Remodel Account type
Remove unnecessary fields: - name - age Add domain-specific fields: - username - password - email - role
This commit is contained in:
parent
d011616564
commit
722205b081
2 changed files with 22 additions and 11 deletions
|
@ -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
|
||||
|
|
29
src/Types.hs
29
src/Types.hs
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue