Reformatting

This commit is contained in:
Mats Rauhala 2018-08-04 23:53:40 +03:00
parent e6086ee34f
commit bcc702b95c
4 changed files with 51 additions and 32 deletions

View File

@ -25,6 +25,7 @@ executable ebook-manager
, Database.Schema
, Database.User
, Server
, Server.Auth
, Types
-- other-extensions:
build-depends: base >=4.10 && <4.11

View File

@ -15,10 +15,9 @@ import Web.FormUrlEncoded
import Database (runDB)
import Database.User
import Database.Schema
import Control.Lens (view)
import Data.Generics.Product
import Servant.Auth as SA
import Server.Auth
import Servant.Auth.Server as SAS
import Servant.Auth as SA
data RegisterForm = RegisterForm { username :: Username
@ -41,33 +40,6 @@ instance FromJSON RegisterStatus
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 }
deriving (Show, Generic)
instance ToJSON SafeUser where
instance FromJSON SafeUser where
instance ToJWT SafeUser where
instance FromJWT SafeUser where
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

View File

@ -13,7 +13,7 @@
module Server where
import qualified API as API
import qualified API.Users as Users
import Server.Auth (authCheck)
import Servant
import Types
import ClassyPrelude hiding (Handler)
@ -31,7 +31,7 @@ server app = serveWithContext api cfg (enter server' API.handler :<|> serveDirec
where
myKey = view (field @"jwk") app
jwtCfg = defaultJWTSettings myKey
authCfg = Users.authCheck app
authCfg = authCheck app
cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext
server' :: AppM :~> Servant.Handler
server' = NT (Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log"))

46
src/Server/Auth.hs Normal file
View File

@ -0,0 +1,46 @@
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language OverloadedStrings #-}
{-# Language NoImplicitPrelude #-}
{-# Language TypeOperators #-}
{-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-}
module Server.Auth where
import ClassyPrelude
import Servant.Auth.Server as SAS
import Data.Aeson
import Database.Schema
import Database.User
import Database
import Types
import Control.Lens (view)
import Data.Generics.Product
-- 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 }
deriving (Show, Generic)
instance ToJSON SafeUser where
instance FromJSON SafeUser where
instance ToJWT SafeUser where
instance FromJWT SafeUser where
type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult SafeUser)
instance FromBasicAuthData SafeUser where
fromBasicAuthData authData authCheckFunction = authCheckFunction authData
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)