Remodel Account type

Remove unnecessary fields:
- name
- age

Add domain-specific fields:
- username
- password
- email
- role
This commit is contained in:
William Carroll 2020-07-25 18:32:17 +01:00
parent d011616564
commit 722205b081
2 changed files with 22 additions and 11 deletions

View file

@ -32,7 +32,7 @@ server pool =
userAdd :: T.Account -> IO (Maybe T.Session)
userAdd newUser = flip runSqlPersistMPool pool $ do
exists <- selectFirst [T.AccountName ==. (T.accountName newUser)] []
exists <- selectFirst [T.AccountUsername ==. (T.accountUsername newUser)] []
case exists of
Nothing -> do
insert newUser
@ -44,7 +44,7 @@ server pool =
userGet :: Text -> IO (Maybe T.Account)
userGet name = flip runSqlPersistMPool pool $ do
mUser <- selectFirst [T.AccountName ==. name] []
mUser <- selectFirst [T.AccountUsername ==. name] []
pure $ entityVal <$> mUser
app :: ConnectionPool -> Application

View file

@ -7,6 +7,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NamedFieldPuns #-}
--------------------------------------------------------------------------------
module Types where
--------------------------------------------------------------------------------
@ -17,21 +18,31 @@ import Database.Persist.TH
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Account
name Text
age Int
UniqueName name
username Text
password Text
email Text
role Text
UniqueUsername username
UniqueEmail email
deriving Eq Read Show
|]
instance FromJSON Account where
parseJSON = withObject "User" $ \ v ->
Account <$> v .: "name"
<*> v .: "age"
parseJSON = withObject "Account" $ \ v ->
Account <$> v .: "username"
<*> v .: "password"
<*> v .: "email"
<*> v .: "role"
instance ToJSON Account where
toJSON (Account name age) =
object [ "name" .= name
, "age" .= age
toJSON (Account{ accountUsername
, accountPassword
, accountEmail
, accountRole }) =
object [ "username" .= accountUsername
, "password" .= accountPassword
, "email" .= accountEmail
, "role" .= accountRole
]
newtype Username = Username Text