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.
This commit is contained in:
William Carroll 2020-08-02 16:30:28 +01:00
parent 25334080b9
commit e9e84f6a08
4 changed files with 77 additions and 19 deletions

View file

@ -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

View file

@ -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 username secret = do
let mSecretUUID = T.RegistrationSecret <$> UUID.fromText secret in do
case mSecretUUID of
Nothing -> throwError err401 { errBody = "Invalid secret format" }
Just secretUUID -> do
verifyAccount :: Text -> T.RegistrationSecret -> Handler NoContent
verifyAccount username 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)

View file

@ -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

View file

@ -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{..}