{-# OPTIONS_GHC -Wno-orphans #-}

{- | Server implementation of the `RequestHeader` and `ResponseHeader`
traits.
-}
module WebGear.Server.Trait.Header () where

import Control.Arrow (arr, returnA, (>>>))
import Data.ByteString (ByteString)
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 (..), ToHttpApiData (..))
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 = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy name
proxy
  ServerHandler m (Maybe (Either Text val)) (Maybe (Either Text val))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ByteString -> Either Text val
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> Either Text val)
-> Maybe ByteString -> Maybe (Either Text val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
headerName (With Request ts -> Request
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 = Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
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
forall (t :: Symbol). Proxy t
Proxy @name) ServerHandler m (With Request ts) (Maybe (Either Text val))
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either (Either HeaderNotFound HeaderParseError) val)
-> ServerHandler
     m
     (With Request ts)
     (Either (Either HeaderNotFound HeaderParseError) val)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe (Either Text val)
 -> Either (Either HeaderNotFound HeaderParseError) val)
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either (Either HeaderNotFound HeaderParseError) val)
forall b c. (b -> c) -> ServerHandler m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Maybe (Either Text val)
-> Either (Either HeaderNotFound HeaderParseError) val
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 -> Either HeaderNotFound HeaderParseError
-> Either (Either HeaderNotFound HeaderParseError) b
forall a b. a -> Either a b
Left (Either HeaderNotFound HeaderParseError
 -> Either (Either HeaderNotFound HeaderParseError) b)
-> Either HeaderNotFound HeaderParseError
-> Either (Either HeaderNotFound HeaderParseError) b
forall a b. (a -> b) -> a -> b
$ HeaderNotFound -> Either HeaderNotFound HeaderParseError
forall a b. a -> Either a b
Left HeaderNotFound
HeaderNotFound
        Just (Left Text
e) -> Either HeaderNotFound HeaderParseError
-> Either (Either HeaderNotFound HeaderParseError) b
forall a b. a -> Either a b
Left (Either HeaderNotFound HeaderParseError
 -> Either (Either HeaderNotFound HeaderParseError) b)
-> Either HeaderNotFound HeaderParseError
-> Either (Either HeaderNotFound HeaderParseError) b
forall a b. (a -> b) -> a -> b
$ HeaderParseError -> Either HeaderNotFound HeaderParseError
forall a b. b -> Either a b
Right (HeaderParseError -> Either HeaderNotFound HeaderParseError)
-> HeaderParseError -> Either HeaderNotFound HeaderParseError
forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e
        Just (Right b
x) -> b -> Either (Either HeaderNotFound HeaderParseError) b
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 = Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
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
forall (t :: Symbol). Proxy t
Proxy @name) ServerHandler m (With Request ts) (Maybe (Either Text val))
-> ServerHandler
     m (Maybe (Either Text val)) (Either HeaderParseError (Maybe val))
-> ServerHandler
     m (With Request ts) (Either HeaderParseError (Maybe val))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe (Either Text val) -> Either HeaderParseError (Maybe val))
-> ServerHandler
     m (Maybe (Either Text val)) (Either HeaderParseError (Maybe val))
forall b c. (b -> c) -> ServerHandler m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Maybe (Either Text val) -> Either HeaderParseError (Maybe val)
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 -> Maybe a -> Either HeaderParseError (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
        Just (Left Text
e) -> HeaderParseError -> Either HeaderParseError (Maybe a)
forall a b. a -> Either a b
Left (HeaderParseError -> Either HeaderParseError (Maybe a))
-> HeaderParseError -> Either HeaderParseError (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e
        Just (Right a
x) -> Maybe a -> Either HeaderParseError (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either HeaderParseError (Maybe a))
-> Maybe a -> Either HeaderParseError (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
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 = Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
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
forall (t :: Symbol). Proxy t
Proxy @name) ServerHandler m (With Request ts) (Maybe (Either Text val))
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either HeaderNotFound (Either Text val))
-> ServerHandler
     m (With Request ts) (Either HeaderNotFound (Either Text val))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe (Either Text val)
 -> Either HeaderNotFound (Either Text val))
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either HeaderNotFound (Either Text val))
forall b c. (b -> c) -> ServerHandler m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Maybe (Either Text val) -> Either HeaderNotFound (Either Text val)
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 -> HeaderNotFound -> Either HeaderNotFound (Either a b)
forall a b. a -> Either a b
Left HeaderNotFound
HeaderNotFound
        Just (Left a
e) -> Either a b -> Either HeaderNotFound (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either HeaderNotFound (Either a b))
-> Either a b -> Either HeaderNotFound (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
e
        Just (Right b
x) -> Either a b -> Either HeaderNotFound (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either HeaderNotFound (Either a b))
-> Either a b -> Either HeaderNotFound (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either 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 = Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
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
forall (t :: Symbol). Proxy t
Proxy @name) ServerHandler m (With Request ts) (Maybe (Either Text val))
-> ServerHandler
     m (Maybe (Either Text val)) (Either Void (Maybe (Either Text val)))
-> ServerHandler
     m (With Request ts) (Either Void (Maybe (Either Text val)))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe (Either Text val) -> Either Void (Maybe (Either Text val)))
-> ServerHandler
     m (Maybe (Either Text val)) (Either Void (Maybe (Either Text val)))
forall b c. (b -> c) -> ServerHandler m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Maybe (Either Text val) -> Either Void (Maybe (Either Text val))
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 -> Maybe (Either a b) -> Either a (Maybe (Either a b))
forall a b. b -> Either a b
Right Maybe (Either a b)
forall a. Maybe a
Nothing
        Just (Left a
e) -> Maybe (Either a b) -> Either a (Maybe (Either a b))
forall a b. b -> Either a b
Right (Maybe (Either a b) -> Either a (Maybe (Either a b)))
-> Maybe (Either a b) -> Either a (Maybe (Either a b))
forall a b. (a -> b) -> a -> b
$ Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (Either a b -> Maybe (Either a b))
-> Either a b -> Maybe (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
e
        Just (Right b
x) -> Maybe (Either a b) -> Either a (Maybe (Either a b))
forall a b. b -> Either a b
Right (Maybe (Either a b) -> Either a (Maybe (Either a b)))
-> Maybe (Either a b) -> Either a (Maybe (Either a b))
forall a b. (a -> b) -> a -> b
$ Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (Either a b -> Maybe (Either a b))
-> Either a b -> Maybe (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right b
x

instance (Monad m, KnownSymbol name, ToHttpApiData 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 = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name
        response :: Response
response = With Response ts -> Response
forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' =
          case Response
response of
            Response Status
status ResponseHeaders
hdrs ResponseBody
body -> Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status ((HeaderName
headerName, val -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader val
val) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs) ResponseBody
body
            Response
_ -> Response
response
    ServerHandler
  m
  (With Response (ResponseHeader 'Required name val : ts))
  (With Response (ResponseHeader 'Required name val : ts))
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, ToHttpApiData 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 = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name
        response :: Response
response = With Response ts -> Response
forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' =
          case Response
response of
            Response Status
status ResponseHeaders
hdrs ResponseBody
body -> Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status (HeaderName
-> Maybe ByteString -> ResponseHeaders -> ResponseHeaders
alterHeader HeaderName
headerName (val -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader (val -> ByteString) -> Maybe val -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe val
maybeVal) ResponseHeaders
hdrs) ResponseBody
body
            Response
_ -> Response
response
    ServerHandler
  m
  (With Response (ResponseHeader 'Optional name val : ts))
  (With Response (ResponseHeader 'Optional name val : ts))
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 = (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
n, ByteString
_) -> HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
n) ResponseHeaders
hdrs
alterHeader HeaderName
name (Just ByteString
val) ResponseHeaders
hdrs = (HeaderName
name, ByteString
val) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs