{-# 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 :: 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)))
forall (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 -> ServerHandler
  m (Either (BasicAuthError e) a) (Either (BasicAuthError e) a)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< BasicAuthError e -> Either (BasicAuthError e) a
forall a b. a -> Either a b
Left BasicAuthError e
forall e. BasicAuthError e
BasicAuthHeaderMissing
      (Just (Left Text
_)) -> ServerHandler
  m (Either (BasicAuthError e) a) (Either (BasicAuthError e) a)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< BasicAuthError e -> Either (BasicAuthError e) a
forall a b. a -> Either a b
Left BasicAuthError e
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 -> ServerHandler
  m (Either (BasicAuthError e) a) (Either (BasicAuthError e) a)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< BasicAuthError e -> Either (BasicAuthError e) a
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
          [] -> BasicAuthError e -> Either (BasicAuthError e) Credentials
forall a b. a -> Either a b
Left BasicAuthError e
forall e. BasicAuthError e
BasicAuthCredsBadFormat
          ByteString
u : [ByteString]
ps -> Credentials -> Either (BasicAuthError e) Credentials
forall a b. b -> Either a b
Right (Credentials -> Either (BasicAuthError e) Credentials)
-> Credentials -> Either (BasicAuthError e) Credentials
forall a b. (a -> b) -> a -> b
$ Username -> Password -> Credentials
Credentials (ByteString -> Username
Username ByteString
u) (ByteString -> Password
Password (ByteString -> Password) -> ByteString -> 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 = (Credentials -> m (Either (BasicAuthError e) a))
-> ServerHandler m Credentials (Either (BasicAuthError e) a)
forall (h :: * -> * -> *) (m :: * -> *) a b.
Handler h m =>
(a -> m b) -> h a b
arrM ((Credentials -> m (Either (BasicAuthError e) a))
 -> ServerHandler m Credentials (Either (BasicAuthError e) a))
-> (Credentials -> m (Either (BasicAuthError e) a))
-> ServerHandler m Credentials (Either (BasicAuthError e) a)
forall a b. (a -> b) -> a -> b
$ \Credentials
creds -> do
        Either e a
res <- Credentials -> m (Either e a)
toBasicAttribute Credentials
creds
        Either (BasicAuthError e) a -> m (Either (BasicAuthError e) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (BasicAuthError e) a -> m (Either (BasicAuthError e) a))
-> Either (BasicAuthError e) a -> m (Either (BasicAuthError e) a)
forall a b. (a -> b) -> a -> b
$ (e -> BasicAuthError e)
-> Either e a -> Either (BasicAuthError e) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e -> BasicAuthError e
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 :: 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)
..} = BasicAuth' 'Required scheme m e a
-> ServerHandler
     m
     (Linked ts Request)
     (Either
        (Absence (BasicAuth' 'Required scheme m e a) Request)
        (Attribute (BasicAuth' 'Required scheme m e a) Request))
forall (h :: * -> * -> *) t a (ts :: [*]).
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Attribute t a))
getTrait (BasicAuth' :: forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
(Credentials -> m (Either e a)) -> BasicAuth' x scheme m e a
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) ServerHandler m (Linked ts Request) (Either (BasicAuthError e) a)
-> ServerHandler
     m
     (Either (BasicAuthError e) a)
     (Either Void (Either (BasicAuthError e) a))
-> ServerHandler
     m (Linked ts Request) (Either Void (Either (BasicAuthError e) a))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either (BasicAuthError e) a
 -> Either Void (Either (BasicAuthError e) a))
-> ServerHandler
     m
     (Either (BasicAuthError e) a)
     (Either Void (Either (BasicAuthError e) a))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Either (BasicAuthError e) a
-> Either Void (Either (BasicAuthError e) a)
forall a b. b -> Either a b
Right