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 :: 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
|
||||||
|
|
29
src/Types.hs
29
src/Types.hs
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue