From 4a3e598f8a49dc975b07ed655bc724c5f45aa66e Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Sat, 4 Aug 2018 23:43:26 +0300 Subject: [PATCH] Authentication --- ebook-manager.cabal | 3 +++ src/API/Users.hs | 30 +++++++++++++++++++++++++----- src/Devel/Main.hs | 4 ++++ src/Main.hs | 2 ++ src/Server.hs | 11 ++++++++++- src/Types.hs | 15 +++++++++------ 6 files changed, 53 insertions(+), 12 deletions(-) diff --git a/ebook-manager.cabal b/ebook-manager.cabal index 4c98c95..752f0b9 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -59,6 +59,9 @@ executable ebook-manager , process , aeson , http-api-data + , servant-auth + , servant-auth-server + , jose hs-source-dirs: src default-extensions: DeriveGeneric , NoImplicitPrelude diff --git a/src/API/Users.hs b/src/API/Users.hs index e6e7a36..ce49770 100644 --- a/src/API/Users.hs +++ b/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{..} = diff --git a/src/Devel/Main.hs b/src/Devel/Main.hs index 84f579e..a8d2893 100644 --- a/src/Devel/Main.hs +++ b/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 + diff --git a/src/Main.hs b/src/Main.hs index 29e4fa7..3032cd1 100644 --- a/src/Main.hs +++ b/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 () diff --git a/src/Server.hs b/src/Server.hs index d824cac..b2a2be8 100644 --- a/src/Server.hs +++ b/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 diff --git a/src/Types.hs b/src/Types.hs index 7b29f6f..0f666c4 100644 --- a/src/Types.hs +++ b/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