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

View file

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