diff options
Diffstat (limited to 'users/wpcarro/assessments/tt/src/Types.hs')
| -rw-r--r-- | users/wpcarro/assessments/tt/src/Types.hs | 544 |
1 files changed, 544 insertions, 0 deletions
diff --git a/users/wpcarro/assessments/tt/src/Types.hs b/users/wpcarro/assessments/tt/src/Types.hs new file mode 100644 index 0000000000..6b06a39694 --- /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{..} |