{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the 'BasicAuth'' trait.
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 (..), Linked)
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
  {-# INLINEABLE getTrait #-}
  getTrait ::
    BasicAuth' Required scheme m e a ->
    ServerHandler m (Linked ts Request) (Either (BasicAuthError e) a)
  getTrait :: forall (ts :: [*]).
BasicAuth' 'Required scheme m e a
-> ServerHandler
     m (Linked ts Request) (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 Linked ts Request
request -> do
    Maybe (Either Text (AuthToken scheme))
result <- forall (scheme :: Symbol) (h :: * -> * -> *) (ts :: [*]).
Get h (AuthorizationHeader scheme) Request =>
h (Linked ts Request) (Maybe (Either Text (AuthToken scheme)))
getAuthorizationHeaderTrait @scheme -< Linked ts Request
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
  {-# INLINEABLE getTrait #-}
  getTrait ::
    BasicAuth' Optional scheme m e a ->
    ServerHandler m (Linked ts Request) (Either Void (Either (BasicAuthError e) a))
  getTrait :: forall (ts :: [*]).
BasicAuth' 'Optional scheme m e a
-> ServerHandler
     m (Linked ts Request) (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 (Linked ts a) (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