Return a Session
Define the Session type and return it for the POST /user endpoint
This commit is contained in:
parent
1d47e94bbe
commit
718152ec14
3 changed files with 49 additions and 11 deletions
|
@ -16,7 +16,7 @@ import qualified Types as T
|
|||
|
||||
type API = "user"
|
||||
:> ReqBody '[JSON] T.User
|
||||
:> Post '[JSON] (Maybe (Key T.User))
|
||||
:> Post '[JSON] (Maybe T.Session)
|
||||
:<|> "user"
|
||||
:> Capture "name" Text
|
||||
:> Get '[JSON] (Maybe T.User)
|
||||
|
|
25
src/App.hs
25
src/App.hs
|
@ -20,7 +20,7 @@ import Network.Wai.Handler.Warp as Warp
|
|||
import Servant
|
||||
|
||||
import API
|
||||
import Types
|
||||
import qualified Types as T
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
server :: ConnectionPool -> Server API
|
||||
|
@ -30,17 +30,22 @@ server pool =
|
|||
userAddH newUser = liftIO $ userAdd newUser
|
||||
userGetH name = liftIO $ userGet name
|
||||
|
||||
userAdd :: User -> IO (Maybe (Key User))
|
||||
userAdd :: T.User -> IO (Maybe T.Session)
|
||||
userAdd newUser = flip runSqlPersistMPool pool $ do
|
||||
exists <- selectFirst [UserName ==. (userName newUser)] []
|
||||
exists <- selectFirst [T.UserName ==. (T.userName newUser)] []
|
||||
case exists of
|
||||
Nothing -> Just <$> insert newUser
|
||||
Just _ -> return Nothing
|
||||
Nothing -> do
|
||||
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
|
||||
mUser <- selectFirst [UserName ==. name] []
|
||||
return $ entityVal <$> mUser
|
||||
mUser <- selectFirst [T.UserName ==. name] []
|
||||
pure $ entityVal <$> mUser
|
||||
|
||||
app :: ConnectionPool -> Application
|
||||
app pool = serve (Proxy @ API) $ server pool
|
||||
|
@ -50,8 +55,8 @@ mkApp sqliteFile = do
|
|||
pool <- runStderrLoggingT $ do
|
||||
createSqlitePool (cs sqliteFile) 5
|
||||
|
||||
runSqlPool (runMigration migrateAll) pool
|
||||
return $ app pool
|
||||
runSqlPool (runMigration T.migrateAll) pool
|
||||
pure $ app pool
|
||||
|
||||
run :: FilePath -> IO ()
|
||||
run sqliteFile =
|
||||
|
|
33
src/Types.hs
33
src/Types.hs
|
@ -33,3 +33,36 @@ instance ToJSON User where
|
|||
object [ "name" .= name
|
||||
, "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
|
||||
]
|
||||
|
|
Loading…
Reference in a new issue