Support POST /invite

Allow Admin accounts to invite users to the application.
This commit is contained in:
William Carroll 2020-08-02 16:07:35 +01:00
parent fe609bbe58
commit 25334080b9
5 changed files with 84 additions and 5 deletions

View file

@ -67,3 +67,7 @@ type API =
:> SessionCookie
:> ReqBody '[JSON] T.UnfreezeAccountRequest
:> Post '[JSON] NoContent
:<|> "invite"
:> SessionCookie
:> ReqBody '[JSON] T.InviteUserRequest
:> Post '[JSON] NoContent

View file

@ -29,6 +29,7 @@ import qualified Accounts as Accounts
import qualified Auth as Auth
import qualified Trips as Trips
import qualified Sessions as Sessions
import qualified Invitations as Invitations
import qualified LoginAttempts as LoginAttempts
import qualified PendingAccounts as PendingAccounts
--------------------------------------------------------------------------------
@ -43,20 +44,32 @@ err429 = ServerError
-- | Send an email to recipient, `to`, with a secret code.
sendVerifyEmail :: T.Config
-> Text
-> T.Username
-> T.Email
-> T.RegistrationSecret
-> IO (Either Email.SendError Email.SendSuccess)
sendVerifyEmail T.Config{..} apiKey (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do
Email.send apiKey subject (cs body) email
sendVerifyEmail T.Config{..} (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do
Email.send mailgunAPIKey subject (cs body) email
where
subject = "Please confirm your account"
-- TODO(wpcarro): Use a URL encoder
-- TODO(wpcarro): Use a dynamic domain and port number
body =
let secret = secretUUID |> UUID.toString in
cs configServer ++ cs username ++ "&secret=" ++ secret
cs configServer ++ "/verify?username=" ++ cs username ++ "&secret=" ++ secret
-- | Send an invitation email to recipient, `to`, with a secret code.
sendInviteEmail :: T.Config
-> T.Email
-> T.InvitationSecret
-> IO (Either Email.SendError Email.SendSuccess)
sendInviteEmail T.Config{..} email@(T.Email to) (T.InvitationSecret secretUUID) = do
Email.send mailgunAPIKey subject (cs body) email
where
subject = "You've been invited!"
body =
let secret = secretUUID |> UUID.toString in
cs configServer ++ "/accept-invitation?email=" ++ cs to ++ "&secret=" ++ secret
server :: T.Config -> Server API
server config@T.Config{..} = createAccount
@ -70,6 +83,7 @@ server config@T.Config{..} = createAccount
:<|> login
:<|> logout
:<|> unfreezeAccount
:<|> inviteUser
where
-- Admit Admins + whatever the predicate `p` passes.
adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct)
@ -100,7 +114,7 @@ server config@T.Config{..} = createAccount
createAccountRequestPassword
createAccountRequestRole
createAccountRequestEmail
liftIO $ sendVerifyEmail config mailgunAPIKey
liftIO $ sendVerifyEmail config
createAccountRequestUsername
createAccountRequestEmail
secretUUID
@ -219,6 +233,18 @@ server config@T.Config{..} = createAccount
liftIO $ LoginAttempts.reset dbFile unfreezeAccountRequestUsername
pure NoContent
inviteUser :: T.SessionCookie
-> T.InviteUserRequest
-> Handler NoContent
inviteUser cookie T.InviteUserRequest{..} = adminsOnly cookie $ do
secretUUID <- liftIO $ T.InvitationSecret <$> Random.randomIO
liftIO $ Invitations.create dbFile
secretUUID
inviteUserRequestEmail
inviteUserRequestRole
liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID
pure NoContent
run :: T.Config -> IO ()
run config@T.Config{..} =
Warp.run 3000 (enforceCors $ serve (Proxy @ API) $ server config)

14
src/Invitations.hs Normal file
View file

@ -0,0 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Invitations where
--------------------------------------------------------------------------------
import Database.SQLite.Simple
import qualified Types as T
--------------------------------------------------------------------------------
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)

View file

@ -469,3 +469,30 @@ instance FromJSON UnfreezeAccountRequest where
parseJSON = withObject "UnfreezeAccountRequest" $ \x -> do
unfreezeAccountRequestUsername <- x .: "username"
pure UnfreezeAccountRequest{..}
data InviteUserRequest = InviteUserRequest
{ inviteUserRequestEmail :: Email
, inviteUserRequestRole :: Role
} deriving (Eq, Show)
instance FromJSON InviteUserRequest where
parseJSON = withObject "InviteUserRequest" $ \x -> do
inviteUserRequestEmail <- x .: "email"
inviteUserRequestRole <- x .: "role"
pure InviteUserRequest{..}
newtype InvitationSecret = InvitationSecret UUID.UUID
deriving (Eq, Show)
instance ToField InvitationSecret where
toField (InvitationSecret secretUUID) =
secretUUID |> UUID.toText |> SQLText
instance FromField InvitationSecret where
fromField field =
case fieldData field of
(SQLText x) ->
case UUID.fromText x of
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"

View file

@ -11,6 +11,7 @@ DROP TABLE IF EXISTS Trips;
DROP TABLE IF EXISTS Sessions;
DROP TABLE IF EXISTS LoginAttempts;
DROP TABLE IF EXISTS PendingAccounts;
DROP TABLE IF EXISTS Invitations;
CREATE TABLE Accounts (
username TEXT CHECK(LENGTH(username) > 0) NOT NULL,
@ -56,4 +57,11 @@ CREATE TABLE PendingAccounts (
PRIMARY KEY (username)
);
CREATE TABLE Invitations (
email TEXT CHECK(LENGTH(email) > 0) NOT NULL UNIQUE,
role TEXT CHECK(role IN ('user', 'manager', 'admin')) NOT NULL,
secret TEXT CHECK(LENGTH(secret) == 36) NOT NULL,
PRIMARY KEY (email)
);
COMMIT;