diff --git a/src/App.hs b/src/App.hs index 40dc23a30..a13ffa2d3 100644 --- a/src/App.hs +++ b/src/App.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs index 813a4b51c..fc1516e5b 100644 --- a/src/Types.hs +++ b/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