diff options
author | Vincent Ambo <mail@tazj.in> | 2021-12-13T22·51+0300 |
---|---|---|
committer | Vincent Ambo <mail@tazj.in> | 2021-12-13T23·15+0300 |
commit | 019f8fd2113df4c5247c3969c60fd4f0e08f91f7 (patch) | |
tree | 76a857f61aa88f62a30e854651e8439db77fd0ea /users/wpcarro/assessments/tt/src | |
parent | 464bbcb15c09813172c79820bcf526bb10cf4208 (diff) | |
parent | 6123e976928ca3d8d93f0b2006b10b5f659eb74d (diff) |
subtree(users/wpcarro): docking briefcase at '24f5a642' r/3226
git-subtree-dir: users/wpcarro git-subtree-mainline: 464bbcb15c09813172c79820bcf526bb10cf4208 git-subtree-split: 24f5a642af3aa1627bbff977f0a101907a02c69f Change-Id: I6105b3762b79126b3488359c95978cadb3efa789
Diffstat (limited to 'users/wpcarro/assessments/tt/src')
-rw-r--r-- | users/wpcarro/assessments/tt/src/.ghci | 2 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/API.hs | 75 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Accounts.hs | 49 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/App.hs | 270 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Auth.hs | 64 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Email.hs | 46 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Invitations.hs | 21 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/LoginAttempts.hs | 30 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Main.hs | 13 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/PendingAccounts.hs | 32 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Sessions.hs | 74 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Trips.hs | 42 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Types.hs | 544 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/Utils.hs | 9 | ||||
-rw-r--r-- | users/wpcarro/assessments/tt/src/init.sql | 67 |
15 files changed, 1338 insertions, 0 deletions
diff --git a/users/wpcarro/assessments/tt/src/.ghci b/users/wpcarro/assessments/tt/src/.ghci new file mode 100644 index 000000000000..efc88e630ccb --- /dev/null +++ b/users/wpcarro/assessments/tt/src/.ghci @@ -0,0 +1,2 @@ +:set prompt "> " +:set -Wall diff --git a/users/wpcarro/assessments/tt/src/API.hs b/users/wpcarro/assessments/tt/src/API.hs new file mode 100644 index 000000000000..471fa761e0f4 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/API.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +-------------------------------------------------------------------------------- +module API where +-------------------------------------------------------------------------------- +import Data.Text +import Servant.API +import Web.Cookie + +import qualified Types as T +-------------------------------------------------------------------------------- + +-- | Once authenticated, users receive a SessionCookie. +type SessionCookie = Header' '[Required] "Cookie" T.SessionCookie + +type API = + -- accounts: Create + "accounts" + :> Header "Cookie" T.SessionCookie + :> ReqBody '[JSON] T.CreateAccountRequest + :> Post '[JSON] NoContent + :<|> "verify" + :> ReqBody '[JSON] T.VerifyAccountRequest + :> Post '[JSON] NoContent + -- accounts: Read + -- accounts: Update + -- accounts: Delete + :<|> "accounts" + :> SessionCookie + :> QueryParam' '[Required] "username" Text + :> Delete '[JSON] NoContent + -- accounts: List + :<|> "accounts" + :> SessionCookie + :> Get '[JSON] [T.User] + + -- trips: Create + :<|> "trips" + :> SessionCookie + :> ReqBody '[JSON] T.Trip + :> Post '[JSON] NoContent + -- trips: Read + -- trips: Update + :<|> "trips" + :> SessionCookie + :> ReqBody '[JSON] T.UpdateTripRequest + :> Put '[JSON] NoContent + -- trips: Delete + :<|> "trips" + :> SessionCookie + :> ReqBody '[JSON] T.TripPK + :> Delete '[JSON] NoContent + -- trips: List + :<|> "trips" + :> SessionCookie + :> Get '[JSON] [T.Trip] + + -- Miscellaneous + :<|> "login" + :> ReqBody '[JSON] T.AccountCredentials + :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] T.Session) + :<|> "logout" + :> SessionCookie + :> Get '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) + :<|> "unfreeze" + :> SessionCookie + :> ReqBody '[JSON] T.UnfreezeAccountRequest + :> Post '[JSON] NoContent + :<|> "invite" + :> SessionCookie + :> ReqBody '[JSON] T.InviteUserRequest + :> Post '[JSON] NoContent + :<|> "accept-invitation" + :> ReqBody '[JSON] T.AcceptInvitationRequest + :> Post '[JSON] NoContent diff --git a/users/wpcarro/assessments/tt/src/Accounts.hs b/users/wpcarro/assessments/tt/src/Accounts.hs new file mode 100644 index 000000000000..c7ab7a2f135f --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Accounts.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module Accounts where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple + +import qualified PendingAccounts +import qualified Types as T +-------------------------------------------------------------------------------- + +-- | Delete the account in PendingAccounts and create on in Accounts. +transferFromPending :: FilePath -> T.PendingAccount -> IO () +transferFromPending dbFile T.PendingAccount{..} = withConnection dbFile $ + \conn -> withTransaction conn $ do + PendingAccounts.delete dbFile pendingAccountUsername + execute conn "INSERT INTO Accounts (username,password,email,role) VALUES (?,?,?,?)" + ( pendingAccountUsername + , pendingAccountPassword + , pendingAccountEmail + , pendingAccountRole + ) + +-- | Create a new account in the Accounts table. +create :: FilePath -> T.Username -> T.ClearTextPassword -> T.Email -> T.Role -> IO () +create dbFile username password email role = withConnection dbFile $ \conn -> do + hashed <- T.hashPassword password + execute conn "INSERT INTO Accounts (username,password,email,role) VALUES (?,?,?,?)" + (username, hashed, email, role) + +-- | Delete `username` from `dbFile`. +delete :: FilePath -> T.Username -> IO () +delete dbFile username = withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Accounts WHERE username = ?" + (Only username) + +-- | Attempt to find `username` in the Account table of `dbFile`. +lookup :: FilePath -> T.Username -> IO (Maybe T.Account) +lookup dbFile username = withConnection dbFile $ \conn -> do + res <- query conn "SELECT username,password,email,role,profilePicture FROM Accounts WHERE username = ?" (Only username) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +-- | Return a list of accounts with the sensitive data removed. +list :: FilePath -> IO [T.User] +list dbFile = withConnection dbFile $ \conn -> do + accounts <- query_ conn "SELECT username,password,email,role,profilePicture FROM Accounts" + pure $ T.userFromAccount <$> accounts diff --git a/users/wpcarro/assessments/tt/src/App.hs b/users/wpcarro/assessments/tt/src/App.hs new file mode 100644 index 000000000000..742bc962dc55 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/App.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +-------------------------------------------------------------------------------- +module App where +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class (liftIO) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Servant +import API +import Utils +import Web.Cookie + +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.Cors as Cors +import qualified System.Random as Random +import qualified Email as Email +import qualified Data.UUID as UUID +import qualified Types as T +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 +-------------------------------------------------------------------------------- + +err429 :: ServerError +err429 = ServerError + { errHTTPCode = 429 + , errReasonPhrase = "Too many requests" + , errBody = "" + , errHeaders = [] + } + +-- | Send an email to recipient, `to`, with a secret code. +sendVerifyEmail :: T.Config + -> T.Username + -> T.Email + -> T.RegistrationSecret + -> IO (Either Email.SendError Email.SendSuccess) +sendVerifyEmail T.Config{..} (T.Username username) email (T.RegistrationSecret secretUUID) = do + Email.send mailgunAPIKey subject (cs body) email + where + subject = "Please confirm your account" + body = + let secret = secretUUID |> UUID.toString in + "To verify your account: POST /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 + "To accept the invitation: POST /accept-invitation username=<username> password=<password> email=" ++ cs to ++ " secret=" ++ secret + +server :: T.Config -> Server API +server config@T.Config{..} = createAccount + :<|> verifyAccount + :<|> deleteAccount + :<|> listAccounts + :<|> createTrip + :<|> updateTrip + :<|> deleteTrip + :<|> listTrips + :<|> login + :<|> 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) + -- Admit Admins only. + adminsOnly cookie = adminsAnd cookie (const True) + + -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s + createAccount :: Maybe T.SessionCookie + -> T.CreateAccountRequest + -> Handler NoContent + createAccount mCookie T.CreateAccountRequest{..} = + case (mCookie, createAccountRequestRole) of + (_, T.RegularUser) -> + doCreateAccount + (Nothing, T.Manager) -> + throwError err401 { errBody = "Only admins can create Manager accounts" } + (Nothing, T.Admin) -> + throwError err401 { errBody = "Only admins can create Admin accounts" } + (Just cookie, _) -> + adminsAnd cookie (\T.Account{..} -> accountRole == T.Manager) doCreateAccount + where + doCreateAccount :: Handler NoContent + doCreateAccount = do + secretUUID <- liftIO $ T.RegistrationSecret <$> Random.randomIO + liftIO $ PendingAccounts.create dbFile + secretUUID + createAccountRequestUsername + createAccountRequestPassword + createAccountRequestRole + createAccountRequestEmail + res <- liftIO $ sendVerifyEmail config + createAccountRequestUsername + createAccountRequestEmail + secretUUID + case res of + Left _ -> undefined + Right _ -> pure NoContent + + verifyAccount :: T.VerifyAccountRequest -> Handler NoContent + verifyAccount T.VerifyAccountRequest{..} = do + mPendingAccount <- liftIO $ PendingAccounts.get dbFile verifyAccountRequestUsername + case mPendingAccount of + Nothing -> + throwError err401 { errBody = "Either your secret or your username (or both) is invalid" } + Just pendingAccount@T.PendingAccount{..} -> + if pendingAccountSecret == verifyAccountRequestSecret then do + liftIO $ Accounts.transferFromPending dbFile pendingAccount + pure NoContent + else + throwError err401 { errBody = "The secret you provided is invalid" } + + deleteAccount :: T.SessionCookie -> Text -> Handler NoContent + deleteAccount cookie username = adminsOnly cookie $ do + liftIO $ Accounts.delete dbFile (T.Username username) + pure NoContent + + listAccounts :: T.SessionCookie -> Handler [T.User] + listAccounts cookie = adminsOnly cookie $ do + liftIO $ Accounts.list dbFile + + createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent + createTrip cookie trip@T.Trip{..} = + adminsAnd cookie (\T.Account{..} -> accountUsername == tripUsername) $ do + liftIO $ Trips.create dbFile trip + pure NoContent + + updateTrip :: T.SessionCookie -> T.UpdateTripRequest -> Handler NoContent + updateTrip cookie updates@T.UpdateTripRequest{..} = + adminsAnd cookie (\T.Account{..} -> accountUsername == T.tripPKUsername updateTripRequestTripPK) $ do + mTrip <- liftIO $ Trips.get dbFile updateTripRequestTripPK + case mTrip of + Nothing -> throwError err400 { errBody = "tripKey is invalid" } + Just trip@T.Trip{..} -> do + -- TODO(wpcarro): Prefer function in Trips module that does this in a + -- DB transaction. + liftIO $ Trips.delete dbFile updateTripRequestTripPK + liftIO $ Trips.create dbFile (T.updateTrip updates trip) + pure NoContent + + deleteTrip :: T.SessionCookie -> T.TripPK -> Handler NoContent + deleteTrip cookie tripPK@T.TripPK{..} = + adminsAnd cookie (\T.Account{..} -> accountUsername == tripPKUsername) $ do + liftIO $ Trips.delete dbFile tripPK + pure NoContent + + listTrips :: T.SessionCookie -> Handler [T.Trip] + listTrips cookie = do + mAccount <- liftIO $ Auth.accountFromCookie dbFile cookie + case mAccount of + Nothing -> throwError err401 { errBody = "Your session cookie is invalid. Try logging out and logging back in." } + Just T.Account{..} -> + case accountRole of + T.Admin -> liftIO $ Trips.listAll dbFile + _ -> liftIO $ Trips.list dbFile accountUsername + + login :: T.AccountCredentials + -> Handler (Headers '[Header "Set-Cookie" SetCookie] T.Session) + login (T.AccountCredentials username password) = do + mAccount <- liftIO $ Accounts.lookup dbFile username + case mAccount of + Just account@T.Account{..} -> do + mAttempts <- liftIO $ LoginAttempts.forUsername dbFile accountUsername + case mAttempts of + Nothing -> + if T.passwordsMatch password accountPassword then do + uuid <- liftIO $ Sessions.findOrCreate dbFile account + pure $ addHeader (Auth.mkCookie uuid) + T.Session{ sessionUsername = accountUsername + , sessionRole = accountRole + } + else do + liftIO $ LoginAttempts.increment dbFile username + throwError err401 { errBody = "Your credentials are invalid" } + Just attempts -> + if attempts >= 3 then + throwError err429 + else if T.passwordsMatch password accountPassword then do + uuid <- liftIO $ Sessions.findOrCreate dbFile account + pure $ addHeader (Auth.mkCookie uuid) + T.Session{ sessionUsername = accountUsername + , sessionRole = accountRole + } + else do + liftIO $ LoginAttempts.increment dbFile username + throwError err401 { errBody = "Your credentials are invalid" } + + -- In this branch, the user didn't supply a known username. + Nothing -> throwError err401 { errBody = "Your credentials are invalid" } + + logout :: T.SessionCookie + -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent) + logout cookie = do + case Auth.uuidFromCookie cookie of + Nothing -> + pure $ addHeader Auth.emptyCookie NoContent + Just uuid -> do + liftIO $ Sessions.delete dbFile uuid + pure $ addHeader Auth.emptyCookie NoContent + + unfreezeAccount :: T.SessionCookie + -> T.UnfreezeAccountRequest + -> Handler NoContent + unfreezeAccount cookie T.UnfreezeAccountRequest{..} = + adminsAnd cookie (\T.Account{..} -> accountRole == T.Manager) $ do + 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 + res <- liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID + case res of + Left _ -> undefined + Right _ -> 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) + where + enforceCors = Cors.cors (const $ Just corsPolicy) + corsPolicy :: Cors.CorsResourcePolicy + corsPolicy = + Cors.simpleCorsResourcePolicy + { Cors.corsOrigins = Just ([cs configClient], True) + , Cors.corsMethods = Cors.simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] + , Cors.corsRequestHeaders = Cors.simpleHeaders ++ ["Content-Type", "Authorization"] + } diff --git a/users/wpcarro/assessments/tt/src/Auth.hs b/users/wpcarro/assessments/tt/src/Auth.hs new file mode 100644 index 000000000000..f1bff23257e0 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Auth.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Auth where +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class (liftIO) +import Web.Cookie +import Servant + +import qualified Data.UUID as UUID +import qualified Sessions as Sessions +import qualified Accounts as Accounts +import qualified Types as T +-------------------------------------------------------------------------------- + +-- | Return the UUID from a Session cookie. +uuidFromCookie :: T.SessionCookie -> Maybe T.SessionUUID +uuidFromCookie (T.SessionCookie cookies) = do + auth <- lookup "auth" cookies + uuid <- UUID.fromASCIIBytes auth + pure $ T.SessionUUID uuid + +-- | Attempt to return the account associated with `cookie`. +accountFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Account) +accountFromCookie dbFile cookie = + case uuidFromCookie cookie of + Nothing -> pure Nothing + Just uuid -> do + mSession <- Sessions.get dbFile uuid + case mSession of + Nothing -> pure Nothing + Just T.StoredSession{..} -> do + mAccount <- Accounts.lookup dbFile storedSessionUsername + case mAccount of + Nothing -> pure Nothing + Just x -> pure (Just x) + +-- | Create a new session cookie. +mkCookie :: T.SessionUUID -> SetCookie +mkCookie (T.SessionUUID uuid) = + defaultSetCookie + { setCookieName = "auth" + , setCookieValue = UUID.toASCIIBytes uuid + } + +-- | Use this to clear out the session cookie. +emptyCookie :: SetCookie +emptyCookie = + defaultSetCookie + { setCookieName = "auth" + , setCookieValue = "" + } + +-- | Throw a 401 error if the `predicate` fails. +assert :: FilePath -> T.SessionCookie -> (T.Account -> Bool) -> Handler a -> Handler a +assert dbFile cookie predicate handler = do + mRole <- liftIO $ accountFromCookie dbFile cookie + case mRole of + Nothing -> throwError err401 { errBody = "Missing valid session cookie" } + Just account -> + if predicate account then + handler + else + throwError err401 { errBody = "You are not authorized to access this resource" } diff --git a/users/wpcarro/assessments/tt/src/Email.hs b/users/wpcarro/assessments/tt/src/Email.hs new file mode 100644 index 000000000000..2dac0973ba6d --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Email.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module Email where +-------------------------------------------------------------------------------- +import Data.Text +import Data.String.Conversions (cs) +import Utils + +import qualified Mail.Hailgun as MG +import qualified Types as T +-------------------------------------------------------------------------------- + +newtype SendSuccess = SendSuccess MG.HailgunSendResponse + +data SendError + = MessageError MG.HailgunErrorMessage + | ResponseError MG.HailgunErrorResponse + +-- | Attempt to send an email with `subject` and with message, `body`. +send :: Text + -> Text + -> Text + -> T.Email + -> IO (Either SendError SendSuccess) +send apiKey subject body (T.Email to) = do + case mkMsg of + Left e -> pure $ Left (MessageError e) + Right x -> do + res <- MG.sendEmail ctx x + case res of + Left e -> pure $ Left (ResponseError e) + Right y -> pure $ Right (SendSuccess y) + where + ctx = MG.HailgunContext { MG.hailgunDomain = "sandboxda5038873f924b50af2f82a0f05cffdf.mailgun.org" + , MG.hailgunApiKey = cs apiKey + , MG.hailgunProxy = Nothing + } + mkMsg = MG.hailgunMessage + subject + (body |> cs |> MG.TextOnly) + "mailgun@sandboxda5038873f924b50af2f82a0f05cffdf.mailgun.org" + (MG.MessageRecipients { MG.recipientsTo = [cs to] + , MG.recipientsCC = [] + , MG.recipientsBCC = [] + }) + [] diff --git a/users/wpcarro/assessments/tt/src/Invitations.hs b/users/wpcarro/assessments/tt/src/Invitations.hs new file mode 100644 index 000000000000..0c700470f3e2 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Invitations.hs @@ -0,0 +1,21 @@ +{-# 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) + +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 diff --git a/users/wpcarro/assessments/tt/src/LoginAttempts.hs b/users/wpcarro/assessments/tt/src/LoginAttempts.hs new file mode 100644 index 000000000000..d78e12e3fd8a --- /dev/null +++ b/users/wpcarro/assessments/tt/src/LoginAttempts.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module LoginAttempts where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple + +import qualified Types as T +-------------------------------------------------------------------------------- + +reset :: FilePath -> T.Username -> IO () +reset dbFile username = withConnection dbFile $ \conn -> + execute conn "UPDATE LoginAttempts SET numAttempts = 0 WHERE username = ?" + (Only username) + +-- | Attempt to return the number of failed login attempts for +-- `username`. Returns a Maybe in case `username` doesn't exist. +forUsername :: FilePath -> T.Username -> IO (Maybe Integer) +forUsername dbFile username = withConnection dbFile $ \conn -> do + res <- query conn "SELECT username,numAttempts FROM LoginAttempts WHERE username = ?" + (Only username) + case res of + [T.LoginAttempt{..}] -> pure (Just loginAttemptNumAttempts) + _ -> pure Nothing + +-- | INSERT a failed login attempt for `username` or UPDATE an existing entry. +increment :: FilePath -> T.Username -> IO () +increment dbFile username = withConnection dbFile $ \conn -> + execute conn "INSERT INTO LoginAttempts (username,numAttempts) VALUES (?,?) ON CONFLICT (username) DO UPDATE SET numAttempts = numAttempts + 1" + (username, 1 :: Integer) diff --git a/users/wpcarro/assessments/tt/src/Main.hs b/users/wpcarro/assessments/tt/src/Main.hs new file mode 100644 index 000000000000..9df4232066bb --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Main.hs @@ -0,0 +1,13 @@ +-------------------------------------------------------------------------------- +module Main where +-------------------------------------------------------------------------------- +import qualified App +import qualified System.Envy as Envy +-------------------------------------------------------------------------------- + +main :: IO () +main = do + mEnv <- Envy.decodeEnv + case mEnv of + Left err -> putStrLn err + Right env -> App.run env diff --git a/users/wpcarro/assessments/tt/src/PendingAccounts.hs b/users/wpcarro/assessments/tt/src/PendingAccounts.hs new file mode 100644 index 000000000000..a555185fa717 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/PendingAccounts.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module PendingAccounts where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple + +import qualified Types as T +-------------------------------------------------------------------------------- + +create :: FilePath + -> T.RegistrationSecret + -> T.Username + -> T.ClearTextPassword + -> T.Role + -> T.Email + -> IO () +create dbFile secret username password role email = withConnection dbFile $ \conn -> do + hashed <- T.hashPassword password + execute conn "INSERT INTO PendingAccounts (secret,username,password,role,email) VALUES (?,?,?,?,?)" + (secret, username, hashed, role, email) + +get :: FilePath -> T.Username -> IO (Maybe T.PendingAccount) +get dbFile username = withConnection dbFile $ \conn -> do + res <- query conn "SELECT secret,username,password,role,email FROM PendingAccounts WHERE username = ?" (Only username) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +delete :: FilePath -> T.Username -> IO () +delete dbFile username = withConnection dbFile $ \conn -> + execute conn "DELETE FROM PendingAccounts WHERE username = ?" (Only username) diff --git a/users/wpcarro/assessments/tt/src/Sessions.hs b/users/wpcarro/assessments/tt/src/Sessions.hs new file mode 100644 index 000000000000..713059a38383 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Sessions.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +module Sessions where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple + +import qualified Data.Time.Clock as Clock +import qualified Types as T +import qualified System.Random as Random +-------------------------------------------------------------------------------- + +-- | Return True if `session` was created at most three hours ago. +isValid :: T.StoredSession -> IO Bool +isValid session = do + t1 <- Clock.getCurrentTime + let t0 = T.storedSessionTsCreated session in + pure $ Clock.diffUTCTime t1 t0 <= 3 * 60 * 60 + +-- | Lookup the session by UUID. +get :: FilePath -> T.SessionUUID -> IO (Maybe T.StoredSession) +get dbFile uuid = withConnection dbFile $ \conn -> do + res <- query conn "SELECT uuid,username,tsCreated FROM Sessions WHERE uuid = ?" (Only uuid) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +-- | Lookup the session stored under `username` in `dbFile`. +find :: FilePath -> T.Username -> IO (Maybe T.StoredSession) +find dbFile username = withConnection dbFile $ \conn -> do + res <- query conn "SELECT uuid,username,tsCreated FROM Sessions WHERE username = ?" (Only username) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +-- | Create a session under the `username` key in `dbFile`. +create :: FilePath -> T.Username -> IO T.SessionUUID +create dbFile username = withConnection dbFile $ \conn -> do + now <- Clock.getCurrentTime + uuid <- Random.randomIO + execute conn "INSERT INTO Sessions (uuid,username,tsCreated) VALUES (?,?,?)" + (T.SessionUUID uuid, username, now) + pure (T.SessionUUID uuid) + +-- | Reset the tsCreated field to the current time to ensure the token is valid. +refresh :: FilePath -> T.SessionUUID -> IO () +refresh dbFile uuid = withConnection dbFile $ \conn -> do + now <- Clock.getCurrentTime + execute conn "UPDATE Sessions SET tsCreated = ? WHERE uuid = ?" + (now, uuid) + pure () + +-- | Delete the session under `username` from `dbFile`. +delete :: FilePath -> T.SessionUUID -> IO () +delete dbFile uuid = withConnection dbFile $ \conn -> + execute conn "DELETE FROM Sessions WHERE uuid = ?" (Only uuid) + +-- | Find or create a session in the Sessions table. If a session exists, +-- refresh the token's validity. +findOrCreate :: FilePath -> T.Account -> IO T.SessionUUID +findOrCreate dbFile account = + let username = T.accountUsername account in do + mSession <- find dbFile username + case mSession of + Nothing -> create dbFile username + Just session -> + let uuid = T.storedSessionUUID session in do + refresh dbFile uuid + pure uuid + +-- | Return a list of all sessions in the Sessions table. +list :: FilePath -> IO [T.StoredSession] +list dbFile = withConnection dbFile $ \conn -> + query_ conn "SELECT uuid,username,tsCreated FROM Sessions" diff --git a/users/wpcarro/assessments/tt/src/Trips.hs b/users/wpcarro/assessments/tt/src/Trips.hs new file mode 100644 index 000000000000..f90740363c52 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Trips.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +module Trips where +-------------------------------------------------------------------------------- +import Database.SQLite.Simple +import Utils + +import qualified Types as T +-------------------------------------------------------------------------------- + +-- | Create a new `trip` in `dbFile`. +create :: FilePath -> T.Trip -> IO () +create dbFile trip = withConnection dbFile $ \conn -> + execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)" + (trip |> T.tripFields) + +-- | Attempt to get the trip record from `dbFile` under `tripKey`. +get :: FilePath -> T.TripPK -> IO (Maybe T.Trip) +get dbFile tripKey = withConnection dbFile $ \conn -> do + res <- query conn "SELECT username,destination,startDate,endDate,comment FROM Trips WHERE username = ? AND destination = ? AND startDate = ? LIMIT 1" + (T.tripPKFields tripKey) + case res of + [x] -> pure (Just x) + _ -> pure Nothing + +-- | Delete a trip from `dbFile` using its `tripKey` Primary Key. +delete :: FilePath -> T.TripPK -> IO () +delete dbFile tripKey = + withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?" + (T.tripPKFields tripKey) + +-- | Return a list of all of the trips in `dbFile`. +listAll :: FilePath -> IO [T.Trip] +listAll dbFile = withConnection dbFile $ \conn -> + query_ conn "SELECT username,destination,startDate,endDate,comment FROM Trips ORDER BY date(startDate) ASC" + +-- | Return a list of all of the trips in `dbFile`. +list :: FilePath -> T.Username -> IO [T.Trip] +list dbFile username = withConnection dbFile $ \conn -> + query conn "SELECT username,destination,startDate,endDate,comment FROM Trips WHERE username = ? ORDER BY date(startDate) ASC" + (Only username) diff --git a/users/wpcarro/assessments/tt/src/Types.hs b/users/wpcarro/assessments/tt/src/Types.hs new file mode 100644 index 000000000000..6b06a39694fc --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Types.hs @@ -0,0 +1,544 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +-------------------------------------------------------------------------------- +module Types where +-------------------------------------------------------------------------------- +import Data.Aeson +import Utils +import Data.Text +import Data.Typeable +import Database.SQLite.Simple +import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField +import GHC.Generics +import Web.Cookie +import Servant.API +import System.Envy (FromEnv, fromEnv, env) +import Crypto.Random.Types (MonadRandom) + +import qualified Data.Time.Calendar as Calendar +import qualified Crypto.KDF.BCrypt as BC +import qualified Data.Time.Clock as Clock +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE +import qualified Data.Maybe as M +import qualified Data.UUID as UUID +-------------------------------------------------------------------------------- + +-- | Top-level application configuration. +data Config = Config + { mailgunAPIKey :: Text + , dbFile :: FilePath + , configClient :: Text + , configServer :: Text + } deriving (Eq, Show) + +instance FromEnv Config where + fromEnv _ = do + mailgunAPIKey <- env "MAILGUN_API_KEY" + dbFile <- env "DB_FILE" + configClient <- env "CLIENT" + configServer <- env "SERVER" + pure Config {..} + +-- TODO(wpcarro): Properly handle NULL for columns like profilePicture. +forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b +forNewtype wrapper y = + case fieldData y of + (SQLText x) -> Ok (wrapper x) + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) + +newtype Username = Username Text + deriving (Eq, Show, Generic) + +instance ToJSON Username +instance FromJSON Username + +instance ToField Username where + toField (Username x) = SQLText x + +instance FromField Username where + fromField = forNewtype Username + +newtype HashedPassword = HashedPassword BS.ByteString + deriving (Eq, Show, Generic) + +instance ToField HashedPassword where + toField (HashedPassword x) = SQLText (TE.decodeUtf8 x) + +instance FromField HashedPassword where + fromField y = + case fieldData y of + (SQLText x) -> x |> TE.encodeUtf8 |> HashedPassword |> Ok + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) + +newtype ClearTextPassword = ClearTextPassword Text + deriving (Eq, Show, Generic) + +instance ToJSON ClearTextPassword +instance FromJSON ClearTextPassword + +instance ToField ClearTextPassword where + toField (ClearTextPassword x) = SQLText x + +instance FromField ClearTextPassword where + fromField = forNewtype ClearTextPassword + +newtype Email = Email Text + deriving (Eq, Show, Generic) + +instance ToJSON Email +instance FromJSON Email + +instance ToField Email where + toField (Email x) = SQLText x + +instance FromField Email where + fromField = forNewtype Email + +data Role = RegularUser | Manager | Admin + deriving (Eq, Show, Generic) + +instance ToJSON Role where + toJSON RegularUser = "user" + toJSON Manager = "manager" + toJSON Admin = "admin" + +instance FromJSON Role where + parseJSON = withText "Role" $ \x -> + case x of + "user" -> pure RegularUser + "manager" -> pure Manager + "admin" -> pure Admin + _ -> fail "Expected \"user\" or \"manager\" or \"admin\"" + +instance ToField Role where + toField RegularUser = SQLText "user" + toField Manager = SQLText "manager" + toField Admin = SQLText "admin" + +instance FromField Role where + fromField y = + case fieldData y of + (SQLText "user") -> Ok RegularUser + (SQLText "manager") -> Ok Manager + (SQLText "admin") -> Ok Admin + x -> returnError ConversionFailed y ("We expected user, manager, admin, but we received: " ++ show x) + +-- TODO(wpcarro): Prefer Data.ByteString instead of Text +newtype ProfilePicture = ProfilePicture Text + deriving (Eq, Show, Generic) + +instance ToJSON ProfilePicture +instance FromJSON ProfilePicture + +instance ToField ProfilePicture where + toField (ProfilePicture x) = SQLText x + +instance FromField ProfilePicture where + fromField = forNewtype ProfilePicture + +data Account = Account + { accountUsername :: Username + , accountPassword :: HashedPassword + , accountEmail :: Email + , accountRole :: Role + , accountProfilePicture :: Maybe ProfilePicture + } deriving (Eq, Show, Generic) + +-- | Return a tuple with all of the fields for an Account record to use for SQL. +accountFields :: Account -> (Username, HashedPassword, Email, Role, Maybe ProfilePicture) +accountFields (Account {..}) + = ( accountUsername + , accountPassword + , accountEmail + , accountRole + , accountProfilePicture + ) + +instance FromRow Account where + fromRow = do + accountUsername <- field + accountPassword <- field + accountEmail <- field + accountRole <- field + accountProfilePicture <- field + pure Account{..} + +data Session = Session + { sessionUsername :: Username + , sessionRole :: Role + } deriving (Eq, Show) + +instance ToJSON Session where + toJSON (Session username role) = + object [ "username" .= username + , "role" .= role + ] + +newtype Comment = Comment Text + deriving (Eq, Show, Generic) + +instance ToJSON Comment +instance FromJSON Comment + +instance ToField Comment where + toField (Comment x) = SQLText x + +instance FromField Comment where + fromField = forNewtype Comment + +newtype Destination = Destination Text + deriving (Eq, Show, Generic) + +instance ToJSON Destination +instance FromJSON Destination + +instance ToField Destination where + toField (Destination x) = SQLText x + +instance FromField Destination where + fromField = forNewtype Destination + +newtype Year = Year Integer deriving (Eq, Show) +newtype Month = Month Integer deriving (Eq, Show) +newtype Day = Day Integer deriving (Eq, Show) +data Date = Date + { dateYear :: Year + , dateMonth :: Month + , dateDay :: Day + } deriving (Eq, Show) + +data Trip = Trip + { tripUsername :: Username + , tripDestination :: Destination + , tripStartDate :: Calendar.Day + , tripEndDate :: Calendar.Day + , tripComment :: Comment + } deriving (Eq, Show, Generic) + +instance FromRow Trip where + fromRow = do + tripUsername <- field + tripDestination <- field + tripStartDate <- field + tripEndDate <- field + tripComment <- field + pure Trip{..} + +-- | The fields used as the Primary Key for a Trip entry. +data TripPK = TripPK + { tripPKUsername :: Username + , tripPKDestination :: Destination + , tripPKStartDate :: Calendar.Day + } deriving (Eq, Show, Generic) + +tripPKFields :: TripPK -> (Username, Destination, Calendar.Day) +tripPKFields (TripPK{..}) + = (tripPKUsername, tripPKDestination, tripPKStartDate) + +instance FromJSON TripPK where + parseJSON = withObject "TripPK" $ \x -> do + tripPKUsername <- x .: "username" + tripPKDestination <- x .: "destination" + tripPKStartDate <- x .: "startDate" + pure TripPK{..} + +-- | Return the tuple representation of a Trip record for SQL. +tripFields :: Trip + -> (Username, Destination, Calendar.Day, Calendar.Day, Comment) +tripFields (Trip{..}) + = ( tripUsername + , tripDestination + , tripStartDate + , tripEndDate + , tripComment + ) + +instance ToJSON Trip where + toJSON (Trip username destination startDate endDate comment) = + object [ "username" .= username + , "destination" .= destination + , "startDate" .= startDate + , "endDate" .= endDate + , "comment" .= comment + ] + +instance FromJSON Trip where + parseJSON = withObject "Trip" $ \x -> do + tripUsername <- x .: "username" + tripDestination <- x .: "destination" + tripStartDate <- x .: "startDate" + tripEndDate <- x .: "endDate" + tripComment <- x .: "comment" + pure Trip{..} + +-- | Users and Accounts both refer to the same underlying entities; however, +-- Users model the user-facing Account details, hiding sensitive details like +-- passwords and emails. +data User = User + { userUsername :: Username + , userProfilePicture :: Maybe ProfilePicture + , userRole :: Role + } deriving (Eq, Show, Generic) + +instance ToJSON User where + toJSON (User username profilePicture role) = + object [ "username" .= username + , "profilePicture" .= profilePicture + , "role" .= role + ] + +userFromAccount :: Account -> User +userFromAccount account = + User { userUsername = accountUsername account + , userProfilePicture = accountProfilePicture account + , userRole = accountRole account + } + +-- | This is the data that a user needs to supply to authenticate with the +-- application. +data AccountCredentials = AccountCredentials + { accountCredentialsUsername :: Username + , accountCredentialsPassword :: ClearTextPassword + } deriving (Eq, Show, Generic) + +instance FromJSON AccountCredentials where + parseJSON = withObject "AccountCredentials" $ \x -> do + accountCredentialsUsername <- x.: "username" + accountCredentialsPassword <- x.: "password" + pure AccountCredentials{..} + + +-- | Hash password `x`. +hashPassword :: (MonadRandom m) => ClearTextPassword -> m HashedPassword +hashPassword (ClearTextPassword x) = do + hashed <- BC.hashPassword 12 (x |> unpack |> B.pack) + pure $ HashedPassword hashed + +-- | Return True if the cleartext password matches the hashed password. +passwordsMatch :: ClearTextPassword -> HashedPassword -> Bool +passwordsMatch (ClearTextPassword clear) (HashedPassword hashed) = + BC.validatePassword (clear |> unpack |> B.pack) hashed + +data CreateAccountRequest = CreateAccountRequest + { createAccountRequestUsername :: Username + , createAccountRequestPassword :: ClearTextPassword + , createAccountRequestEmail :: Email + , createAccountRequestRole :: Role + } deriving (Eq, Show) + +instance FromJSON CreateAccountRequest where + parseJSON = withObject "CreateAccountRequest" $ \x -> do + createAccountRequestUsername <- x .: "username" + createAccountRequestPassword <- x .: "password" + createAccountRequestEmail <- x .: "email" + createAccountRequestRole <- x .: "role" + pure $ CreateAccountRequest{..} + +createAccountRequestFields :: CreateAccountRequest + -> (Username, ClearTextPassword, Email, Role) +createAccountRequestFields CreateAccountRequest{..} = + ( createAccountRequestUsername + , createAccountRequestPassword + , createAccountRequestEmail + , createAccountRequestRole + ) + +newtype SessionUUID = SessionUUID UUID.UUID + deriving (Eq, Show, Generic) + +instance FromField SessionUUID where + fromField y = + case fieldData y of + (SQLText x) -> + case UUID.fromText x of + Nothing -> returnError ConversionFailed y ("Could not convert to UUID: " ++ show x) + Just uuid -> Ok $ SessionUUID uuid + _ -> returnError ConversionFailed y "Expected SQLText for SessionUUID, but we received" + +instance ToField SessionUUID where + toField (SessionUUID uuid) = + uuid |> UUID.toText |> SQLText + +data StoredSession = StoredSession + { storedSessionUUID :: SessionUUID + , storedSessionUsername :: Username + , storedSessionTsCreated :: Clock.UTCTime + } deriving (Eq, Show, Generic) + +instance FromRow StoredSession where + fromRow = do + storedSessionUUID <- field + storedSessionUsername <- field + storedSessionTsCreated <- field + pure StoredSession {..} + +data LoginAttempt = LoginAttempt + { loginAttemptUsername :: Username + , loginAttemptNumAttempts :: Integer + } deriving (Eq, Show) + +instance FromRow LoginAttempt where + fromRow = do + loginAttemptUsername <- field + loginAttemptNumAttempts <- field + pure LoginAttempt {..} + +newtype SessionCookie = SessionCookie Cookies + +instance FromHttpApiData SessionCookie where + parseHeader x = + x |> parseCookies |> SessionCookie |> pure + parseQueryParam x = + x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure + +newtype RegistrationSecret = RegistrationSecret UUID.UUID + 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 y = + case fieldData y of + (SQLText x) -> + case UUID.fromText x of + Nothing -> returnError ConversionFailed y ("Could not convert text to UUID: " ++ show x) + Just uuid -> Ok $ RegistrationSecret uuid + _ -> returnError ConversionFailed y "Field data is not SQLText, which is what we expect" + +instance ToField RegistrationSecret where + toField (RegistrationSecret secretUUID) = + secretUUID |> UUID.toText |> SQLText + +instance FromJSON RegistrationSecret + +data VerifyAccountRequest = VerifyAccountRequest + { verifyAccountRequestUsername :: Username + , verifyAccountRequestSecret :: RegistrationSecret + } deriving (Eq, Show) + +instance FromJSON VerifyAccountRequest where + parseJSON = withObject "VerifyAccountRequest" $ \x -> do + verifyAccountRequestUsername <- x .: "username" + verifyAccountRequestSecret <- x .: "secret" + pure VerifyAccountRequest{..} + +data PendingAccount = PendingAccount + { pendingAccountSecret :: RegistrationSecret + , pendingAccountUsername :: Username + , pendingAccountPassword :: HashedPassword + , pendingAccountRole :: Role + , pendingAccountEmail :: Email + } deriving (Eq, Show) + +instance FromRow PendingAccount where + fromRow = do + pendingAccountSecret <- field + pendingAccountUsername <- field + pendingAccountPassword <- field + pendingAccountRole <- field + pendingAccountEmail <- field + pure PendingAccount {..} + +data UpdateTripRequest = UpdateTripRequest + { updateTripRequestTripPK :: TripPK + , updateTripRequestDestination :: Maybe Destination + , updateTripRequestStartDate :: Maybe Calendar.Day + , updateTripRequestEndDate :: Maybe Calendar.Day + , updateTripRequestComment :: Maybe Comment + } deriving (Eq, Show) + +instance FromJSON UpdateTripRequest where + parseJSON = withObject "UpdateTripRequest" $ \x -> do + updateTripRequestTripPK <- x .: "tripKey" + -- the following four fields might not be present + updateTripRequestDestination <- x .:? "destination" + updateTripRequestStartDate <- x .:? "startDate" + updateTripRequestEndDate <- x .:? "endDate" + updateTripRequestComment <- x .:? "comment" + pure UpdateTripRequest{..} + +-- | Apply the updates in the UpdateTripRequest to Trip. +updateTrip :: UpdateTripRequest -> Trip -> Trip +updateTrip UpdateTripRequest{..} Trip{..} = Trip + { tripUsername = tripUsername + , tripDestination = M.fromMaybe tripDestination updateTripRequestDestination + , tripStartDate = M.fromMaybe tripStartDate updateTripRequestStartDate + , tripEndDate = M.fromMaybe tripEndDate updateTripRequestEndDate + , tripComment = M.fromMaybe tripComment updateTripRequestComment + } + +data UnfreezeAccountRequest = UnfreezeAccountRequest + { unfreezeAccountRequestUsername :: Username + } deriving (Eq, Show) + +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, Generic) + +instance ToJSON InvitationSecret +instance FromJSON InvitationSecret + +instance ToField InvitationSecret where + toField (InvitationSecret secretUUID) = + secretUUID |> UUID.toText |> SQLText + +instance FromField InvitationSecret where + fromField y = + case fieldData y of + (SQLText x) -> + case UUID.fromText x of + Nothing -> returnError ConversionFailed y ("Could not convert text to UUID: " ++ show x) + Just z -> Ok $ InvitationSecret z + _ -> returnError ConversionFailed y "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{..} diff --git a/users/wpcarro/assessments/tt/src/Utils.hs b/users/wpcarro/assessments/tt/src/Utils.hs new file mode 100644 index 000000000000..48c33af0796d --- /dev/null +++ b/users/wpcarro/assessments/tt/src/Utils.hs @@ -0,0 +1,9 @@ +-------------------------------------------------------------------------------- +module Utils where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +-------------------------------------------------------------------------------- + +-- | Prefer this operator to the ampersand for stylistic reasons. +(|>) :: a -> (a -> b) -> b +(|>) = (&) diff --git a/users/wpcarro/assessments/tt/src/init.sql b/users/wpcarro/assessments/tt/src/init.sql new file mode 100644 index 000000000000..b42753ae5d01 --- /dev/null +++ b/users/wpcarro/assessments/tt/src/init.sql @@ -0,0 +1,67 @@ +-- Run `.read init.sql` from within a SQLite3 REPL to initialize the tables we +-- need for this application. This will erase all current entries, so use with +-- caution. +-- Make sure to set `PRAGMA foreign_keys = on;` when transacting with the +-- database. + +BEGIN TRANSACTION; + +DROP TABLE IF EXISTS Accounts; +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, + password TEXT CHECK(LENGTH(password) > 0) NOT NULL, + email TEXT CHECK(LENGTH(email) > 0) NOT NULL UNIQUE, + role TEXT CHECK(role IN ('user', 'manager', 'admin')) NOT NULL, + profilePicture BLOB, + PRIMARY KEY (username) +); + +CREATE TABLE Trips ( + username TEXT NOT NULL, + destination TEXT CHECK(LENGTH(destination) > 0) NOT NULL, + startDate TEXT CHECK(LENGTH(startDate) == 10) NOT NULL, -- 'YYYY-MM-DD' + endDate TEXT CHECK(LENGTH(endDate) == 10) NOT NULL, -- 'YYYY-MM-DD' + comment TEXT NOT NULL, + PRIMARY KEY (username, destination, startDate), + FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE +); + +CREATE TABLE Sessions ( + uuid TEXT CHECK(LENGTH(uuid) == 36) NOT NULL, + username TEXT NOT NULL UNIQUE, + -- TODO(wpcarro): Add a LENGTH CHECK here + tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS' + PRIMARY KEY (uuid), + FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE +); + +CREATE TABLE LoginAttempts ( + username TEXT NOT NULL UNIQUE, + numAttempts INTEGER NOT NULL, + PRIMARY KEY (username), + FOREIGN KEY (username) REFERENCES Accounts ON DELETE CASCADE +); + +CREATE TABLE PendingAccounts ( + secret TEXT CHECK(LENGTH(secret) == 36) NOT NULL, + username TEXT CHECK(LENGTH(username) > 0) NOT NULL, + password TEXT CHECK(LENGTH(password) > 0) NOT NULL, + role TEXT CHECK(role IN ('user', 'manager', 'admin')) NOT NULL, + email TEXT CHECK(LENGTH(email) > 0) NOT NULL UNIQUE, + 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; |