diff --git a/src/API.hs b/src/API.hs index b46ae5b35..98ffd6094 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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) diff --git a/src/App.hs b/src/App.hs index 1f7754517..203d1d073 100644 --- a/src/App.hs +++ b/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 = diff --git a/src/Types.hs b/src/Types.hs index 3a410dc4b..c2f0ee19b 100644 --- a/src/Types.hs +++ b/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 + ]