{-# LANGUAGE DeriveFunctor #-}
{-# HLINT ignore "Avoid lambda" #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Web.Minion.Response.Header where

import Data.ByteString qualified as Bytes
import Data.CaseInsensitive qualified as CI
import Data.Coerce (coerce)
import Data.Proxy (Proxy (..))
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text.Encode
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types qualified as Http
import Network.Wai qualified as Wai
import Web.HttpApiData (ToHttpApiData (..))
import Web.Minion.Args.Internal
import Web.Minion.Response (CanRespond (..), ToResponse (..))

newtype AddHeader name a = AddHeader a
  deriving ((forall a b. (a -> b) -> AddHeader name a -> AddHeader name b)
-> (forall a b. a -> AddHeader name b -> AddHeader name a)
-> Functor (AddHeader name)
forall k (name :: k) a b. a -> AddHeader name b -> AddHeader name a
forall k (name :: k) a b.
(a -> b) -> AddHeader name a -> AddHeader name b
forall a b. a -> AddHeader name b -> AddHeader name a
forall a b. (a -> b) -> AddHeader name a -> AddHeader name b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (name :: k) a b.
(a -> b) -> AddHeader name a -> AddHeader name b
fmap :: forall a b. (a -> b) -> AddHeader name a -> AddHeader name b
$c<$ :: forall k (name :: k) a b. a -> AddHeader name b -> AddHeader name a
<$ :: forall a b. a -> AddHeader name b -> AddHeader name a
Functor)

newtype RawHeaderValue = RawHeaderValue Bytes.ByteString

instance ToHttpApiData RawHeaderValue where
  {-# INLINE toUrlPiece #-}
  toUrlPiece :: RawHeaderValue -> Text
toUrlPiece = (ByteString -> Text) -> RawHeaderValue -> Text
forall a b. Coercible a b => a -> b
coerce ByteString -> Text
Text.Encode.decodeUtf8
  {-# INLINE toHeader #-}
  toHeader :: RawHeaderValue -> ByteString
toHeader = RawHeaderValue -> ByteString
forall a b. Coercible a b => a -> b
coerce

data AddHeaders hs a = AddHeaders
  { forall (hs :: [*]) a. AddHeaders hs a -> HList hs
headers :: HList hs
  , forall (hs :: [*]) a. AddHeaders hs a -> a
body :: a
  }
  deriving ((forall a b. (a -> b) -> AddHeaders hs a -> AddHeaders hs b)
-> (forall a b. a -> AddHeaders hs b -> AddHeaders hs a)
-> Functor (AddHeaders hs)
forall (hs :: [*]) a b. a -> AddHeaders hs b -> AddHeaders hs a
forall (hs :: [*]) a b.
(a -> b) -> AddHeaders hs a -> AddHeaders hs b
forall a b. a -> AddHeaders hs b -> AddHeaders hs a
forall a b. (a -> b) -> AddHeaders hs a -> AddHeaders hs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (hs :: [*]) a b.
(a -> b) -> AddHeaders hs a -> AddHeaders hs b
fmap :: forall a b. (a -> b) -> AddHeaders hs a -> AddHeaders hs b
$c<$ :: forall (hs :: [*]) a b. a -> AddHeaders hs b -> AddHeaders hs a
<$ :: forall a b. a -> AddHeaders hs b -> AddHeaders hs a
Functor)

instance (CanRespond a) => CanRespond (AddHeaders hs a) where
  {-# INLINE canRespond #-}
  canRespond :: [ByteString] -> Bool
canRespond = forall o. CanRespond o => [ByteString] -> Bool
forall {k} (o :: k). CanRespond o => [ByteString] -> Bool
canRespond @a

instance (ToResponse m a, UnwindHeaders hs, Monad m) => ToResponse m (AddHeaders hs a) where
  {-# INLINE toResponse #-}
  toResponse :: [ByteString] -> AddHeaders hs a -> m Response
toResponse [ByteString]
accept AddHeaders{a
HList hs
$sel:headers:AddHeaders :: forall (hs :: [*]) a. AddHeaders hs a -> HList hs
$sel:body:AddHeaders :: forall (hs :: [*]) a. AddHeaders hs a -> a
headers :: HList hs
body :: a
..} =
    (ResponseHeaders -> ResponseHeaders) -> Response -> Response
Wai.mapResponseHeaders (forall (hs :: [*]). UnwindHeaders hs => HList hs -> ResponseHeaders
unwindHeaders @hs HList hs
headers ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<>) (Response -> Response) -> m Response -> m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString] -> a -> m Response
forall (m :: * -> *) r.
ToResponse m r =>
[ByteString] -> r -> m Response
toResponse [ByteString]
accept a
body

class UnwindHeaders hs where
  unwindHeaders :: HList hs -> [Http.Header]

instance UnwindHeaders '[] where
  {-# INLINE unwindHeaders #-}
  unwindHeaders :: HList '[] -> [Http.Header]
  unwindHeaders :: HList '[] -> ResponseHeaders
unwindHeaders HList '[]
_ = []

instance (UnwindHeaders hs, KnownSymbol name, ToHttpApiData typ) => UnwindHeaders (AddHeader name typ ': hs) where
  {-# INLINE unwindHeaders #-}
  unwindHeaders :: HList (AddHeader name typ : hs) -> ResponseHeaders
unwindHeaders (AddHeader typ
val :# HList ts1
hs) =
    (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.Encode.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name), forall a. ToHttpApiData a => a -> ByteString
toHeader @typ typ
val)
      Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: forall (hs :: [*]). UnwindHeaders hs => HList hs -> ResponseHeaders
unwindHeaders @hs HList hs
HList ts1
hs