59 lines
2.0 KiB
Haskell
59 lines
2.0 KiB
Haskell
{-# Language DataKinds #-}
|
|
{-# Language TypeFamilies #-}
|
|
{-# Language OverloadedStrings #-}
|
|
{-# Language NoImplicitPrelude #-}
|
|
{-# Language TypeOperators #-}
|
|
{-# Language DuplicateRecordFields #-}
|
|
{-# Language TypeApplications #-}
|
|
{-# Language TemplateHaskell #-}
|
|
module Server.Auth
|
|
( SafeUser(..)
|
|
, authCheck
|
|
, AuthResult(..)
|
|
, requireLoggedIn)
|
|
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
|
|
import Servant (err401)
|
|
import Control.Monad.Logger
|
|
|
|
-- 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)
|
|
|
|
requireLoggedIn :: (MonadLogger m, MonadThrow m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
|
|
requireLoggedIn f (Authenticated user) = f user
|
|
requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401
|