Modify types, create instances

src/API/Users.hs

@@ -4,7 +4,8 @@
 {-# Language NoImplicitPrelude #-}
 {-# Language TypeOperators #-}
 {-# Language DuplicateRecordFields #-}
-module API.Users (API, handler) where
+{-# Language TypeApplications #-}
+module API.Users  where
 
 import Servant
 import ClassyPrelude
@@ -13,18 +14,21 @@ import Data.Aeson
 import Web.FormUrlEncoded
 import Database (runDB)
 import Database.User
+import Database.Schema
+import Control.Lens (view)
+import Data.Generics.Product
 
 data LoginForm = LoginForm { username :: Text
                            , password :: Text }
                deriving (Generic, Show)
 
-data RegisterForm = RegisterForm { username :: Text
-                                 , email :: Text
-                                 , password :: Text
-                                 , passwordAgain :: Text }
+data RegisterForm = RegisterForm { username :: Username
+                                 , email :: Email
+                                 , password :: PlainPassword
+                                 , passwordAgain :: PlainPassword }
                   deriving (Generic, Show)
 
-data LoginStatus = LoginStatus deriving Generic
+data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic
 
 data RegisterStatus = RegisterStatus deriving Generic
 
@@ -42,6 +46,15 @@ instance FromJSON RegisterStatus
 instance FromForm RegisterForm
 instance ToForm RegisterForm
 
+-- generic-lens can convert similar types to this
+data SafeUser = SafeUser { email :: Email
+                         , username :: Username
+                         , role :: Role }
+              deriving (Show, Generic)
+
+instance ToJSON SafeUser where
+instance FromJSON SafeUser where
+
 type API = "login" :> ReqBody '[JSON, FormUrlEncoded] LoginForm :> Post '[JSON] LoginStatus
       :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
 
@@ -49,14 +62,16 @@ handler :: ServerT API AppM
 handler = loginHandler :<|> registerHandler
 
 loginHandler :: LoginForm -> AppM LoginStatus
-loginHandler LoginForm{..} = throwM err403
+loginHandler LoginForm{..} = do
+  user <- fmap (view (super @SafeUser)) <$> runDB (validateUser (Username username) (PlainPassword password))
+  return (LoginStatus user)
 
 registerHandler :: RegisterForm -> AppM RegisterStatus
 registerHandler RegisterForm{..} =
   case () of
        () | password /= passwordAgain -> noMatch
           | otherwise ->
-              either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email (PlainPassword password))
+              either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email password)
   where
     noMatch = throwM err403{errBody = "passwords don't match"}
     alreadyExists = throwM err403{errBody = "User already exists"}