60 lines
2.6 KiB
Haskell
60 lines
2.6 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module Servant.Auth.Server.Internal.BasicAuth where
|
|
|
|
#if !MIN_VERSION_servant_server(0,16,0)
|
|
#define ServerError ServantErr
|
|
#endif
|
|
|
|
import qualified Data.ByteString as BS
|
|
import Servant (BasicAuthData (..),
|
|
ServerError (..), err401)
|
|
import Servant.Server.Internal.BasicAuth (decodeBAHdr,
|
|
mkBAChallengerHdr)
|
|
|
|
import Servant.Auth.Server.Internal.Types
|
|
|
|
-- | A 'ServerError' that asks the client to authenticate via Basic
|
|
-- Authentication, should be invoked by an application whenever
|
|
-- appropriate. The argument is the realm.
|
|
wwwAuthenticatedErr :: BS.ByteString -> ServerError
|
|
wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] }
|
|
|
|
-- | A type holding the configuration for Basic Authentication.
|
|
-- It is defined as a type family with no arguments, so that
|
|
-- it can be instantiated to whatever type you need to
|
|
-- authenticate your users (use @type instance BasicAuthCfg = ...@).
|
|
--
|
|
-- Note that the instantiation is application-wide,
|
|
-- i.e. there can be only one instance.
|
|
-- As a consequence, it should not be instantiated in a library.
|
|
--
|
|
-- Basic Authentication expects an element of type 'BasicAuthCfg'
|
|
-- to be in the 'Context'; that element is then passed automatically
|
|
-- to the instance of 'FromBasicAuthData' together with the
|
|
-- authentication data obtained from the client.
|
|
--
|
|
-- If you do not need a configuration for Basic Authentication,
|
|
-- you can use just @BasicAuthCfg = ()@, and recall to also
|
|
-- add @()@ to the 'Context'.
|
|
-- A basic but more interesting example is to take as 'BasicAuthCfg'
|
|
-- a list of authorised username/password pairs:
|
|
--
|
|
-- > deriving instance Eq BasicAuthData
|
|
-- > type instance BasicAuthCfg = [BasicAuthData]
|
|
-- > instance FromBasicAuthData User where
|
|
-- > fromBasicAuthData authData authCfg =
|
|
-- > if elem authData authCfg then ...
|
|
type family BasicAuthCfg
|
|
|
|
class FromBasicAuthData a where
|
|
-- | Whether the username exists and the password is correct.
|
|
-- Note that, rather than passing a 'Pass' to the function, we pass a
|
|
-- function that checks an 'EncryptedPass'. This is to make sure you don't
|
|
-- accidentally do something untoward with the password, like store it.
|
|
fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a)
|
|
|
|
basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr
|
|
basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of
|
|
Nothing -> return Indefinite
|
|
Just baData -> fromBasicAuthData baData cfg
|