Authentication

This commit is contained in:
Mats Rauhala 2018-08-04 23:43:26 +03:00
parent 964972858b
commit 4a3e598f8a
6 changed files with 53 additions and 12 deletions

View File

@ -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

View File

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

View File

@ -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

View File

@ -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 ()

View File

@ -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

View File

@ -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