{-# OPTIONS_GHC -Wno-orphans #-}

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

import Control.Arrow (arr, returnA, (>>>))
import Data.ByteString.Conversion (ToByteString, toByteString')
import qualified Data.HashMap.Strict as HM
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)
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 (..), Linked, Set (..), unlink)
import WebGear.Core.Trait.Header (Header (..), HeaderNotFound (..), HeaderParseError (..))
import WebGear.Server.Handler (ServerHandler)

extractRequestHeader ::
  (Monad m, KnownSymbol name, FromHttpApiData val) =>
  Proxy name ->
  ServerHandler m (Linked ts Request) (Maybe (Either Text val))
extractRequestHeader :: forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (Linked ts Request) (Maybe (Either Text val))
extractRequestHeader Proxy name
proxy = proc Linked ts Request
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 (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Request
req)

instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Required Strict name val) Request where
  {-# INLINEABLE getTrait #-}
  getTrait ::
    Header Required Strict name val ->
    ServerHandler m (Linked ts Request) (Either (Either HeaderNotFound HeaderParseError) val)
  getTrait :: forall (ts :: [*]).
Header 'Required 'Strict name val
-> ServerHandler
     m
     (Linked ts Request)
     (Either (Either HeaderNotFound HeaderParseError) val)
getTrait Header 'Required 'Strict name val
Header = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (Linked ts Request) (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) (Header Optional Strict name val) Request where
  {-# INLINEABLE getTrait #-}
  getTrait ::
    Header Optional Strict name val ->
    ServerHandler m (Linked ts Request) (Either HeaderParseError (Maybe val))
  getTrait :: forall (ts :: [*]).
Header 'Optional 'Strict name val
-> ServerHandler
     m (Linked ts Request) (Either HeaderParseError (Maybe val))
getTrait Header 'Optional 'Strict name val
Header = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (Linked ts Request) (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) (Header Required Lenient name val) Request where
  {-# INLINEABLE getTrait #-}
  getTrait ::
    Header Required Lenient name val ->
    ServerHandler m (Linked ts Request) (Either HeaderNotFound (Either Text val))
  getTrait :: forall (ts :: [*]).
Header 'Required 'Lenient name val
-> ServerHandler
     m (Linked ts Request) (Either HeaderNotFound (Either Text val))
getTrait Header 'Required 'Lenient name val
Header = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (Linked ts Request) (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) (Header Optional Lenient name val) Request where
  {-# INLINEABLE getTrait #-}
  getTrait ::
    Header Optional Lenient name val ->
    ServerHandler m (Linked ts Request) (Either Void (Maybe (Either Text val)))
  getTrait :: forall (ts :: [*]).
Header 'Optional 'Lenient name val
-> ServerHandler
     m (Linked ts Request) (Either Void (Maybe (Either Text val)))
getTrait Header 'Optional 'Lenient name val
Header = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (Linked ts Request) (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) (Header Required Strict name val) Response where
  {-# INLINEABLE setTrait #-}
  setTrait ::
    Header Required Strict name val ->
    (Linked ts Response -> Response -> val -> Linked (Header Required Strict name val : ts) Response) ->
    ServerHandler m (Linked ts Response, val) (Linked (Header Required Strict name val : ts) Response)
  setTrait :: forall (ts :: [*]).
Header 'Required 'Strict name val
-> (Linked ts Response
    -> Response
    -> val
    -> Linked (Header 'Required 'Strict name val : ts) Response)
-> ServerHandler
     m
     (Linked ts Response, val)
     (Linked (Header 'Required 'Strict name val : ts) Response)
setTrait Header 'Required 'Strict name val
Header Linked ts Response
-> Response
-> val
-> Linked (Header 'Required 'Strict name val : ts) Response
f = proc (Linked ts Response
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{Maybe ByteString
HashMap HeaderName ByteString
Status
responseStatus :: Response -> Status
responseHeaders :: Response -> HashMap HeaderName ByteString
responseBody :: Response -> Maybe ByteString
responseBody :: Maybe ByteString
responseHeaders :: HashMap HeaderName ByteString
responseStatus :: Status
..} = forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
l
        response' :: Response
response' = Response
response{responseHeaders :: HashMap HeaderName ByteString
responseHeaders = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert HeaderName
headerName (forall a. ToByteString a => a -> ByteString
toByteString' val
val) HashMap HeaderName ByteString
responseHeaders}
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Linked ts Response
-> Response
-> val
-> Linked (Header 'Required 'Strict name val : ts) Response
f Linked ts Response
l Response
response' val
val

instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (Header Optional Strict name val) Response where
  {-# INLINEABLE setTrait #-}
  setTrait ::
    Header Optional Strict name val ->
    (Linked ts Response -> Response -> Maybe val -> Linked (Header Optional Strict name val : ts) Response) ->
    ServerHandler m (Linked ts Response, Maybe val) (Linked (Header Optional Strict name val : ts) Response)
  setTrait :: forall (ts :: [*]).
Header 'Optional 'Strict name val
-> (Linked ts Response
    -> Response
    -> Maybe val
    -> Linked (Header 'Optional 'Strict name val : ts) Response)
-> ServerHandler
     m
     (Linked ts Response, Maybe val)
     (Linked (Header 'Optional 'Strict name val : ts) Response)
setTrait Header 'Optional 'Strict name val
Header Linked ts Response
-> Response
-> Maybe val
-> Linked (Header 'Optional 'Strict name val : ts) Response
f = proc (Linked ts Response
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{Maybe ByteString
HashMap HeaderName ByteString
Status
responseBody :: Maybe ByteString
responseHeaders :: HashMap HeaderName ByteString
responseStatus :: Status
responseStatus :: Response -> Status
responseHeaders :: Response -> HashMap HeaderName ByteString
responseBody :: Response -> Maybe ByteString
..} = forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
l
        response' :: Response
response' = Response
response{responseHeaders :: HashMap HeaderName ByteString
responseHeaders = forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HM.alter (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. ToByteString a => a -> ByteString
toByteString' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe val
maybeVal) HeaderName
headerName HashMap HeaderName ByteString
responseHeaders}
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Linked ts Response
-> Response
-> Maybe val
-> Linked (Header 'Optional 'Strict name val : ts) Response
f Linked ts Response
l Response
response' Maybe val
maybeVal