-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Traits related to HTTP headers.
module WebGear.Trait.Header
  ( Header
  , HeaderFail (..)
  , HeaderMatch
  , HeaderMismatch (..)
  ) where

import Data.ByteString (ByteString)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.String (fromString)
import Data.Text (Text)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Web.HttpApiData (FromHttpApiData (..))

import WebGear.Trait (CheckResult (..), Trait (..))
import WebGear.Types (Request, requestHeader)


-- | A 'Trait' for capturing a header with name @s@ in a request or
-- response and convert it to some type @t@ via 'FromHttpApiData'.
data Header (s :: Symbol) (t :: Type)

-- | Failure in extracting a header value
data HeaderFail = HeaderNotFound | HeaderParseError Text
  deriving stock (ReadPrec [HeaderFail]
ReadPrec HeaderFail
Int -> ReadS HeaderFail
ReadS [HeaderFail]
(Int -> ReadS HeaderFail)
-> ReadS [HeaderFail]
-> ReadPrec HeaderFail
-> ReadPrec [HeaderFail]
-> Read HeaderFail
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderFail]
$creadListPrec :: ReadPrec [HeaderFail]
readPrec :: ReadPrec HeaderFail
$creadPrec :: ReadPrec HeaderFail
readList :: ReadS [HeaderFail]
$creadList :: ReadS [HeaderFail]
readsPrec :: Int -> ReadS HeaderFail
$creadsPrec :: Int -> ReadS HeaderFail
Read, Int -> HeaderFail -> ShowS
[HeaderFail] -> ShowS
HeaderFail -> String
(Int -> HeaderFail -> ShowS)
-> (HeaderFail -> String)
-> ([HeaderFail] -> ShowS)
-> Show HeaderFail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderFail] -> ShowS
$cshowList :: [HeaderFail] -> ShowS
show :: HeaderFail -> String
$cshow :: HeaderFail -> String
showsPrec :: Int -> HeaderFail -> ShowS
$cshowsPrec :: Int -> HeaderFail -> ShowS
Show, HeaderFail -> HeaderFail -> Bool
(HeaderFail -> HeaderFail -> Bool)
-> (HeaderFail -> HeaderFail -> Bool) -> Eq HeaderFail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderFail -> HeaderFail -> Bool
$c/= :: HeaderFail -> HeaderFail -> Bool
== :: HeaderFail -> HeaderFail -> Bool
$c== :: HeaderFail -> HeaderFail -> Bool
Eq)

instance (KnownSymbol s, FromHttpApiData t, Monad m) => Trait (Header s t) Request m where
  type Val (Header s t) Request = t
  type Fail (Header s t) Request = HeaderFail

  check :: Request -> m (CheckResult (Header s t) Request)
  check :: Request -> m (CheckResult (Header s t) Request)
check r :: Request
r = CheckResult (Header s t) Request
-> m (CheckResult (Header s t) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckResult (Header s t) Request
 -> m (CheckResult (Header s t) Request))
-> CheckResult (Header s t) Request
-> m (CheckResult (Header s t) Request)
forall a b. (a -> b) -> a -> b
$
    let s :: HeaderName
s = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)
    in case ByteString -> Either Text t
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> Either Text t)
-> Maybe ByteString -> Maybe (Either Text t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
s Request
r of
         Nothing        -> Fail (Header s t) Request -> CheckResult (Header s t) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail Fail (Header s t) Request
HeaderFail
HeaderNotFound
         Just (Left e :: Text
e)  -> Fail (Header s t) Request -> CheckResult (Header s t) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail (Fail (Header s t) Request -> CheckResult (Header s t) Request)
-> Fail (Header s t) Request -> CheckResult (Header s t) Request
forall a b. (a -> b) -> a -> b
$ Text -> HeaderFail
HeaderParseError Text
e
         Just (Right x :: t
x) -> Request
-> Val (Header s t) Request -> CheckResult (Header s t) Request
forall k (t :: k) a. a -> Val t a -> CheckResult t a
CheckSuccess Request
r t
Val (Header s t) Request
x

-- | A 'Trait' for ensuring that a header named @s@ has value @t@.
data HeaderMatch (s :: Symbol) (t :: Symbol)

-- | Failure in extracting a header value
data HeaderMismatch = HeaderMismatch
  { HeaderMismatch -> ByteString
expectedHeader :: ByteString
  , HeaderMismatch -> Maybe ByteString
actualHeader   :: Maybe ByteString
  }
  deriving stock (HeaderMismatch -> HeaderMismatch -> Bool
(HeaderMismatch -> HeaderMismatch -> Bool)
-> (HeaderMismatch -> HeaderMismatch -> Bool) -> Eq HeaderMismatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderMismatch -> HeaderMismatch -> Bool
$c/= :: HeaderMismatch -> HeaderMismatch -> Bool
== :: HeaderMismatch -> HeaderMismatch -> Bool
$c== :: HeaderMismatch -> HeaderMismatch -> Bool
Eq, ReadPrec [HeaderMismatch]
ReadPrec HeaderMismatch
Int -> ReadS HeaderMismatch
ReadS [HeaderMismatch]
(Int -> ReadS HeaderMismatch)
-> ReadS [HeaderMismatch]
-> ReadPrec HeaderMismatch
-> ReadPrec [HeaderMismatch]
-> Read HeaderMismatch
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderMismatch]
$creadListPrec :: ReadPrec [HeaderMismatch]
readPrec :: ReadPrec HeaderMismatch
$creadPrec :: ReadPrec HeaderMismatch
readList :: ReadS [HeaderMismatch]
$creadList :: ReadS [HeaderMismatch]
readsPrec :: Int -> ReadS HeaderMismatch
$creadsPrec :: Int -> ReadS HeaderMismatch
Read, Int -> HeaderMismatch -> ShowS
[HeaderMismatch] -> ShowS
HeaderMismatch -> String
(Int -> HeaderMismatch -> ShowS)
-> (HeaderMismatch -> String)
-> ([HeaderMismatch] -> ShowS)
-> Show HeaderMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderMismatch] -> ShowS
$cshowList :: [HeaderMismatch] -> ShowS
show :: HeaderMismatch -> String
$cshow :: HeaderMismatch -> String
showsPrec :: Int -> HeaderMismatch -> ShowS
$cshowsPrec :: Int -> HeaderMismatch -> ShowS
Show)

instance (KnownSymbol s, KnownSymbol t, Monad m) => Trait (HeaderMatch s t) Request m where
  type Val (HeaderMatch s t) Request = ByteString
  type Fail (HeaderMatch s t) Request = HeaderMismatch

  check :: Request -> m (CheckResult (HeaderMatch s t) Request)
  check :: Request -> m (CheckResult (HeaderMatch s t) Request)
check r :: Request
r = CheckResult (HeaderMatch s t) Request
-> m (CheckResult (HeaderMatch s t) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckResult (HeaderMatch s t) Request
 -> m (CheckResult (HeaderMatch s t) Request))
-> CheckResult (HeaderMatch s t) Request
-> m (CheckResult (HeaderMatch s t) Request)
forall a b. (a -> b) -> a -> b
$
    let
      name :: HeaderName
name = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)
      expected :: ByteString
expected = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy t -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy t
forall k (t :: k). Proxy t
Proxy @t)
    in
      case HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
name Request
r of
        Nothing                  -> Fail (HeaderMatch s t) Request
-> CheckResult (HeaderMatch s t) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail HeaderMismatch :: ByteString -> Maybe ByteString -> HeaderMismatch
HeaderMismatch
                                      {expectedHeader :: ByteString
expectedHeader = ByteString
expected, actualHeader :: Maybe ByteString
actualHeader = Maybe ByteString
forall a. Maybe a
Nothing}
        Just hv :: ByteString
hv | ByteString
hv ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expected -> Request
-> Val (HeaderMatch s t) Request
-> CheckResult (HeaderMatch s t) Request
forall k (t :: k) a. a -> Val t a -> CheckResult t a
CheckSuccess Request
r ByteString
Val (HeaderMatch s t) Request
hv
                | Bool
otherwise      -> Fail (HeaderMatch s t) Request
-> CheckResult (HeaderMatch s t) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail HeaderMismatch :: ByteString -> Maybe ByteString -> HeaderMismatch
HeaderMismatch
                                      {expectedHeader :: ByteString
expectedHeader = ByteString
expected, actualHeader :: Maybe ByteString
actualHeader = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
hv}