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{..} =

src/Devel/Main.hs

@@ -1,3 +1,6 @@
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language FlexibleContexts #-}
 module Devel.Main where
 
 import Prelude
@@ -55,3 +58,4 @@ modifyStoredIORef store f = withStore store $ \ref -> do
 
 tidStoreNum :: Word32
 tidStoreNum = 1
+

src/Main.hs

@@ -16,6 +16,7 @@ import Control.Lens (view)
 import Data.Generics.Product
 import Data.Pool (createPool)
 import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
+import Servant.Auth.Server (generateKey)
 
 defaultMain :: App -> IO ()
 defaultMain = run 8080 . server
@@ -28,6 +29,7 @@ withApp config f = do
       pgUsername = Just (view (field @"database" . field @"username") config)
       pgPassword = Just (view (field @"database" . field @"password") config)
   database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5
+  jwk <- generateKey
   f App{..}
 
 main :: IO ()

src/Server.hs

@@ -9,21 +9,30 @@
 {-# Language RecordWildCards #-}
 {-# Language DeriveGeneric #-}
 {-# Language FlexibleInstances #-}
+{-# Language TypeApplications #-}
 module Server where
 
 import qualified API as API
+import qualified API.Users as Users
 import Servant
 import Types
 import ClassyPrelude hiding (Handler)
 import Control.Monad.Logger
 import Control.Monad.Except
+import Servant.Auth.Server
+import Control.Lens
+import Data.Generics.Product
 
 type API = API.API :<|> "static" :> Raw
 
 
 server :: App -> Application
-server app = serve api (enter server' API.handler :<|> serveDirectoryFileServer "static")
+server app = serveWithContext api cfg (enter server' API.handler :<|> serveDirectoryFileServer "static")
   where
+    myKey = view (field @"jwk") app
+    jwtCfg = defaultJWTSettings myKey
+    authCfg = Users.authCheck app
+    cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext
     server' :: AppM :~> Servant.Handler
     server' = NT (Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log"))
     api :: Proxy API

src/Types.hs

@@ -2,20 +2,23 @@
 {-# Language DeriveGeneric #-}
 {-# Language TypeSynonymInstances #-}
 {-# Language FlexibleInstances #-}
-module Types where
+module Types
+  ( App(..)
+  , AppM
+  -- Figure out how to re-export instances
+  ) where
 
 import ClassyPrelude
 import Control.Monad.Logger
 import Configuration
 import Data.Pool (Pool)
 import Database.Selda.Backend (SeldaConnection)
-import Crypto.Random.Types (MonadRandom(..))
+import Servant.Auth.Server as SAS ()
+import Crypto.JOSE.JWK (JWK)
 
 data App = App { config :: Config
-               , database :: Pool SeldaConnection }
+               , database :: Pool SeldaConnection
+               , jwk :: JWK }
          deriving (Generic)
 
 type AppM = LoggingT (ReaderT App IO)
-
-instance MonadRandom AppM where
-  getRandomBytes = lift . lift . getRandomBytes