{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module WebGear.Server.Trait.Auth.Basic where
import Control.Arrow (arr, returnA, (>>>))
import Data.Bifunctor (first)
import Data.ByteString.Base64 (decodeLenient)
import Data.ByteString.Char8 (intercalate, split)
import Data.Void (Void)
import WebGear.Core.Handler (arrM)
import WebGear.Core.Modifiers
import WebGear.Core.Request (Request)
import WebGear.Core.Trait (Get (..), With)
import WebGear.Core.Trait.Auth.Basic (
BasicAuth' (..),
BasicAuthError (..),
Credentials (..),
Password (..),
Username (..),
)
import WebGear.Core.Trait.Auth.Common (
AuthToken (..),
AuthorizationHeader,
getAuthorizationHeaderTrait,
)
import WebGear.Server.Handler (ServerHandler)
instance
( Monad m
, Get (ServerHandler m) (AuthorizationHeader scheme) Request
) =>
Get (ServerHandler m) (BasicAuth' Required scheme m e a) Request
where
{-# INLINE getTrait #-}
getTrait ::
BasicAuth' Required scheme m e a ->
ServerHandler m (Request `With` ts) (Either (BasicAuthError e) a)
getTrait :: forall (ts :: [*]).
BasicAuth' 'Required scheme m e a
-> ServerHandler m (With Request ts) (Either (BasicAuthError e) a)
getTrait BasicAuth'{Credentials -> m (Either e a)
$sel:toBasicAttribute:BasicAuth' :: forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
BasicAuth' x scheme m e a -> Credentials -> m (Either e a)
toBasicAttribute :: Credentials -> m (Either e a)
..} = proc With Request ts
request -> do
Maybe (Either Text (AuthToken scheme))
result <- forall (scheme :: Symbol) (h :: * -> * -> *) (ts :: [*]).
Get h (AuthorizationHeader scheme) Request =>
h (With Request ts) (Maybe (Either Text (AuthToken scheme)))
getAuthorizationHeaderTrait @scheme -< With Request ts
request
case Maybe (Either Text (AuthToken scheme))
result of
Maybe (Either Text (AuthToken scheme))
Nothing -> forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a b. a -> Either a b
Left forall e. BasicAuthError e
BasicAuthHeaderMissing
(Just (Left Text
_)) -> forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a b. a -> Either a b
Left forall e. BasicAuthError e
BasicAuthSchemeMismatch
(Just (Right AuthToken scheme
token)) ->
case AuthToken scheme -> Either (BasicAuthError e) Credentials
parseCreds AuthToken scheme
token of
Left BasicAuthError e
e -> forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a b. a -> Either a b
Left BasicAuthError e
e
Right Credentials
c -> ServerHandler m Credentials (Either (BasicAuthError e) a)
validateCreds -< Credentials
c
where
parseCreds :: AuthToken scheme -> Either (BasicAuthError e) Credentials
parseCreds :: AuthToken scheme -> Either (BasicAuthError e) Credentials
parseCreds AuthToken{ByteString
CI ByteString
authScheme :: forall (scheme :: Symbol). AuthToken scheme -> CI ByteString
authToken :: forall (scheme :: Symbol). AuthToken scheme -> ByteString
authToken :: ByteString
authScheme :: CI ByteString
..} =
case Char -> ByteString -> [ByteString]
split Char
':' (ByteString -> ByteString
decodeLenient ByteString
authToken) of
[] -> forall a b. a -> Either a b
Left forall e. BasicAuthError e
BasicAuthCredsBadFormat
ByteString
u : [ByteString]
ps -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Username -> Password -> Credentials
Credentials (ByteString -> Username
Username ByteString
u) (ByteString -> Password
Password forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
intercalate ByteString
":" [ByteString]
ps)
validateCreds :: ServerHandler m Credentials (Either (BasicAuthError e) a)
validateCreds :: ServerHandler m Credentials (Either (BasicAuthError e) a)
validateCreds = forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM forall a b. (a -> b) -> a -> b
$ \Credentials
creds -> do
Either e a
res <- Credentials -> m (Either e a)
toBasicAttribute Credentials
creds
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall e. e -> BasicAuthError e
BasicAuthAttributeError Either e a
res
instance
( Monad m
, Get (ServerHandler m) (AuthorizationHeader scheme) Request
) =>
Get (ServerHandler m) (BasicAuth' Optional scheme m e a) Request
where
{-# INLINE getTrait #-}
getTrait ::
BasicAuth' Optional scheme m e a ->
ServerHandler m (Request `With` ts) (Either Void (Either (BasicAuthError e) a))
getTrait :: forall (ts :: [*]).
BasicAuth' 'Optional scheme m e a
-> ServerHandler
m (With Request ts) (Either Void (Either (BasicAuthError e) a))
getTrait BasicAuth'{Credentials -> m (Either e a)
toBasicAttribute :: Credentials -> m (Either e a)
$sel:toBasicAttribute:BasicAuth' :: forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
BasicAuth' x scheme m e a -> Credentials -> m (Either e a)
..} = forall (h :: * -> * -> *) t a (ts :: [*]).
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (Attribute t a))
getTrait (BasicAuth'{Credentials -> m (Either e a)
toBasicAttribute :: Credentials -> m (Either e a)
$sel:toBasicAttribute:BasicAuth' :: Credentials -> m (Either e a)
..} :: BasicAuth' Required scheme m e a) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. b -> Either a b
Right