Return a Session

Define the Session type and return it for the POST /user endpoint
This commit is contained in:
William Carroll 2020-07-24 23:35:49 +01:00
parent 1d47e94bbe
commit 718152ec14
3 changed files with 49 additions and 11 deletions

View file

@ -16,7 +16,7 @@ import qualified Types as T
type API = "user" type API = "user"
:> ReqBody '[JSON] T.User :> ReqBody '[JSON] T.User
:> Post '[JSON] (Maybe (Key T.User)) :> Post '[JSON] (Maybe T.Session)
:<|> "user" :<|> "user"
:> Capture "name" Text :> Capture "name" Text
:> Get '[JSON] (Maybe T.User) :> Get '[JSON] (Maybe T.User)

View file

@ -20,7 +20,7 @@ import Network.Wai.Handler.Warp as Warp
import Servant import Servant
import API import API
import Types import qualified Types as T
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
server :: ConnectionPool -> Server API server :: ConnectionPool -> Server API
@ -30,17 +30,22 @@ server pool =
userAddH newUser = liftIO $ userAdd newUser userAddH newUser = liftIO $ userAdd newUser
userGetH name = liftIO $ userGet name userGetH name = liftIO $ userGet name
userAdd :: User -> IO (Maybe (Key User)) userAdd :: T.User -> IO (Maybe T.Session)
userAdd newUser = flip runSqlPersistMPool pool $ do userAdd newUser = flip runSqlPersistMPool pool $ do
exists <- selectFirst [UserName ==. (userName newUser)] [] exists <- selectFirst [T.UserName ==. (T.userName newUser)] []
case exists of case exists of
Nothing -> Just <$> insert newUser Nothing -> do
Just _ -> return Nothing insert newUser
pure $ Just (T.Session { T.username = T.Username "wpcarro"
, T.password = T.Password "testing"
, T.role = T.RegularUser
})
Just _ -> pure Nothing
userGet :: Text -> IO (Maybe User) userGet :: Text -> IO (Maybe T.User)
userGet name = flip runSqlPersistMPool pool $ do userGet name = flip runSqlPersistMPool pool $ do
mUser <- selectFirst [UserName ==. name] [] mUser <- selectFirst [T.UserName ==. name] []
return $ entityVal <$> mUser pure $ entityVal <$> mUser
app :: ConnectionPool -> Application app :: ConnectionPool -> Application
app pool = serve (Proxy @ API) $ server pool app pool = serve (Proxy @ API) $ server pool
@ -50,8 +55,8 @@ mkApp sqliteFile = do
pool <- runStderrLoggingT $ do pool <- runStderrLoggingT $ do
createSqlitePool (cs sqliteFile) 5 createSqlitePool (cs sqliteFile) 5
runSqlPool (runMigration migrateAll) pool runSqlPool (runMigration T.migrateAll) pool
return $ app pool pure $ app pool
run :: FilePath -> IO () run :: FilePath -> IO ()
run sqliteFile = run sqliteFile =

View file

@ -33,3 +33,36 @@ instance ToJSON User where
object [ "name" .= name object [ "name" .= name
, "age" .= age , "age" .= age
] ]
newtype Username = Username Text
deriving (Eq, Show)
instance ToJSON Username where
toJSON (Username x) = toJSON x
newtype Password = Password Text
deriving (Eq, Show)
instance ToJSON Password where
toJSON (Password x) = toJSON x
data Role = RegularUser | Manager | Admin
deriving (Eq, Show)
instance ToJSON Role where
toJSON RegularUser = "user"
toJSON Manager = "manager"
toJSON Admin = "admin"
data Session = Session
{ username :: Username
, password :: Password
, role :: Role
} deriving (Eq, Show)
instance ToJSON Session where
toJSON (Session username password role) =
object [ "username" .= username
, "password" .= password
, "role" .= role
]