Support POST /invite
Allow Admin accounts to invite users to the application.
This commit is contained in:
parent
fe609bbe58
commit
25334080b9
5 changed files with 84 additions and 5 deletions
|
@ -67,3 +67,7 @@ type API =
|
|||
:> SessionCookie
|
||||
:> ReqBody '[JSON] T.UnfreezeAccountRequest
|
||||
:> Post '[JSON] NoContent
|
||||
:<|> "invite"
|
||||
:> SessionCookie
|
||||
:> ReqBody '[JSON] T.InviteUserRequest
|
||||
:> Post '[JSON] NoContent
|
||||
|
|
36
src/App.hs
36
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)
|
||||
|
|
14
src/Invitations.hs
Normal file
14
src/Invitations.hs
Normal 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)
|
27
src/Types.hs
27
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"
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in a new issue