{-# 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 :: 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 = 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 (Linked ts Request -> Request
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 :: Header 'Required 'Strict name val
-> ServerHandler
     m
     (Linked ts Request)
     (Either (Either HeaderNotFound HeaderParseError) val)
getTrait Header 'Required 'Strict name val
Header = Proxy name
-> ServerHandler m (Linked ts Request) (Maybe (Either Text val))
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
forall k (t :: k). Proxy t
Proxy @name) ServerHandler m (Linked ts Request) (Maybe (Either Text val))
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either (Either HeaderNotFound HeaderParseError) val)
-> ServerHandler
     m
     (Linked ts Request)
     (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 (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) (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 :: Header 'Optional 'Strict name val
-> ServerHandler
     m (Linked ts Request) (Either HeaderParseError (Maybe val))
getTrait Header 'Optional 'Strict name val
Header = Proxy name
-> ServerHandler m (Linked ts Request) (Maybe (Either Text val))
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
forall k (t :: k). Proxy t
Proxy @name) ServerHandler m (Linked ts Request) (Maybe (Either Text val))
-> ServerHandler
     m (Maybe (Either Text val)) (Either HeaderParseError (Maybe val))
-> ServerHandler
     m (Linked ts Request) (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 (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) (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 :: Header 'Required 'Lenient name val
-> ServerHandler
     m (Linked ts Request) (Either HeaderNotFound (Either Text val))
getTrait Header 'Required 'Lenient name val
Header = Proxy name
-> ServerHandler m (Linked ts Request) (Maybe (Either Text val))
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
forall k (t :: k). Proxy t
Proxy @name) ServerHandler m (Linked ts Request) (Maybe (Either Text val))
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either HeaderNotFound (Either Text val))
-> ServerHandler
     m (Linked ts Request) (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 (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) (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 :: Header 'Optional 'Lenient name val
-> ServerHandler
     m (Linked ts Request) (Either Void (Maybe (Either Text val)))
getTrait Header 'Optional 'Lenient name val
Header = Proxy name
-> ServerHandler m (Linked ts Request) (Maybe (Either Text val))
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
forall k (t :: k). Proxy t
Proxy @name) ServerHandler m (Linked ts Request) (Maybe (Either Text val))
-> ServerHandler
     m (Maybe (Either Text val)) (Either Void (Maybe (Either Text val)))
-> ServerHandler
     m (Linked ts Request) (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 (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, 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 :: 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 = 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
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name
        response :: Response
response@Response{Maybe ByteString
Status
HashMap HeaderName ByteString
responseStatus :: Response -> Status
responseHeaders :: Response -> HashMap HeaderName ByteString
responseBody :: Response -> Maybe ByteString
responseBody :: Maybe ByteString
responseHeaders :: HashMap HeaderName ByteString
responseStatus :: Status
..} = Linked ts Response -> Response
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
l
        response' :: Response
response' = Response
response{responseHeaders :: HashMap HeaderName ByteString
responseHeaders = HeaderName
-> ByteString
-> HashMap HeaderName ByteString
-> HashMap HeaderName ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert HeaderName
headerName (val -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' val
val) HashMap HeaderName ByteString
responseHeaders}
    ServerHandler
  m
  (Linked (Header 'Required 'Strict name val : ts) Response)
  (Linked (Header 'Required 'Strict name val : ts) Response)
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 :: 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 = 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
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name
        response :: Response
response@Response{Maybe ByteString
Status
HashMap HeaderName ByteString
responseBody :: Maybe ByteString
responseHeaders :: HashMap HeaderName ByteString
responseStatus :: Status
responseStatus :: Response -> Status
responseHeaders :: Response -> HashMap HeaderName ByteString
responseBody :: Response -> Maybe ByteString
..} = Linked ts Response -> Response
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
l
        response' :: Response
response' = Response
response{responseHeaders :: HashMap HeaderName ByteString
responseHeaders = (Maybe ByteString -> Maybe ByteString)
-> HeaderName
-> HashMap HeaderName ByteString
-> HashMap HeaderName ByteString
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HM.alter (Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a b. a -> b -> a
const (Maybe ByteString -> Maybe ByteString -> Maybe ByteString)
-> Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ val -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (val -> ByteString) -> Maybe val -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe val
maybeVal) HeaderName
headerName HashMap HeaderName ByteString
responseHeaders}
    ServerHandler
  m
  (Linked (Header 'Optional 'Strict name val : ts) Response)
  (Linked (Header 'Optional 'Strict name val : ts) Response)
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