{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the `Header` trait.
module WebGear.Server.Trait.Header () where

import Control.Arrow (arr, returnA, (>>>))
import Data.ByteString (ByteString)
import Data.ByteString.Conversion (ToByteString, toByteString')
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.Text (Text)
import Data.Void (Void)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types (HeaderName, ResponseHeaders)
import Web.HttpApiData (FromHttpApiData, parseHeader)
import WebGear.Core.Modifiers
import WebGear.Core.Request (Request, requestHeader)
import WebGear.Core.Response (Response (..))
import WebGear.Core.Trait (Get (..), Set (..), With, unwitness)
import WebGear.Core.Trait.Header (HeaderNotFound (..), HeaderParseError (..), RequestHeader (..), ResponseHeader (..))
import WebGear.Server.Handler (ServerHandler)

extractRequestHeader ::
  (Monad m, KnownSymbol name, FromHttpApiData val) =>
  Proxy name ->
  ServerHandler m (Request `With` ts) (Maybe (Either Text val))
extractRequestHeader :: forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractRequestHeader Proxy name
proxy = proc With Request ts
req -> do
  let HeaderName
headerName :: HeaderName = 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 Proxy name
proxy
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
headerName (forall a (ts :: [*]). With a ts -> a
unwitness With Request ts
req)

instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Required Strict name val) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    RequestHeader Required Strict name val ->
    ServerHandler m (Request `With` ts) (Either (Either HeaderNotFound HeaderParseError) val)
  getTrait :: forall (ts :: [*]).
RequestHeader 'Required 'Strict name val
-> ServerHandler
     m
     (With Request ts)
     (Either (Either HeaderNotFound HeaderParseError) val)
getTrait RequestHeader 'Required 'Strict name val
RequestHeader = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractRequestHeader (forall {k} (t :: k). Proxy t
Proxy @name) 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 {b}.
Maybe (Either Text b)
-> Either (Either HeaderNotFound HeaderParseError) b
f
    where
      f :: Maybe (Either Text b)
-> Either (Either HeaderNotFound HeaderParseError) b
f = \case
        Maybe (Either Text b)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left HeaderNotFound
HeaderNotFound
        Just (Left Text
e) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e
        Just (Right b
x) -> forall a b. b -> Either a b
Right b
x

instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Optional Strict name val) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    RequestHeader Optional Strict name val ->
    ServerHandler m (Request `With` ts) (Either HeaderParseError (Maybe val))
  getTrait :: forall (ts :: [*]).
RequestHeader 'Optional 'Strict name val
-> ServerHandler
     m (With Request ts) (Either HeaderParseError (Maybe val))
getTrait RequestHeader 'Optional 'Strict name val
RequestHeader = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractRequestHeader (forall {k} (t :: k). Proxy t
Proxy @name) 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}.
Maybe (Either Text a) -> Either HeaderParseError (Maybe a)
f
    where
      f :: Maybe (Either Text a) -> Either HeaderParseError (Maybe a)
f = \case
        Maybe (Either Text a)
Nothing -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
        Just (Left Text
e) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e
        Just (Right a
x) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x

instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Required Lenient name val) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    RequestHeader Required Lenient name val ->
    ServerHandler m (Request `With` ts) (Either HeaderNotFound (Either Text val))
  getTrait :: forall (ts :: [*]).
RequestHeader 'Required 'Lenient name val
-> ServerHandler
     m (With Request ts) (Either HeaderNotFound (Either Text val))
getTrait RequestHeader 'Required 'Lenient name val
RequestHeader = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractRequestHeader (forall {k} (t :: k). Proxy t
Proxy @name) 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}.
Maybe (Either a b) -> Either HeaderNotFound (Either a b)
f
    where
      f :: Maybe (Either a b) -> Either HeaderNotFound (Either a b)
f = \case
        Maybe (Either a b)
Nothing -> forall a b. a -> Either a b
Left HeaderNotFound
HeaderNotFound
        Just (Left a
e) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left a
e
        Just (Right b
x) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right b
x

instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (RequestHeader Optional Lenient name val) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    RequestHeader Optional Lenient name val ->
    ServerHandler m (Request `With` ts) (Either Void (Maybe (Either Text val)))
  getTrait :: forall (ts :: [*]).
RequestHeader 'Optional 'Lenient name val
-> ServerHandler
     m (With Request ts) (Either Void (Maybe (Either Text val)))
getTrait RequestHeader 'Optional 'Lenient name val
RequestHeader = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractRequestHeader (forall {k} (t :: k). Proxy t
Proxy @name) 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} {a}.
Maybe (Either a b) -> Either a (Maybe (Either a b))
f
    where
      f :: Maybe (Either a b) -> Either a (Maybe (Either a b))
f = \case
        Maybe (Either a b)
Nothing -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
        Just (Left a
e) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left a
e
        Just (Right b
x) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right b
x

instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (ResponseHeader Required name val) Response where
  {-# INLINE setTrait #-}
  setTrait ::
    ResponseHeader Required name val ->
    (Response `With` ts -> Response -> val -> Response `With` (ResponseHeader Required name val : ts)) ->
    ServerHandler m (Response `With` ts, val) (Response `With` (ResponseHeader Required name val : ts))
  setTrait :: forall (ts :: [*]).
ResponseHeader 'Required name val
-> (With Response ts
    -> Response
    -> val
    -> With Response (ResponseHeader 'Required name val : ts))
-> ServerHandler
     m
     (With Response ts, val)
     (With Response (ResponseHeader 'Required name val : ts))
setTrait ResponseHeader 'Required name val
ResponseHeader With Response ts
-> Response
-> val
-> With Response (ResponseHeader 'Required name val : ts)
f = proc (With Response ts
l, val
val) -> do
    let HeaderName
headerName :: HeaderName = 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 @name
        response :: Response
response@Response{ResponseHeaders
Status
ResponseBody
responseStatus :: Response -> Status
responseHeaders :: Response -> ResponseHeaders
responseBody :: Response -> ResponseBody
responseBody :: ResponseBody
responseHeaders :: ResponseHeaders
responseStatus :: Status
..} = forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' = Response
response{responseHeaders :: ResponseHeaders
responseHeaders = (HeaderName
headerName, forall a. ToByteString a => a -> ByteString
toByteString' val
val) forall a. a -> [a] -> [a]
: ResponseHeaders
responseHeaders}
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< With Response ts
-> Response
-> val
-> With Response (ResponseHeader 'Required name val : ts)
f With Response ts
l Response
response' val
val

instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (ResponseHeader Optional name val) Response where
  {-# INLINE setTrait #-}
  -- If the optional value is 'Nothing', the header is removed from the response
  setTrait ::
    ResponseHeader Optional name val ->
    (Response `With` ts -> Response -> Maybe val -> Response `With` (ResponseHeader Optional name val : ts)) ->
    ServerHandler m (Response `With` ts, Maybe val) (Response `With` (ResponseHeader Optional name val : ts))
  setTrait :: forall (ts :: [*]).
ResponseHeader 'Optional name val
-> (With Response ts
    -> Response
    -> Maybe val
    -> With Response (ResponseHeader 'Optional name val : ts))
-> ServerHandler
     m
     (With Response ts, Maybe val)
     (With Response (ResponseHeader 'Optional name val : ts))
setTrait ResponseHeader 'Optional name val
ResponseHeader With Response ts
-> Response
-> Maybe val
-> With Response (ResponseHeader 'Optional name val : ts)
f = proc (With Response ts
l, Maybe val
maybeVal) -> do
    let HeaderName
headerName :: HeaderName = 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 @name
        response :: Response
response@Response{ResponseHeaders
Status
ResponseBody
responseBody :: ResponseBody
responseHeaders :: ResponseHeaders
responseStatus :: Status
responseStatus :: Response -> Status
responseHeaders :: Response -> ResponseHeaders
responseBody :: Response -> ResponseBody
..} = forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' = Response
response{responseHeaders :: ResponseHeaders
responseHeaders = HeaderName
-> Maybe ByteString -> ResponseHeaders -> ResponseHeaders
alterHeader HeaderName
headerName (forall a. ToByteString a => a -> ByteString
toByteString' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe val
maybeVal) ResponseHeaders
responseHeaders}
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< With Response ts
-> Response
-> Maybe val
-> With Response (ResponseHeader 'Optional name val : ts)
f With Response ts
l Response
response' Maybe val
maybeVal

alterHeader :: HeaderName -> Maybe ByteString -> ResponseHeaders -> ResponseHeaders
alterHeader :: HeaderName
-> Maybe ByteString -> ResponseHeaders -> ResponseHeaders
alterHeader HeaderName
name Maybe ByteString
Nothing ResponseHeaders
hdrs = forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
n, ByteString
_) -> HeaderName
name forall a. Eq a => a -> a -> Bool
/= HeaderName
n) ResponseHeaders
hdrs
alterHeader HeaderName
name (Just ByteString
val) ResponseHeaders
hdrs = (HeaderName
name, ByteString
val) forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs