Support POST /invite

Allow Admin accounts to invite users to the application.

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

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
+sendVerifyEmail T.Config{..} (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do
-  Email.send apiKey subject (cs body) email
+  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)

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)

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"

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;