From 25334080b9bcdf238f75069feb92fba65896da5e Mon Sep 17 00:00:00 2001 From: William Carroll Date: Sun, 2 Aug 2020 16:07:35 +0100 Subject: [PATCH] Support POST /invite Allow Admin accounts to invite users to the application. --- src/API.hs | 4 ++++ src/App.hs | 36 +++++++++++++++++++++++++++++++----- src/Invitations.hs | 14 ++++++++++++++ src/Types.hs | 27 +++++++++++++++++++++++++++ src/init.sql | 8 ++++++++ 5 files changed, 84 insertions(+), 5 deletions(-) create mode 100644 src/Invitations.hs diff --git a/src/API.hs b/src/API.hs index 956e745b3..caf42727d 100644 --- a/src/API.hs +++ b/src/API.hs @@ -67,3 +67,7 @@ type API = :> SessionCookie :> ReqBody '[JSON] T.UnfreezeAccountRequest :> Post '[JSON] NoContent + :<|> "invite" + :> SessionCookie + :> ReqBody '[JSON] T.InviteUserRequest + :> Post '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index 07203d143..cec8a135b 100644 --- a/src/App.hs +++ b/src/App.hs @@ -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) diff --git a/src/Invitations.hs b/src/Invitations.hs new file mode 100644 index 000000000..62038bb03 --- /dev/null +++ b/src/Invitations.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs index 54f3ec64e..7fe3f2b15 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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" diff --git a/src/init.sql b/src/init.sql index b616fdece..b42753ae5 100644 --- a/src/init.sql +++ b/src/init.sql @@ -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;