64 lines
2.4 KiB
Haskell
64 lines
2.4 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
module Server.Auth
|
|
( SafeUser(..)
|
|
, authCheck
|
|
, AuthResult(..)
|
|
, requireLoggedIn)
|
|
where
|
|
|
|
import ClassyPrelude
|
|
import Control.Lens (view)
|
|
import Control.Monad.Catch (MonadThrow, throwM)
|
|
import Control.Monad.Logger
|
|
import Data.Aeson
|
|
import Data.Generics.Product
|
|
import Database
|
|
import Database.Schema
|
|
import Database.User
|
|
import Servant (err401)
|
|
import Servant.Auth.Server as SAS
|
|
import qualified Servant.Docs as Docs
|
|
import Types
|
|
|
|
-- 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 Docs.ToSample SafeUser where
|
|
toSamples _ = [("User", SafeUser "user@example.com" "user" UserRole )]
|
|
|
|
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 :: (MonadThrow m, MonadLogger m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
|
|
requireLoggedIn f (Authenticated user) = f user
|
|
requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401
|