From 718152ec14242a83fa63c5272c7527dbbd928ee2 Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Fri, 24 Jul 2020 23:35:49 +0100
Subject: [PATCH] Return a Session

Define the Session type and return it for the POST /user endpoint
---
 src/API.hs   |  2 +-
 src/App.hs   | 25 +++++++++++++++----------
 src/Types.hs | 33 +++++++++++++++++++++++++++++++++
 3 files changed, 49 insertions(+), 11 deletions(-)

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
+           ]