{- |
 Common types and functions related to authorization.
-}
module WebGear.Core.Trait.Auth.Common (
  AuthorizationHeader,
  getAuthorizationHeaderTrait,
  Realm (..),
  AuthToken (..),
  respondUnauthorized,
) where

import Control.Arrow (returnA)
import Data.ByteString (ByteString, drop)
import Data.ByteString.Char8 (break)
import Data.CaseInsensitive (CI, mk, original)
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Void (absurd)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Web.HttpApiData (FromHttpApiData (..))
import WebGear.Core.Handler (Handler, unwitnessA, (>->))
import WebGear.Core.MIMETypes (PlainText (..))
import WebGear.Core.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (Get (..), Sets, With)
import WebGear.Core.Trait.Body (Body, setBody)
import WebGear.Core.Trait.Header (RequestHeader (..), RequiredResponseHeader, setHeader)
import WebGear.Core.Trait.Status (Status, unauthorized401)
import Prelude hiding (break, drop)

-- | Trait for \"Authorization\" header
type AuthorizationHeader scheme = RequestHeader Optional Lenient "Authorization" (AuthToken scheme)

{- | Extract the \"Authorization\" header from a request by specifying
   an authentication scheme.

  The header is split into the scheme and token parts and returned.
-}
getAuthorizationHeaderTrait ::
  forall scheme h ts.
  (Get h (AuthorizationHeader scheme) Request) =>
  h (Request `With` ts) (Maybe (Either Text (AuthToken scheme)))
getAuthorizationHeaderTrait :: forall (scheme :: Symbol) (h :: * -> * -> *) (ts :: [*]).
Get h (AuthorizationHeader scheme) Request =>
h (With Request ts) (Maybe (Either Text (AuthToken scheme)))
getAuthorizationHeaderTrait = proc With Request ts
request -> do
  Either Void (Maybe (Either Text (AuthToken scheme)))
result <- forall (h :: * -> * -> *) t a (ts :: [*]).
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (Attribute t a))
getTrait (forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
RequestHeader e p name val
RequestHeader :: RequestHeader Optional Lenient "Authorization" (AuthToken scheme)) -< With Request ts
request
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Void -> a
absurd forall a. a -> a
id Either Void (Maybe (Either Text (AuthToken scheme)))
result
{-# INLINE getAuthorizationHeaderTrait #-}

-- | The protection space for authentication
newtype Realm = Realm ByteString
  deriving newtype (Realm -> Realm -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Realm -> Realm -> Bool
$c/= :: Realm -> Realm -> Bool
== :: Realm -> Realm -> Bool
$c== :: Realm -> Realm -> Bool
Eq, Eq Realm
Realm -> Realm -> Bool
Realm -> Realm -> Ordering
Realm -> Realm -> Realm
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Realm -> Realm -> Realm
$cmin :: Realm -> Realm -> Realm
max :: Realm -> Realm -> Realm
$cmax :: Realm -> Realm -> Realm
>= :: Realm -> Realm -> Bool
$c>= :: Realm -> Realm -> Bool
> :: Realm -> Realm -> Bool
$c> :: Realm -> Realm -> Bool
<= :: Realm -> Realm -> Bool
$c<= :: Realm -> Realm -> Bool
< :: Realm -> Realm -> Bool
$c< :: Realm -> Realm -> Bool
compare :: Realm -> Realm -> Ordering
$ccompare :: Realm -> Realm -> Ordering
Ord, Int -> Realm -> ShowS
[Realm] -> ShowS
Realm -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Realm] -> ShowS
$cshowList :: [Realm] -> ShowS
show :: Realm -> String
$cshow :: Realm -> String
showsPrec :: Int -> Realm -> ShowS
$cshowsPrec :: Int -> Realm -> ShowS
Show, ReadPrec [Realm]
ReadPrec Realm
Int -> ReadS Realm
ReadS [Realm]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Realm]
$creadListPrec :: ReadPrec [Realm]
readPrec :: ReadPrec Realm
$creadPrec :: ReadPrec Realm
readList :: ReadS [Realm]
$creadList :: ReadS [Realm]
readsPrec :: Int -> ReadS Realm
$creadsPrec :: Int -> ReadS Realm
Read, String -> Realm
forall a. (String -> a) -> IsString a
fromString :: String -> Realm
$cfromString :: String -> Realm
IsString)

-- | The components of Authorization request header
data AuthToken (scheme :: Symbol) = AuthToken
  { forall (scheme :: Symbol). AuthToken scheme -> CI ByteString
authScheme :: CI ByteString
  -- ^ Authentication scheme
  , forall (scheme :: Symbol). AuthToken scheme -> ByteString
authToken :: ByteString
  -- ^ Authentication token
  }

instance (KnownSymbol scheme) => FromHttpApiData (AuthToken scheme) where
  parseUrlPiece :: Text -> Either Text (AuthToken scheme)
parseUrlPiece = forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

  {-# INLINE parseHeader #-}
  parseHeader :: ByteString -> Either Text (AuthToken scheme)
parseHeader ByteString
hdr =
    case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
hdr of
      (ByteString
scm, ByteString
tok) ->
        let actualScheme :: CI ByteString
actualScheme = forall s. FoldCase s => s -> CI s
mk ByteString
scm
            expectedScheme :: CI ByteString
expectedScheme = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @scheme
         in if CI ByteString
actualScheme forall a. Eq a => a -> a -> Bool
== CI ByteString
expectedScheme
              then forall a b. b -> Either a b
Right (forall (scheme :: Symbol).
CI ByteString -> ByteString -> AuthToken scheme
AuthToken CI ByteString
actualScheme (Int -> ByteString -> ByteString
drop Int
1 ByteString
tok))
              else forall a b. a -> Either a b
Left Text
"scheme mismatch"

{- | Create a \"401 Unauthorized\" response.

 The response will have a plain text body and an appropriate
 \"WWW-Authenticate\" header.
-}
respondUnauthorized ::
  ( Handler h m
  , Sets
      h
      [ Status
      , RequiredResponseHeader "Content-Type" Text
      , RequiredResponseHeader "WWW-Authenticate" Text
      , Body PlainText Text
      ]
      Response
  ) =>
  -- | The authentication scheme
  CI ByteString ->
  -- | The authentication realm
  Realm ->
  h a Response
respondUnauthorized :: forall (h :: * -> * -> *) (m :: * -> *) a.
(Handler h m,
 Sets
   h
   '[Status, RequiredResponseHeader "Content-Type" Text,
     RequiredResponseHeader "WWW-Authenticate" Text,
     Body PlainText Text]
   Response) =>
CI ByteString -> Realm -> h a Response
respondUnauthorized CI ByteString
scheme (Realm ByteString
realm) = proc a
_ -> do
  let headerVal :: Text
headerVal = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
original CI ByteString
scheme forall a. Semigroup a => a -> a -> a
<> ByteString
" realm=\"" forall a. Semigroup a => a -> a -> a
<> ByteString
realm forall a. Semigroup a => a -> a -> a
<> ByteString
"\""
  (forall (h :: * -> * -> *).
Set h Status Response =>
h () (With Response '[Status])
unauthorized401 -< ())
    forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With Response '[Status]
resp -> forall body mt (h :: * -> * -> *) (ts :: [*]).
(Sets
   h
   '[Body mt body, RequiredResponseHeader "Content-Type" Text]
   Response,
 MIMEType mt) =>
mt
-> h (With Response ts, body)
     (With
        Response
        (Body mt body : RequiredResponseHeader "Content-Type" Text : ts))
setBody PlainText
PlainText -< (With Response '[Status]
resp, Text
"Unauthorized" :: Text))
    forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With
  Response
  '[Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
    Status]
resp -> forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
Set h (ResponseHeader 'Required name val) Response =>
h (With Response ts, val)
  (With Response (ResponseHeader 'Required name val : ts))
setHeader @"WWW-Authenticate" -< (With
  Response
  '[Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
    Status]
resp, Text
headerVal))
    forall (h :: * -> * -> *) env stack a b.
Arrow h =>
h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b
>-> (\With
  Response
  '[RequiredResponseHeader "WWW-Authenticate" Text,
    Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
    Status]
resp -> forall (h :: * -> * -> *) (m :: * -> *) (ts :: [*]).
Handler h m =>
h (With Response ts) Response
unwitnessA -< With
  Response
  '[RequiredResponseHeader "WWW-Authenticate" Text,
    Body PlainText Text, RequiredResponseHeader "Content-Type" Text,
    Status]
resp)
{-# INLINE respondUnauthorized #-}