{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
--------------------------------------------------------------------------------
module Types where
--------------------------------------------------------------------------------
import Data.Aeson
import Data.Function ((&))
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 Crypto.Random.Types (MonadRandom)
import qualified Crypto.KDF.BCrypt as BC
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as TE
--------------------------------------------------------------------------------
-- 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 ""
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 field =
case fieldData field of
(SQLText x) -> x & TE.encodeUtf8 & HashedPassword & Ok
_ -> returnError ConversionFailed field ""
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
instance ToField Role where
toField RegularUser = SQLText "user"
toField Manager = SQLText "manager"
toField Admin = SQLText "admin"
instance FromField Role where
fromField field =
case fieldData field of
(SQLText "user") -> Ok RegularUser
(SQLText "manager") -> Ok Manager
(SQLText "admin") -> Ok Admin
_ -> returnError ConversionFailed field ""
-- 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
})
= ( accountUsername
, accountPassword
, accountEmail
, accountRole
, accountProfilePicture
)
instance FromRow Account where
fromRow = Account <$> field
<*> field
<*> field
<*> field
<*> field
data Session = Session
{ username :: Username
, role :: 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
-- TODO(wpcarro): Replace this with a different type.
newtype Date = Date Text
deriving (Eq, Show, Generic)
instance ToJSON Date
instance FromJSON Date
instance ToField Date where
toField (Date x) = SQLText x
instance FromField Date where
fromField = forNewtype Date
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
data Trip = Trip
{ tripUsername :: Username
, tripDestination :: Destination
, tripStartDate :: Date
, tripEndDate :: Date
, tripComment :: Comment
} deriving (Eq, Show, Generic)
instance FromRow Trip where
fromRow = Trip <$> field
<*> field
<*> field
<*> field
<*> field
-- | The fields used as the Primary Key for a Trip entry.
data TripPK = TripPK
{ tripPKUsername :: Username
, tripPKDestination :: Destination
, tripPKStartDate :: Date
} deriving (Eq, Show, Generic)
tripPKFields :: TripPK -> (Username, Destination, Date)
tripPKFields (TripPK{ tripPKUsername
, tripPKDestination
, tripPKStartDate
})
= (tripPKUsername, tripPKDestination, tripPKStartDate)
instance FromJSON TripPK where
parseJSON = withObject "TripPK" $ \x -> do
username <- x .: "username"
destination <- x .: "destination"
startDate <- x .: "startDate"
pure TripPK{ tripPKUsername = username
, tripPKDestination = destination
, tripPKStartDate = startDate
}
-- | Return the tuple representation of a Trip record for SQL.
tripFields :: Trip -> (Username, Destination, Date, Date, Comment)
tripFields (Trip{ tripUsername
, tripDestination
, tripStartDate
, tripEndDate
, tripComment
})
= ( 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
username <- x .: "username"
destination <- x .: "destination"
startDate <- x .: "startDate"
endDate <- x .: "endDate"
comment <- x .: "comment"
pure Trip{ tripUsername = username
, tripDestination = destination
, tripStartDate = startDate
, tripEndDate = endDate
, tripComment = comment
}
-- | 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
username <- x.: "username"
password <- x.: "password"
pure AccountCredentials{ accountCredentialsUsername = username
, accountCredentialsPassword = password
}
-- -- | Hash password `x`.
hashPassword :: (MonadRandom m) => ClearTextPassword -> m HashedPassword
hashPassword (ClearTextPassword x) = do
hashed <- BC.hashPassword 12 (x & unpack & B.pack)
pure $ HashedPassword hashed
data CreateAccountRequest = CreateAccountRequest
{ createAccountRequestUsername :: Username
, createAccountRequestPassword :: ClearTextPassword
, createAccountRequestEmail :: Email
, createAccountRequestRole :: Role
} deriving (Eq, Show)
instance FromJSON CreateAccountRequest where
parseJSON = withObject "CreateAccountRequest" $ \x -> do
username <- x .: "username"
password <- x .: "password"
email <- x .: "email"
role <- x .: "role"
pure $ CreateAccountRequest username password email role
createAccountRequestFields :: CreateAccountRequest -> (Username, ClearTextPassword, Email, Role)
createAccountRequestFields request =
( createAccountRequestUsername request
, createAccountRequestPassword request
, createAccountRequestEmail request
, createAccountRequestRole request
)