diff --git a/ebook-manager.cabal b/ebook-manager.cabal index 752f0b9..c29f0f3 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -25,6 +25,7 @@ executable ebook-manager , Database.Schema , Database.User , Server + , Server.Auth , Types -- other-extensions: build-depends: base >=4.10 && <4.11 diff --git a/src/API/Users.hs b/src/API/Users.hs index 80bd06d..db30611 100644 --- a/src/API/Users.hs +++ b/src/API/Users.hs @@ -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 diff --git a/src/Server.hs b/src/Server.hs index b2a2be8..0c230a9 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -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")) diff --git a/src/Server/Auth.hs b/src/Server/Auth.hs new file mode 100644 index 0000000..75c6c68 --- /dev/null +++ b/src/Server/Auth.hs @@ -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)