Support POST /accept-invitation

Allow users to accept invitations that we email to them.

TL;DR:
- I learned how to write FromHttpApiData instances, which allows me to
  parse/validate data at the edges of my application; this substantially cleans
  up my Handler code.

src/API.hs

@@ -21,7 +21,7 @@ type API =
            :> Post '[JSON] NoContent
       :<|> "verify"
            :> QueryParam' '[Required] "username" Text
-           :> QueryParam' '[Required] "secret" Text
+           :> QueryParam' '[Required] "secret" T.RegistrationSecret
            :> Get '[JSON] NoContent
       -- accounts: Read
       -- accounts: Update
@@ -71,3 +71,6 @@ type API =
            :> SessionCookie
            :> ReqBody '[JSON] T.InviteUserRequest
            :> Post '[JSON] NoContent
+      :<|> "accept-invitation"
+           :> ReqBody '[JSON] T.AcceptInvitationRequest
+           :> Get '[JSON] NoContent

src/App.hs

@@ -84,6 +84,7 @@ server config@T.Config{..} = createAccount
                         :<|> logout
                         :<|> unfreezeAccount
                         :<|> inviteUser
+                        :<|> acceptInvitation
   where
     -- Admit Admins + whatever the predicate `p` passes.
     adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct)
@@ -120,12 +121,8 @@ server config@T.Config{..} = createAccount
             secretUUID
           pure NoContent
 
-    verifyAccount :: Text -> Text -> Handler NoContent
+    verifyAccount :: Text -> T.RegistrationSecret -> Handler NoContent
-    verifyAccount username secret = do
+    verifyAccount username secretUUID = do
-      let mSecretUUID = T.RegistrationSecret <$> UUID.fromText secret in do
-        case mSecretUUID of
-          Nothing -> throwError err401 { errBody = "Invalid secret format" }
-          Just secretUUID -> do
       mPendingAccount <- liftIO $ PendingAccounts.get dbFile (T.Username username)
       case mPendingAccount of
         Nothing ->
@@ -245,6 +242,22 @@ server config@T.Config{..} = createAccount
       liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID
       pure NoContent
 
+    acceptInvitation :: T.AcceptInvitationRequest -> Handler NoContent
+    acceptInvitation T.AcceptInvitationRequest{..} = do
+      mInvitation <- liftIO $ Invitations.get dbFile acceptInvitationRequestEmail
+      case mInvitation of
+        Nothing -> throwError err404 { errBody = "No invitation for email" }
+        Just T.Invitation{..} ->
+          if invitationSecret == acceptInvitationRequestSecret then do
+            liftIO $ Accounts.create dbFile
+              acceptInvitationRequestUsername
+              acceptInvitationRequestPassword
+              invitationEmail
+              invitationRole
+            pure NoContent
+          else
+            throwError err401 { errBody = "You are not providing a valid secret" }
+
 run :: T.Config -> IO ()
 run config@T.Config{..} =
   Warp.run 3000 (enforceCors $ serve (Proxy @ API) $ server config)

src/Invitations.hs

@@ -12,3 +12,10 @@ create :: FilePath -> T.InvitationSecret -> T.Email -> T.Role -> IO ()
 create dbFile secret email role = withConnection dbFile $ \conn -> do
   execute conn "INSERT INTO Invitations (email,role,secret) VALUES (?,?,?)"
     (email, role, secret)
+
+get :: FilePath -> T.Email -> IO (Maybe T.Invitation)
+get dbFile email = withConnection dbFile $ \conn -> do
+  res <- query conn "SELECT email,role,secret FROM Invitations WHERE email = ?" (Only email)
+  case res of
+    [x] -> pure (Just x)
+    _ -> pure Nothing

src/Types.hs

@@ -401,7 +401,13 @@ instance FromHttpApiData SessionCookie where
     x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure
 
 newtype RegistrationSecret = RegistrationSecret UUID.UUID
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
+
+instance FromHttpApiData RegistrationSecret where
+  parseQueryParam x =
+    case UUID.fromText x of
+      Nothing -> Left x
+      Just uuid -> Right (RegistrationSecret uuid)
 
 instance FromField RegistrationSecret where
   fromField field =
@@ -482,7 +488,10 @@ instance FromJSON InviteUserRequest where
     pure InviteUserRequest{..}
 
 newtype InvitationSecret = InvitationSecret UUID.UUID
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
+
+instance ToJSON InvitationSecret
+instance FromJSON InvitationSecret
 
 instance ToField InvitationSecret where
   toField (InvitationSecret secretUUID) =
@@ -496,3 +505,29 @@ instance FromField InvitationSecret where
           Nothing -> returnError ConversionFailed field ("Could not convert text to UUID: " ++ show x)
           Just x -> Ok $ InvitationSecret x
       _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect"
+
+data Invitation = Invitation
+  { invitationEmail :: Email
+  , invitationRole :: Role
+  , invitationSecret :: InvitationSecret
+  } deriving (Eq, Show)
+
+instance FromRow Invitation where
+  fromRow = Invitation <$> field
+                       <*> field
+                       <*> field
+
+data AcceptInvitationRequest = AcceptInvitationRequest
+  { acceptInvitationRequestUsername :: Username
+  , acceptInvitationRequestPassword :: ClearTextPassword
+  , acceptInvitationRequestEmail :: Email
+  , acceptInvitationRequestSecret :: InvitationSecret
+  } deriving (Eq, Show)
+
+instance FromJSON AcceptInvitationRequest where
+  parseJSON = withObject "AcceptInvitationRequest" $ \x -> do
+    acceptInvitationRequestUsername <- x .: "username"
+    acceptInvitationRequestPassword <- x .: "password"
+    acceptInvitationRequestEmail <- x .: "email"
+    acceptInvitationRequestSecret <- x .: "secret"
+    pure AcceptInvitationRequest{..}