Authentication

src/API/Users.hs

@@ -17,6 +17,8 @@ import Database.User
 import Database.Schema
 import Control.Lens (view)
 import Data.Generics.Product
+import Servant.Auth as SA
+import Servant.Auth.Server as SAS
 
 data LoginForm = LoginForm { username :: Text
                            , password :: Text }
@@ -47,6 +49,10 @@ instance FromForm RegisterForm
 instance ToForm RegisterForm
 
 -- generic-lens can convert similar types to this
+-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
+-- can open the jwt token and view what's inside, you just can't modify it.
+--
+-- Is it a problem that a human readable username and email are visible?
 data SafeUser = SafeUser { email :: Email
                          , username :: Username
                          , role :: Role }
@@ -54,17 +60,31 @@ data SafeUser = SafeUser { email :: Email
 
 instance ToJSON SafeUser where
 instance FromJSON SafeUser where
+instance ToJWT SafeUser where
+instance FromJWT SafeUser where
 
-type API = "login" :> ReqBody '[JSON, FormUrlEncoded] LoginForm :> Post '[JSON] LoginStatus
+authCheck :: App -> BasicAuthData -> IO (AuthResult SafeUser)
+authCheck app (BasicAuthData username password) = flip runReaderT app $
+  maybe SAS.Indefinite authenticated <$> runDB (validateUser username' password')
+  where
+    username' = Username $ decodeUtf8 username
+    password' = PlainPassword $ decodeUtf8 password
+    authenticated = SAS.Authenticated . view (super @SafeUser)
+
+type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult SafeUser)
+
+instance FromBasicAuthData SafeUser where
+  fromBasicAuthData authData authCheckFunction = authCheckFunction authData
+
+type API = Auth '[SA.BasicAuth] SafeUser :> "login" :> Get '[JSON] LoginStatus
       :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
 
 handler :: ServerT API AppM
 handler = loginHandler :<|> registerHandler
 
-loginHandler :: LoginForm -> AppM LoginStatus
-loginHandler LoginForm{..} = do
-  user <- fmap (view (super @SafeUser)) <$> runDB (validateUser (Username username) (PlainPassword password))
-  return (LoginStatus user)
+loginHandler :: AuthResult SafeUser -> AppM LoginStatus
+loginHandler (Authenticated u) = return (LoginStatus (Just u))
+loginHandler _ = return (LoginStatus Nothing)
 
 registerHandler :: RegisterForm -> AppM RegisterStatus
 registerHandler RegisterForm{..} =