diff options
author | William Carroll <wpcarro@gmail.com> | 2020-07-30T17·38+0100 |
---|---|---|
committer | William Carroll <wpcarro@gmail.com> | 2020-07-30T17·38+0100 |
commit | dec8890190ff0b86f1a50044814701ef39b808e6 (patch) | |
tree | 3a6c5e821c43e3cbe920abfedcf87134716f7a6c /src/Types.hs | |
parent | 30838b8df7350d9dd37b5873f21247d6bddefc15 (diff) |
Verify users' email addresses when they attempt to sign-up
Lots of changes here: - Add the GET /verify endpoint - Email users a secret using MailGun - Create a PendingAccounts table and record type - Prefer do-notation for FromRow instances (and in general) instead of the <*> or a liftA2 style. Using instances using `<*>` makes the instances depend on the order in which the record's fields were defined. When combined with a "SELECT *", which returns the columns in whichever order the schema defines them (or depending on the DB implementation), produces runtime parse errors at best and silent errors at worst. - Delete bill from accounts.csv to free up the wpcarro@gmail.com when testing the /verify route.
Diffstat (limited to 'src/Types.hs')
-rw-r--r-- | src/Types.hs | 89 |
1 files changed, 67 insertions, 22 deletions
diff --git a/src/Types.hs b/src/Types.hs index 135c50f17f4a..d03aae9c7f38 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} -------------------------------------------------------------------------------- module Types where @@ -24,6 +25,7 @@ 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 -------------------------------------------------------------------------------- @@ -34,16 +36,17 @@ data Config = Config } deriving (Eq, Show) instance FromEnv Config where - fromEnv _ = - Config <$> env "MAILGUN_API_KEY" - <*> env "DB_FILE" + fromEnv _ = do + mailgunAPIKey <- env "MAILGUN_API_KEY" + dbFile <- env "DB_FILE" + pure Config {..} -- TODO(wpcarro): Properly handle NULL for columns like profilePicture. forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b forNewtype wrapper field = case fieldData field of (SQLText x) -> Ok (wrapper x) - _ -> returnError ConversionFailed field "" + x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x) newtype Username = Username Text deriving (Eq, Show, Generic) @@ -67,7 +70,7 @@ instance FromField HashedPassword where fromField field = case fieldData field of (SQLText x) -> x |> TE.encodeUtf8 |> HashedPassword |> Ok - _ -> returnError ConversionFailed field "" + x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x) newtype ClearTextPassword = ClearTextPassword Text deriving (Eq, Show, Generic) @@ -119,7 +122,7 @@ instance FromField Role where (SQLText "user") -> Ok RegularUser (SQLText "manager") -> Ok Manager (SQLText "admin") -> Ok Admin - _ -> returnError ConversionFailed field "" + x -> returnError ConversionFailed field ("We expected user, manager, admin, but we received: " ++ show x) -- TODO(wpcarro): Prefer Data.ByteString instead of Text newtype ProfilePicture = ProfilePicture Text @@ -158,11 +161,13 @@ accountFields (Account { accountUsername ) instance FromRow Account where - fromRow = Account <$> field - <*> field - <*> field - <*> field - <*> field + fromRow = do + accountUsername <- field + accountPassword <- field + accountEmail <- field + accountRole <- field + accountProfilePicture <- field + pure Account{..} data Session = Session { username :: Username @@ -221,11 +226,13 @@ data Trip = Trip } deriving (Eq, Show, Generic) instance FromRow Trip where - fromRow = Trip <$> field - <*> field - <*> field - <*> field - <*> field + 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 @@ -370,9 +377,9 @@ instance FromField SessionUUID where case fieldData field of (SQLText x) -> case UUID.fromText x of - Nothing -> returnError ConversionFailed field "" + Nothing -> returnError ConversionFailed field ("Could not convert to UUID: " ++ show x) Just x -> Ok $ SessionUUID x - _ -> returnError ConversionFailed field "" + _ -> returnError ConversionFailed field "Expected SQLText for SessionUUID, but we received" instance ToField SessionUUID where toField (SessionUUID uuid) = @@ -385,9 +392,11 @@ data StoredSession = StoredSession } deriving (Eq, Show, Generic) instance FromRow StoredSession where - fromRow = StoredSession <$> field - <*> field - <*> field + fromRow = do + storedSessionUUID <- field + storedSessionUsername <- field + storedSessionTsCreated <- field + pure StoredSession {..} data LoginAttempt = LoginAttempt { loginAttemptUsername :: Username @@ -395,7 +404,10 @@ data LoginAttempt = LoginAttempt } deriving (Eq, Show) instance FromRow LoginAttempt where - fromRow = LoginAttempt <$> field <*> field + fromRow = do + loginAttemptUsername <- field + loginAttemptNumAttempts <- field + pure LoginAttempt {..} newtype SessionCookie = SessionCookie Cookies @@ -404,3 +416,36 @@ instance FromHttpApiData SessionCookie where x |> parseCookies |> SessionCookie |> pure parseQueryParam x = x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure + +newtype RegistrationSecret = RegistrationSecret UUID.UUID + deriving (Eq, Show) + +instance FromField RegistrationSecret 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 $ RegistrationSecret x + _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect" + +instance ToField RegistrationSecret where + toField (RegistrationSecret secretUUID) = + secretUUID |> UUID.toText |> SQLText + +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 {..} |