{-# 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 (..), HasTrait, With, from, pick)
import WebGear.Core.Trait.Auth.Basic (
  BasicAuth' (..),
  BasicAuthError (..),
  Credentials (..),
  Password (..),
  Username (..),
 )
import WebGear.Core.Trait.Auth.Common (
  AuthToken (..),
  AuthorizationHeader,
 )
import WebGear.Server.Handler (ServerHandler)

instance (Monad m) => Get (ServerHandler m) (BasicAuth' Required scheme m e a) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    (HasTrait (AuthorizationHeader scheme) ts) =>
    BasicAuth' Required scheme m e a ->
    ServerHandler m (Request `With` ts) (Either (BasicAuthError e) a)
  getTrait :: forall (ts :: [*]).
HasTrait (AuthorizationHeader scheme) ts =>
BasicAuth' 'Required scheme m e a
-> ServerHandler m (With Request ts) (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)
..} = proc With Request ts
request -> do
    let result :: Maybe (Either Text (AuthToken scheme))
result = forall {k} (t :: k) a. Tagged t a -> a
forall t a. Tagged t a -> a
pick @(AuthorizationHeader scheme) (Tagged
   (AuthorizationHeader scheme)
   (Maybe (Either Text (AuthToken scheme)))
 -> Maybe (Either Text (AuthToken scheme)))
-> Tagged
     (AuthorizationHeader scheme)
     (Maybe (Either Text (AuthToken scheme)))
-> Maybe (Either Text (AuthToken scheme))
forall a b. (a -> b) -> a -> b
$ With Request ts
-> Tagged
     (AuthorizationHeader scheme)
     (Attribute (AuthorizationHeader scheme) Request)
forall a.
With a ts
-> Tagged
     (AuthorizationHeader scheme)
     (Attribute (AuthorizationHeader scheme) a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from With Request ts
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 :: CI ByteString
authToken :: ByteString
authScheme :: forall (scheme :: Symbol). AuthToken scheme -> CI ByteString
authToken :: forall (scheme :: Symbol). AuthToken scheme -> 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 a b. (a -> m b) -> ServerHandler m a b
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 a. a -> m 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 a b c. (a -> b) -> Either a c -> Either b c
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) (BasicAuth' Optional scheme m e a) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    (HasTrait (AuthorizationHeader scheme) ts) =>
    BasicAuth' Optional scheme m e a ->
    ServerHandler m (Request `With` ts) (Either Void (Either (BasicAuthError e) a))
  getTrait :: forall (ts :: [*]).
HasTrait (AuthorizationHeader scheme) 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)
$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)
..} = BasicAuth' 'Required scheme m e a
-> ServerHandler
     m
     (With Request ts)
     (Either
        (Absence (BasicAuth' 'Required scheme m e a) Request)
        (Attribute (BasicAuth' 'Required scheme m e a) Request))
forall (ts :: [*]).
Prerequisite (BasicAuth' 'Required scheme m e a) ts Request =>
BasicAuth' 'Required scheme m e a
-> ServerHandler
     m
     (With Request ts)
     (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, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (Attribute t a))
getTrait (BasicAuth'{Credentials -> m (Either e a)
$sel:toBasicAttribute:BasicAuth' :: Credentials -> m (Either e a)
toBasicAttribute :: Credentials -> m (Either e a)
..} :: BasicAuth' Required scheme m e a) ServerHandler m (With Request ts) (Either (BasicAuthError e) a)
-> ServerHandler
     m
     (Either (BasicAuthError e) a)
     (Either Void (Either (BasicAuthError e) a))
-> ServerHandler
     m (With Request ts) (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 b c. (b -> c) -> ServerHandler m b c
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