{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}

module Okapi.HTTP.Response.Headers (
    Headers (..),
    ParseError (..),
    parser,
    printer,
    raw,
    field,
    field',
    field_,
    fieldRFC9651,
    fieldBareItem,
    fieldItem,
    fieldList,
    fieldDictionary,
    contentType,
    setCookie,
    MediaType (..),
    ConstF (..),
    GHeaders (..),
    headersCodec,
) where

import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.CaseInsensitive qualified as CI
import Data.Int (Int16, Int32, Int64)
import Data.Kind (Type)
import Data.List (partition)
import Data.Proxy (Proxy (..))
import Data.Text qualified as Text
import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)
import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime, localTimeOfDay, timeZoneOffsetString, zonedTimeToLocalTime, zonedTimeZone)
import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)
import Data.UUID (UUID)
import GHC.Generics (C1, D1, Generic (..), K1 (..), M1 (..), Rec0, S1, Selector (..), (:*:) (..))
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Network.HTTP.Types qualified as HTTP
import Text.Read (readMaybe)
import Web.HttpApiData (parseHeader, toHeader)
import Okapi.Tree (Failure, HasLeaf (..), Info (..), Leaf (..), Parser, Printer, Piece, Context, Tree (..))
import Okapi.Tree qualified as Tree
import Okapi.HTTP.Response.Attributes (Attributes)
import Okapi.HTTP.Response.Attributes qualified as Attributes
import Okapi.HTTP.Response.SetCookies (SetCookie)
import Okapi.HTTP.RFC9651 (RFC9651)
import Okapi.HTTP.RFC9651 qualified as RFC9651
import Okapi.HTTP.RFC9651.BareItem (BareItem)
import Okapi.HTTP.RFC9651.Item (Item, bareItem)
import Okapi.HTTP.RFC9651.List (List)
import Okapi.HTTP.RFC9651.Dictionary (Dictionary)

-- $setup
-- >>> :set -XApplicativeDo
-- >>> import Okapi.Tree (printParse, printStable, int, (=.))
-- >>> :{
-- let twoFields = do
--       a <- fst =. field "x-a" int
--       b <- snd =. field "x-b" int
--       pure (a, b)
-- :}

type Headers :: Type -> Type
data Headers a where
    Raw             :: Headers HTTP.RequestHeaders
    Field           :: HTTP.HeaderName -> Leaf Headers a -> Headers a
    Field'          :: HTTP.HeaderName -> Leaf Headers a -> Headers (Maybe a)
    Field_          :: HTTP.HeaderName -> ByteString -> Headers ()
    FieldRFC9651 :: HTTP.HeaderName -> Tree RFC9651 a a -> Headers a
    SetCookie       :: ByteString -> Leaf SetCookie a -> Tree Attributes p p -> Headers (a, p)

data ParseError = ParseError deriving (ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
/= :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseError -> ShowS
showsPrec :: Int -> ParseError -> ShowS
$cshow :: ParseError -> String
show :: ParseError -> String
$cshowList :: [ParseError] -> ShowS
showList :: [ParseError] -> ShowS
Show)

type instance Context Headers = [HTTP.Header]
type instance Failure Headers = ParseError
type instance Piece Headers = ByteString


parser :: Tree Headers i o -> Parser Headers o
parser :: forall i o. Tree Headers i o -> Parser Headers o
parser = (forall a. Headers a -> Parser Headers a)
-> Tree Headers i o
-> Context Headers
-> (Either (Failure Headers) o, Context Headers)
forall (t :: * -> *) i o.
(forall a. t a -> Parser t a) -> Tree t i o -> Parser t o
Tree.parser Headers a -> Parser Headers a
forall a. Headers a -> Parser Headers a
alg
  where
    alg :: Headers a -> Parser Headers a
    alg :: forall a. Headers a -> Parser Headers a
alg Headers a
Raw Context Headers
hs = (a -> Either ParseError a
forall a b. b -> Either a b
Right a
Context Headers
hs, [])
    alg (Field HeaderName
key Leaf Headers a
vLeaf) Context Headers
hs =
        case (Header -> Bool) -> [Header] -> ([Header], [Header])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(HeaderName
k, ByteString
_) -> HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
key) [Header]
Context Headers
hs of
            ([], [Header]
_)            -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
            ((HeaderName
_, ByteString
v) : [Header]
_, [Header]
rest) -> case Leaf Headers a
vLeaf.decode ByteString
v of
                Left ParseError
_  -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
                Right a
x -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
x, [Header]
Context Headers
rest)
    alg (Field' HeaderName
key Leaf Headers a
vLeaf) Context Headers
hs =
        case (Header -> Bool) -> [Header] -> ([Header], [Header])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(HeaderName
k, ByteString
_) -> HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
key) [Header]
Context Headers
hs of
            ([], [Header]
_)            -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
Maybe a
forall a. Maybe a
Nothing, Context Headers
hs)
            ((HeaderName
_, ByteString
v) : [Header]
_, [Header]
rest) -> case Leaf Headers a
vLeaf.decode ByteString
v of
                Left ParseError
_  -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
Maybe a
forall a. Maybe a
Nothing, [Header]
Context Headers
rest)
                Right a
x -> (a -> Either ParseError a
forall a b. b -> Either a b
Right (a -> Maybe a
forall a. a -> Maybe a
Just a
x), [Header]
Context Headers
rest)
    alg (Field_ HeaderName
k ByteString
v) Context Headers
hs =
        case HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
k [Header]
Context Headers
hs of
            Just ByteString
v' | ByteString
v' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
v -> (a -> Either ParseError a
forall a b. b -> Either a b
Right (), (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
k', ByteString
_) -> HeaderName
k' HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
k) [Header]
Context Headers
hs)
            Maybe ByteString
_                 -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
    alg (FieldRFC9651 HeaderName
name Tree RFC9651 a a
c) Context Headers
hs =
        case (Header -> Bool) -> [Header] -> ([Header], [Header])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(HeaderName
k, ByteString
_) -> HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name) [Header]
Context Headers
hs of
            ([], [Header]
_)            -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
            ((HeaderName
_, ByteString
v) : [Header]
_, [Header]
rest) -> case (Either ParseError a, ByteString) -> Either ParseError a
forall a b. (a, b) -> a
fst (Tree RFC9651 a a -> Parser RFC9651 a
forall i o. Tree RFC9651 i o -> Parser RFC9651 o
RFC9651.parser Tree RFC9651 a a
c ByteString
Context RFC9651
v) of
                Left ParseError
_  -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
                Right a
x -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
x, [Header]
Context Headers
rest)
    alg (SetCookie ByteString
cookieName Leaf SetCookie a
vLeaf Tree Attributes p p
attrsC) Context Headers
hs =
        let tok :: ByteString -> (ByteString, ByteString, ByteString)
tok ByteString
v = let (ByteString
n, ByteString
r1) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
61) ByteString
v
                        (ByteString
val, ByteString
attrs) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
59) (Int -> ByteString -> ByteString
BS.drop Int
1 ByteString
r1)
                    in (ByteString
n, ByteString
val, ByteString
attrs)
            ([Header]
matched, [Header]
rest) = (Header -> Bool) -> [Header] -> ([Header], [Header])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(HeaderName
k, ByteString
v) -> HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"set-cookie" Bool -> Bool -> Bool
&& (\(ByteString
n, ByteString
_, ByteString
_) -> ByteString
n ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
cookieName) (ByteString -> (ByteString, ByteString, ByteString)
tok ByteString
v)) [Header]
Context Headers
hs
        in case [Header]
matched of
            []         -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
            (HeaderName
_, ByteString
v) : [Header]
_ ->
                let (ByteString
_, ByteString
val, ByteString
attrs) = ByteString -> (ByteString, ByteString, ByteString)
tok ByteString
v
                in case Leaf SetCookie a
vLeaf.decode ByteString
val of
                    Left ParseError
_  -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
                    Right a
x -> case (Either ParseError p, ByteString) -> Either ParseError p
forall a b. (a, b) -> a
fst (Tree Attributes p p -> Parser Attributes p
forall i o. Tree Attributes i o -> Parser Attributes o
Attributes.parser Tree Attributes p p
attrsC ByteString
Context Attributes
attrs) of
                        Left ParseError
_  -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Headers
hs)
                        Right p
p -> (a -> Either ParseError a
forall a b. b -> Either a b
Right (a
x, p
p), [Header]
Context Headers
rest)

printer :: Tree Headers i o -> Printer Headers i
printer :: forall i o. Tree Headers i o -> Printer Headers i
printer = (forall a. Headers a -> Printer Headers a)
-> Tree Headers i o -> i -> Context Headers
forall (t :: * -> *) i o.
Monoid (Context t) =>
(forall a. t a -> Printer t a) -> Tree t i o -> Printer t i
Tree.printer Headers a -> Printer Headers a
forall a. Headers a -> Printer Headers a
alg
  where
    alg :: Headers a -> Printer Headers a
    alg :: forall a. Headers a -> Printer Headers a
alg Headers a
Raw                           a
hs       = a
Context Headers
hs
    alg (Field HeaderName
key Leaf Headers a
vLeaf)             a
x        = [(HeaderName
key, Leaf Headers a
vLeaf.encode a
x)]
    alg (Field' HeaderName
_ Leaf Headers a
_)                  a
Maybe a
Nothing  = []
    alg (Field' HeaderName
key Leaf Headers a
vLeaf)            (Just a
x) = [(HeaderName
key, Leaf Headers a
vLeaf.encode a
x)]
    alg (Field_ HeaderName
k ByteString
v)                  ()       = [(HeaderName
k, ByteString
v)]
    alg (FieldRFC9651 HeaderName
name Tree RFC9651 a a
c)         a
a        = [(HeaderName
name, Tree RFC9651 a a -> Printer RFC9651 a
forall i o. Tree RFC9651 i o -> Printer RFC9651 i
RFC9651.printer Tree RFC9651 a a
c a
a)]
    alg (SetCookie ByteString
name Leaf SetCookie a
vLeaf Tree Attributes p p
attrsC) (a
x, p
p)   =
        [(HeaderName
"set-cookie", ByteString
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Leaf SetCookie a
vLeaf.encode a
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Tree Attributes p p -> Printer Attributes p
forall i o. Tree Attributes i o -> Printer Attributes i
Attributes.printer Tree Attributes p p
attrsC p
p)]

data MediaType
    = JSON
    | HTML
    | PlainText
    | FormUrlEncoded
    | OctetStream
    | EventStream
    | Custom ByteString
    deriving (MediaType -> MediaType -> Bool
(MediaType -> MediaType -> Bool)
-> (MediaType -> MediaType -> Bool) -> Eq MediaType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MediaType -> MediaType -> Bool
== :: MediaType -> MediaType -> Bool
$c/= :: MediaType -> MediaType -> Bool
/= :: MediaType -> MediaType -> Bool
Eq, Int -> MediaType -> ShowS
[MediaType] -> ShowS
MediaType -> String
(Int -> MediaType -> ShowS)
-> (MediaType -> String)
-> ([MediaType] -> ShowS)
-> Show MediaType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MediaType -> ShowS
showsPrec :: Int -> MediaType -> ShowS
$cshow :: MediaType -> String
show :: MediaType -> String
$cshowList :: [MediaType] -> ShowS
showList :: [MediaType] -> ShowS
Show)

mediaTypeBytes :: MediaType -> ByteString
mediaTypeBytes :: MediaType -> ByteString
mediaTypeBytes MediaType
JSON           = ByteString
"application/json"
mediaTypeBytes MediaType
HTML           = ByteString
"text/html"
mediaTypeBytes MediaType
PlainText      = ByteString
"text/plain"
mediaTypeBytes MediaType
FormUrlEncoded = ByteString
"application/x-www-form-urlencoded"
mediaTypeBytes MediaType
OctetStream    = ByteString
"application/octet-stream"
mediaTypeBytes MediaType
EventStream    = ByteString
"text/event-stream"
mediaTypeBytes (Custom ByteString
bs)    = ByteString
bs

raw :: Tree Headers HTTP.RequestHeaders HTTP.RequestHeaders
raw :: Tree Headers [Header] [Header]
raw = Headers [Header] -> Tree Headers [Header] [Header]
forall (t :: * -> *) i. t i -> Tree t i i
Node Headers [Header]
Raw

-- | Parse and print a required response header field.
--
-- prop> printParse parser printer (field "x-foo" int) (x :: Int)
-- prop> printStable parser printer (field "x-foo" int) (x :: Int)
field :: HTTP.HeaderName -> Leaf Headers a -> Tree Headers a a
field :: forall a. HeaderName -> Leaf Headers a -> Tree Headers a a
field HeaderName
key Leaf Headers a
vLeaf = Headers a -> Tree Headers a a
forall (t :: * -> *) i. t i -> Tree t i i
Node (HeaderName -> Leaf Headers a -> Headers a
forall a. HeaderName -> Leaf Headers a -> Headers a
Field HeaderName
key Leaf Headers a
vLeaf)

-- | Parse and print an optional response header field.
--
-- prop> printParse parser printer (field' "x-foo" int) (x :: Maybe Int)
field' :: HTTP.HeaderName -> Leaf Headers a -> Tree Headers (Maybe a) (Maybe a)
field' :: forall a.
HeaderName -> Leaf Headers a -> Tree Headers (Maybe a) (Maybe a)
field' HeaderName
key Leaf Headers a
vLeaf = Headers (Maybe a) -> Tree Headers (Maybe a) (Maybe a)
forall (t :: * -> *) i. t i -> Tree t i i
Node (HeaderName -> Leaf Headers a -> Headers (Maybe a)
forall a. HeaderName -> Leaf Headers a -> Headers (Maybe a)
Field' HeaderName
key Leaf Headers a
vLeaf)

field_ :: HTTP.HeaderName -> ByteString -> Tree Headers h h -> Tree Headers h h
field_ :: forall h.
HeaderName -> ByteString -> Tree Headers h h -> Tree Headers h h
field_ HeaderName
k ByteString
v Tree Headers h h
c = Tree Headers h (h -> h) -> Tree Headers h h -> Tree Headers h h
forall (t :: * -> *) i o1 o.
Tree t i (o1 -> o) -> Tree t i o1 -> Tree t i o
Apply ((h -> ()) -> Tree Headers () (h -> h) -> Tree Headers h (h -> h)
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (() -> h -> ()
forall a b. a -> b -> a
const ()) ((() -> h -> h) -> Tree Headers () () -> Tree Headers () (h -> h)
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap ((h -> h) -> () -> h -> h
forall a b. a -> b -> a
const h -> h
forall a. a -> a
id) (Headers () -> Tree Headers () ()
forall (t :: * -> *) i. t i -> Tree t i i
Node (HeaderName -> ByteString -> Headers ()
Field_ HeaderName
k ByteString
v)))) Tree Headers h h
c

fieldRFC9651 :: HTTP.HeaderName -> Tree RFC9651 a a -> Tree Headers a a
fieldRFC9651 :: forall a. HeaderName -> Tree RFC9651 a a -> Tree Headers a a
fieldRFC9651 HeaderName
name Tree RFC9651 a a
c = Headers a -> Tree Headers a a
forall (t :: * -> *) i. t i -> Tree t i i
Node (HeaderName -> Tree RFC9651 a a -> Headers a
forall a. HeaderName -> Tree RFC9651 a a -> Headers a
FieldRFC9651 HeaderName
name Tree RFC9651 a a
c)

fieldBareItem :: HTTP.HeaderName -> Leaf BareItem a -> Tree Headers a a
fieldBareItem :: forall a. HeaderName -> Leaf BareItem a -> Tree Headers a a
fieldBareItem HeaderName
name Leaf BareItem a
i = HeaderName -> Tree RFC9651 a a -> Tree Headers a a
forall a. HeaderName -> Tree RFC9651 a a -> Tree Headers a a
fieldRFC9651 HeaderName
name (Tree Item a a -> Tree RFC9651 a a
forall a. Tree Item a a -> Tree RFC9651 a a
RFC9651.item (Leaf BareItem a -> Tree Item a a
forall a. Leaf BareItem a -> Tree Item a a
bareItem Leaf BareItem a
i))

fieldItem :: HTTP.HeaderName -> Tree Item a a -> Tree Headers a a
fieldItem :: forall a. HeaderName -> Tree Item a a -> Tree Headers a a
fieldItem HeaderName
name Tree Item a a
c = HeaderName -> Tree RFC9651 a a -> Tree Headers a a
forall a. HeaderName -> Tree RFC9651 a a -> Tree Headers a a
fieldRFC9651 HeaderName
name (Tree Item a a -> Tree RFC9651 a a
forall a. Tree Item a a -> Tree RFC9651 a a
RFC9651.item Tree Item a a
c)

fieldList :: HTTP.HeaderName -> Tree List a a -> Tree Headers a a
fieldList :: forall a. HeaderName -> Tree List a a -> Tree Headers a a
fieldList HeaderName
name Tree List a a
c = HeaderName -> Tree RFC9651 a a -> Tree Headers a a
forall a. HeaderName -> Tree RFC9651 a a -> Tree Headers a a
fieldRFC9651 HeaderName
name (Tree List a a -> Tree RFC9651 a a
forall a. Tree List a a -> Tree RFC9651 a a
RFC9651.list Tree List a a
c)

fieldDictionary :: HTTP.HeaderName -> Tree Dictionary a a -> Tree Headers a a
fieldDictionary :: forall a. HeaderName -> Tree Dictionary a a -> Tree Headers a a
fieldDictionary HeaderName
name Tree Dictionary a a
c = HeaderName -> Tree RFC9651 a a -> Tree Headers a a
forall a. HeaderName -> Tree RFC9651 a a -> Tree Headers a a
fieldRFC9651 HeaderName
name (Tree Dictionary a a -> Tree RFC9651 a a
forall a. Tree Dictionary a a -> Tree RFC9651 a a
RFC9651.dictionary Tree Dictionary a a
c)

contentType :: MediaType -> Tree Headers h h -> Tree Headers h h
contentType :: forall h. MediaType -> Tree Headers h h -> Tree Headers h h
contentType MediaType
mt = HeaderName -> ByteString -> Tree Headers h h -> Tree Headers h h
forall h.
HeaderName -> ByteString -> Tree Headers h h -> Tree Headers h h
field_ HeaderName
"content-type" (MediaType -> ByteString
mediaTypeBytes MediaType
mt)

setCookie :: ByteString -> Leaf SetCookie a -> Tree Attributes p p -> Tree Headers (a, p) (a, p)
setCookie :: forall a p.
ByteString
-> Leaf SetCookie a
-> Tree Attributes p p
-> Tree Headers (a, p) (a, p)
setCookie ByteString
name Leaf SetCookie a
vLeaf Tree Attributes p p
attrsC = Headers (a, p) -> Tree Headers (a, p) (a, p)
forall (t :: * -> *) i. t i -> Tree t i i
Node (ByteString
-> Leaf SetCookie a -> Tree Attributes p p -> Headers (a, p)
forall a p.
ByteString
-> Leaf SetCookie a -> Tree Attributes p p -> Headers (a, p)
SetCookie ByteString
name Leaf SetCookie a
vLeaf Tree Attributes p p
attrsC)

instance HasLeaf Headers Int       where leaf :: Leaf Headers Int
leaf = (Piece Headers -> Either (Failure Headers) Int)
-> (Int -> Piece Headers) -> Info -> Leaf Headers Int
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text Int -> Either ParseError Int
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int -> Either ParseError Int)
-> (ByteString -> Either Text Int)
-> ByteString
-> Either ParseError Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Int -> ByteString
Int -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Headers Int16     where leaf :: Leaf Headers Int16
leaf = (Piece Headers -> Either (Failure Headers) Int16)
-> (Int16 -> Piece Headers) -> Info -> Leaf Headers Int16
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Int16 -> Either ParseError Int16
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int16 -> Either ParseError Int16)
-> (ByteString -> Either Text Int16)
-> ByteString
-> Either ParseError Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int16
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Int16 -> ByteString
Int16 -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"integer" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"int32"))
instance HasLeaf Headers Int32     where leaf :: Leaf Headers Int32
leaf = (Piece Headers -> Either (Failure Headers) Int32)
-> (Int32 -> Piece Headers) -> Info -> Leaf Headers Int32
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Int32 -> Either ParseError Int32
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int32 -> Either ParseError Int32)
-> (ByteString -> Either Text Int32)
-> ByteString
-> Either ParseError Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int32
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Int32 -> ByteString
Int32 -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"integer" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"int32"))
instance HasLeaf Headers Int64     where leaf :: Leaf Headers Int64
leaf = (Piece Headers -> Either (Failure Headers) Int64)
-> (Int64 -> Piece Headers) -> Info -> Leaf Headers Int64
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Int64 -> Either ParseError Int64
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Int64 -> Either ParseError Int64)
-> (ByteString -> Either Text Int64)
-> ByteString
-> Either ParseError Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int64
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Int64 -> ByteString
Int64 -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"integer" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"int64"))
instance HasLeaf Headers Integer   where leaf :: Leaf Headers Integer
leaf = (Piece Headers -> Either (Failure Headers) Integer)
-> (Integer -> Piece Headers) -> Info -> Leaf Headers Integer
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Integer -> Either ParseError Integer
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Integer -> Either ParseError Integer)
-> (ByteString -> Either Text Integer)
-> ByteString
-> Either ParseError Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Integer
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Integer -> ByteString
Integer -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Headers Bool      where leaf :: Leaf Headers Bool
leaf = (Piece Headers -> Either (Failure Headers) Bool)
-> (Bool -> Piece Headers) -> Info -> Leaf Headers Bool
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text Bool -> Either ParseError Bool
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Bool -> Either ParseError Bool)
-> (ByteString -> Either Text Bool)
-> ByteString
-> Either ParseError Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Bool
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Bool -> ByteString
Bool -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"boolean" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Headers Float     where leaf :: Leaf Headers Float
leaf = (Piece Headers -> Either (Failure Headers) Float)
-> (Float -> Piece Headers) -> Info -> Leaf Headers Float
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Float -> Either ParseError Float
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Float -> Either ParseError Float)
-> (ByteString -> Either Text Float)
-> ByteString
-> Either ParseError Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Float
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Float -> ByteString
Float -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"number" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"float"))
instance HasLeaf Headers Double    where leaf :: Leaf Headers Double
leaf = (Piece Headers -> Either (Failure Headers) Double)
-> (Double -> Piece Headers) -> Info -> Leaf Headers Double
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text Double -> Either ParseError Double
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Double -> Either ParseError Double)
-> (ByteString -> Either Text Double)
-> ByteString
-> Either ParseError Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Double
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Double -> ByteString
Double -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"number" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"double"))
instance HasLeaf Headers Text.Text where leaf :: Leaf Headers Text
leaf = (Piece Headers -> Either (Failure Headers) Text)
-> (Text -> Piece Headers) -> Info -> Leaf Headers Text
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text Text -> Either ParseError Text
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Text -> Either ParseError Text)
-> (ByteString -> Either Text Text)
-> ByteString
-> Either ParseError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Text
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Text -> ByteString
Text -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"string" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Headers UUID      where leaf :: Leaf Headers UUID
leaf = (Piece Headers -> Either (Failure Headers) UUID)
-> (UUID -> Piece Headers) -> Info -> Leaf Headers UUID
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text UUID -> Either ParseError UUID
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text UUID -> Either ParseError UUID)
-> (ByteString -> Either Text UUID)
-> ByteString
-> Either ParseError UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text UUID
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) UUID -> ByteString
UUID -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"uuid"))
instance HasLeaf Headers Day       where leaf :: Leaf Headers Day
leaf = (Piece Headers -> Either (Failure Headers) Day)
-> (Day -> Piece Headers) -> Info -> Leaf Headers Day
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError) -> Either Text Day -> Either ParseError Day
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text Day -> Either ParseError Day)
-> (ByteString -> Either Text Day)
-> ByteString
-> Either ParseError Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Day
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) Day -> ByteString
Day -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date"))
instance HasLeaf Headers LocalTime where leaf :: Leaf Headers LocalTime
leaf = (Piece Headers -> Either (Failure Headers) LocalTime)
-> (LocalTime -> Piece Headers) -> Info -> Leaf Headers LocalTime
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text LocalTime -> Either ParseError LocalTime
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text LocalTime -> Either ParseError LocalTime)
-> (ByteString -> Either Text LocalTime)
-> ByteString
-> Either ParseError LocalTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text LocalTime
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) LocalTime -> ByteString
LocalTime -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date-time"))
instance HasLeaf Headers UTCTime   where leaf :: Leaf Headers UTCTime
leaf = (Piece Headers -> Either (Failure Headers) UTCTime)
-> (UTCTime -> Piece Headers) -> Info -> Leaf Headers UTCTime
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text UTCTime -> Either ParseError UTCTime
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text UTCTime -> Either ParseError UTCTime)
-> (ByteString -> Either Text UTCTime)
-> ByteString
-> Either ParseError UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text UTCTime
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) UTCTime -> ByteString
UTCTime -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date-time"))
instance HasLeaf Headers TimeOfDay where leaf :: Leaf Headers TimeOfDay
leaf = (Piece Headers -> Either (Failure Headers) TimeOfDay)
-> (TimeOfDay -> Piece Headers) -> Info -> Leaf Headers TimeOfDay
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ((Text -> ParseError)
-> Either Text TimeOfDay -> Either ParseError TimeOfDay
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ParseError -> Text -> ParseError
forall a b. a -> b -> a
const ParseError
ParseError) (Either Text TimeOfDay -> Either ParseError TimeOfDay)
-> (ByteString -> Either Text TimeOfDay)
-> ByteString
-> Either ParseError TimeOfDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text TimeOfDay
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader) TimeOfDay -> ByteString
TimeOfDay -> Piece Headers
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"time"))

instance HasLeaf Headers ByteString where
    leaf :: Leaf Headers ByteString
leaf = (Piece Headers -> Either (Failure Headers) ByteString)
-> (ByteString -> Piece Headers) -> Info -> Leaf Headers ByteString
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ByteString -> Either ParseError ByteString
Piece Headers -> Either (Failure Headers) ByteString
forall a b. b -> Either a b
Right ByteString -> ByteString
ByteString -> Piece Headers
forall a. a -> a
id (Text -> Maybe Text -> Info
Info Text
"string" Maybe Text
forall a. Maybe a
Nothing)

instance HasLeaf Headers DiffTime where
    leaf :: Leaf Headers DiffTime
leaf = (Piece Headers -> Either (Failure Headers) DiffTime)
-> (DiffTime -> Piece Headers) -> Info -> Leaf Headers DiffTime
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ByteString -> Either ParseError DiffTime
Piece Headers -> Either (Failure Headers) DiffTime
forall {b}. Fractional b => ByteString -> Either ParseError b
dec (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (DiffTime -> Text) -> DiffTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (DiffTime -> String) -> DiffTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show (Double -> String) -> (DiffTime -> Double) -> DiffTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac :: DiffTime -> Double)) (Text -> Maybe Text -> Info
Info Text
"number" Maybe Text
forall a. Maybe a
Nothing)
      where
        dec :: ByteString -> Either ParseError b
dec ByteString
bs = case (String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack (ByteString -> Text
decodeUtf8Lenient ByteString
bs)) :: Maybe Double) of
            Just Double
d  -> b -> Either ParseError b
forall a b. b -> Either a b
Right (Double -> b
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d)
            Maybe Double
Nothing -> ParseError -> Either ParseError b
forall a b. a -> Either a b
Left ParseError
ParseError

instance HasLeaf Headers (TimeOfDay, TimeZone) where
    leaf :: Leaf Headers (TimeOfDay, TimeZone)
leaf = (Piece Headers -> Either (Failure Headers) (TimeOfDay, TimeZone))
-> ((TimeOfDay, TimeZone) -> Piece Headers)
-> Info
-> Leaf Headers (TimeOfDay, TimeZone)
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ByteString -> Either ParseError (TimeOfDay, TimeZone)
Piece Headers -> Either (Failure Headers) (TimeOfDay, TimeZone)
dec (TimeOfDay, TimeZone) -> ByteString
(TimeOfDay, TimeZone) -> Piece Headers
forall {t}. FormatTime t => (t, TimeZone) -> ByteString
enc (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"time"))
      where
        enc :: (t, TimeZone) -> ByteString
enc (t
tod, TimeZone
tz) = Text -> ByteString
encodeUtf8 (String -> Text
Text.pack (TimeLocale -> String -> t -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%T" t
tod String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TimeZone -> String
timeZoneOffsetString TimeZone
tz))
        dec :: ByteString -> Either ParseError (TimeOfDay, TimeZone)
dec ByteString
bs = case Bool -> TimeLocale -> String -> String -> Maybe ZonedTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%T%z" (Text -> String
Text.unpack (ByteString -> Text
decodeUtf8Lenient ByteString
bs)) of
            Just ZonedTime
zt -> (TimeOfDay, TimeZone) -> Either ParseError (TimeOfDay, TimeZone)
forall a b. b -> Either a b
Right (LocalTime -> TimeOfDay
localTimeOfDay (ZonedTime -> LocalTime
zonedTimeToLocalTime ZonedTime
zt), ZonedTime -> TimeZone
zonedTimeZone ZonedTime
zt)
            Maybe ZonedTime
Nothing -> ParseError -> Either ParseError (TimeOfDay, TimeZone)
forall a b. a -> Either a b
Left ParseError
ParseError

data ConstF (val :: Symbol) = ConstF deriving (ConstF val -> ConstF val -> Bool
(ConstF val -> ConstF val -> Bool)
-> (ConstF val -> ConstF val -> Bool) -> Eq (ConstF val)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (val :: Symbol). ConstF val -> ConstF val -> Bool
$c== :: forall (val :: Symbol). ConstF val -> ConstF val -> Bool
== :: ConstF val -> ConstF val -> Bool
$c/= :: forall (val :: Symbol). ConstF val -> ConstF val -> Bool
/= :: ConstF val -> ConstF val -> Bool
Eq, Int -> ConstF val -> ShowS
[ConstF val] -> ShowS
ConstF val -> String
(Int -> ConstF val -> ShowS)
-> (ConstF val -> String)
-> ([ConstF val] -> ShowS)
-> Show (ConstF val)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (val :: Symbol). Int -> ConstF val -> ShowS
forall (val :: Symbol). [ConstF val] -> ShowS
forall (val :: Symbol). ConstF val -> String
$cshowsPrec :: forall (val :: Symbol). Int -> ConstF val -> ShowS
showsPrec :: Int -> ConstF val -> ShowS
$cshow :: forall (val :: Symbol). ConstF val -> String
show :: ConstF val -> String
$cshowList :: forall (val :: Symbol). [ConstF val] -> ShowS
showList :: [ConstF val] -> ShowS
Show)

fieldToHeaderName :: String -> HTTP.HeaderName
fieldToHeaderName :: String -> HeaderName
fieldToHeaderName = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName)
-> (String -> ByteString) -> String -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' then Char
'-' else Char
c)

class GHeaders (f :: Type -> Type) where
    gHeadersCodec :: Tree Headers (f ()) (f ())

instance (GHeaders f) => GHeaders (D1 meta f) where
    gHeadersCodec :: Tree Headers (D1 meta f ()) (D1 meta f ())
gHeadersCodec = (f () -> D1 meta f ())
-> Tree Headers (D1 meta f ()) (f ())
-> Tree Headers (D1 meta f ()) (D1 meta f ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap f () -> D1 meta f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Tree Headers (D1 meta f ()) (f ())
 -> Tree Headers (D1 meta f ()) (D1 meta f ()))
-> Tree Headers (D1 meta f ()) (f ())
-> Tree Headers (D1 meta f ()) (D1 meta f ())
forall a b. (a -> b) -> a -> b
$ (D1 meta f () -> f ())
-> Tree Headers (f ()) (f ()) -> Tree Headers (D1 meta f ()) (f ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap D1 meta f () -> f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 Tree Headers (f ()) (f ())
forall (f :: * -> *). GHeaders f => Tree Headers (f ()) (f ())
gHeadersCodec

instance (GHeaders f) => GHeaders (C1 meta f) where
    gHeadersCodec :: Tree Headers (C1 meta f ()) (C1 meta f ())
gHeadersCodec = (f () -> C1 meta f ())
-> Tree Headers (C1 meta f ()) (f ())
-> Tree Headers (C1 meta f ()) (C1 meta f ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap f () -> C1 meta f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Tree Headers (C1 meta f ()) (f ())
 -> Tree Headers (C1 meta f ()) (C1 meta f ()))
-> Tree Headers (C1 meta f ()) (f ())
-> Tree Headers (C1 meta f ()) (C1 meta f ())
forall a b. (a -> b) -> a -> b
$ (C1 meta f () -> f ())
-> Tree Headers (f ()) (f ()) -> Tree Headers (C1 meta f ()) (f ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap C1 meta f () -> f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 Tree Headers (f ()) (f ())
forall (f :: * -> *). GHeaders f => Tree Headers (f ()) (f ())
gHeadersCodec

instance (GHeaders f, GHeaders g) => GHeaders (f :*: g) where
    gHeadersCodec :: Tree Headers ((:*:) f g ()) ((:*:) f g ())
gHeadersCodec =
        Tree Headers ((:*:) f g ()) (g () -> (:*:) f g ())
-> Tree Headers ((:*:) f g ()) (g ())
-> Tree Headers ((:*:) f g ()) ((:*:) f g ())
forall (t :: * -> *) i o1 o.
Tree t i (o1 -> o) -> Tree t i o1 -> Tree t i o
Apply
            ((f () -> g () -> (:*:) f g ())
-> Tree Headers ((:*:) f g ()) (f ())
-> Tree Headers ((:*:) f g ()) (g () -> (:*:) f g ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (\f ()
l g ()
r -> f ()
l f () -> g () -> (:*:) f g ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g ()
r) (((:*:) f g () -> f ())
-> Tree Headers (f ()) (f ()) -> Tree Headers ((:*:) f g ()) (f ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (\(f ()
l :*: g ()
_) -> f ()
l) Tree Headers (f ()) (f ())
forall (f :: * -> *). GHeaders f => Tree Headers (f ()) (f ())
gHeadersCodec))
            (((:*:) f g () -> g ())
-> Tree Headers (g ()) (g ()) -> Tree Headers ((:*:) f g ()) (g ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (\(f ()
_ :*: g ()
r) -> g ()
r) Tree Headers (g ()) (g ())
forall (f :: * -> *). GHeaders f => Tree Headers (f ()) (f ())
gHeadersCodec)

instance (Selector s, HasLeaf Headers a) => GHeaders (S1 s (Rec0 a)) where
    gHeadersCodec :: Tree Headers (S1 s (Rec0 a) ()) (S1 s (Rec0 a) ())
gHeadersCodec =
        let key :: HeaderName
key = String -> HeaderName
fieldToHeaderName (S1 s (Rec0 a) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (S1 s (Rec0 a) ()
forall a. HasCallStack => a
undefined :: S1 s (Rec0 a) ()))
         in (a -> S1 s (Rec0 a) ())
-> Tree Headers (S1 s (Rec0 a) ()) a
-> Tree Headers (S1 s (Rec0 a) ()) (S1 s (Rec0 a) ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (Rec0 a () -> S1 s (Rec0 a) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 a () -> S1 s (Rec0 a) ())
-> (a -> Rec0 a ()) -> a -> S1 s (Rec0 a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rec0 a ()
forall k i c (p :: k). c -> K1 i c p
K1) (Tree Headers (S1 s (Rec0 a) ()) a
 -> Tree Headers (S1 s (Rec0 a) ()) (S1 s (Rec0 a) ()))
-> Tree Headers (S1 s (Rec0 a) ()) a
-> Tree Headers (S1 s (Rec0 a) ()) (S1 s (Rec0 a) ())
forall a b. (a -> b) -> a -> b
$ (S1 s (Rec0 a) () -> a)
-> Tree Headers a a -> Tree Headers (S1 s (Rec0 a) ()) a
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (Rec0 a () -> a
forall k i c (p :: k). K1 i c p -> c
unK1 (Rec0 a () -> a)
-> (S1 s (Rec0 a) () -> Rec0 a ()) -> S1 s (Rec0 a) () -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 s (Rec0 a) () -> Rec0 a ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) (Tree Headers a a -> Tree Headers (S1 s (Rec0 a) ()) a)
-> Tree Headers a a -> Tree Headers (S1 s (Rec0 a) ()) a
forall a b. (a -> b) -> a -> b
$ Headers a -> Tree Headers a a
forall (t :: * -> *) i. t i -> Tree t i i
Node (HeaderName -> Leaf Headers a -> Headers a
forall a. HeaderName -> Leaf Headers a -> Headers a
Field HeaderName
key (forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf @Headers @a))

instance {-# OVERLAPPING #-} (Selector s, HasLeaf Headers a) => GHeaders (S1 s (Rec0 (Maybe a))) where
    gHeadersCodec :: Tree Headers (S1 s (Rec0 (Maybe a)) ()) (S1 s (Rec0 (Maybe a)) ())
gHeadersCodec =
        let key :: HeaderName
key = String -> HeaderName
fieldToHeaderName (S1 s (Rec0 (Maybe a)) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (S1 s (Rec0 (Maybe a)) ()
forall a. HasCallStack => a
undefined :: S1 s (Rec0 (Maybe a)) ()))
         in (Maybe a -> S1 s (Rec0 (Maybe a)) ())
-> Tree Headers (S1 s (Rec0 (Maybe a)) ()) (Maybe a)
-> Tree
     Headers (S1 s (Rec0 (Maybe a)) ()) (S1 s (Rec0 (Maybe a)) ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (Rec0 (Maybe a) () -> S1 s (Rec0 (Maybe a)) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 (Maybe a) () -> S1 s (Rec0 (Maybe a)) ())
-> (Maybe a -> Rec0 (Maybe a) ())
-> Maybe a
-> S1 s (Rec0 (Maybe a)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Rec0 (Maybe a) ()
forall k i c (p :: k). c -> K1 i c p
K1) (Tree Headers (S1 s (Rec0 (Maybe a)) ()) (Maybe a)
 -> Tree
      Headers (S1 s (Rec0 (Maybe a)) ()) (S1 s (Rec0 (Maybe a)) ()))
-> Tree Headers (S1 s (Rec0 (Maybe a)) ()) (Maybe a)
-> Tree
     Headers (S1 s (Rec0 (Maybe a)) ()) (S1 s (Rec0 (Maybe a)) ())
forall a b. (a -> b) -> a -> b
$ (S1 s (Rec0 (Maybe a)) () -> Maybe a)
-> Tree Headers (Maybe a) (Maybe a)
-> Tree Headers (S1 s (Rec0 (Maybe a)) ()) (Maybe a)
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (Rec0 (Maybe a) () -> Maybe a
forall k i c (p :: k). K1 i c p -> c
unK1 (Rec0 (Maybe a) () -> Maybe a)
-> (S1 s (Rec0 (Maybe a)) () -> Rec0 (Maybe a) ())
-> S1 s (Rec0 (Maybe a)) ()
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 s (Rec0 (Maybe a)) () -> Rec0 (Maybe a) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) (Tree Headers (Maybe a) (Maybe a)
 -> Tree Headers (S1 s (Rec0 (Maybe a)) ()) (Maybe a))
-> Tree Headers (Maybe a) (Maybe a)
-> Tree Headers (S1 s (Rec0 (Maybe a)) ()) (Maybe a)
forall a b. (a -> b) -> a -> b
$ Headers (Maybe a) -> Tree Headers (Maybe a) (Maybe a)
forall (t :: * -> *) i. t i -> Tree t i i
Node (HeaderName -> Leaf Headers a -> Headers (Maybe a)
forall a. HeaderName -> Leaf Headers a -> Headers (Maybe a)
Field' HeaderName
key (forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf @Headers @a))

instance {-# OVERLAPPING #-} (Selector s, KnownSymbol val) => GHeaders (S1 s (Rec0 (ConstF val))) where
    gHeadersCodec :: Tree
  Headers (S1 s (Rec0 (ConstF val)) ()) (S1 s (Rec0 (ConstF val)) ())
gHeadersCodec =
        let k :: HeaderName
k = String -> HeaderName
fieldToHeaderName (S1 s (Rec0 (ConstF val)) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (S1 s (Rec0 (ConstF val)) ()
forall a. HasCallStack => a
undefined :: S1 s (Rec0 (ConstF val)) ()))
            v :: ByteString
v = Text -> ByteString
encodeUtf8 (String -> Text
Text.pack (Proxy val -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @val)))
         in (() -> S1 s (Rec0 (ConstF val)) ())
-> Tree Headers (S1 s (Rec0 (ConstF val)) ()) ()
-> Tree
     Headers (S1 s (Rec0 (ConstF val)) ()) (S1 s (Rec0 (ConstF val)) ())
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (\() -> Rec0 (ConstF val) () -> S1 s (Rec0 (ConstF val)) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (ConstF val -> Rec0 (ConstF val) ()
forall k i c (p :: k). c -> K1 i c p
K1 ConstF val
forall (val :: Symbol). ConstF val
ConstF)) (Tree Headers (S1 s (Rec0 (ConstF val)) ()) ()
 -> Tree
      Headers
      (S1 s (Rec0 (ConstF val)) ())
      (S1 s (Rec0 (ConstF val)) ()))
-> Tree Headers (S1 s (Rec0 (ConstF val)) ()) ()
-> Tree
     Headers (S1 s (Rec0 (ConstF val)) ()) (S1 s (Rec0 (ConstF val)) ())
forall a b. (a -> b) -> a -> b
$ (S1 s (Rec0 (ConstF val)) () -> ())
-> Tree Headers () ()
-> Tree Headers (S1 s (Rec0 (ConstF val)) ()) ()
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (() -> S1 s (Rec0 (ConstF val)) () -> ()
forall a b. a -> b -> a
const ()) (Tree Headers () ()
 -> Tree Headers (S1 s (Rec0 (ConstF val)) ()) ())
-> Tree Headers () ()
-> Tree Headers (S1 s (Rec0 (ConstF val)) ()) ()
forall a b. (a -> b) -> a -> b
$ Headers () -> Tree Headers () ()
forall (t :: * -> *) i. t i -> Tree t i i
Node (HeaderName -> ByteString -> Headers ()
Field_ HeaderName
k ByteString
v)

headersCodec :: forall a. (Generic a, GHeaders (Rep a)) => Tree Headers a a
headersCodec :: forall a. (Generic a, GHeaders (Rep a)) => Tree Headers a a
headersCodec = (Rep a () -> a) -> Tree Headers a (Rep a ()) -> Tree Headers a a
forall o1 o (t :: * -> *) i. (o1 -> o) -> Tree t i o1 -> Tree t i o
FMap (forall a x. Generic a => Rep a x -> a
to @a) (Tree Headers a (Rep a ()) -> Tree Headers a a)
-> Tree Headers a (Rep a ()) -> Tree Headers a a
forall a b. (a -> b) -> a -> b
$ (a -> Rep a ())
-> Tree Headers (Rep a ()) (Rep a ()) -> Tree Headers a (Rep a ())
forall i i' (t :: * -> *) o. (i -> i') -> Tree t i' o -> Tree t i o
LMap (forall a x. Generic a => a -> Rep a x
from @a) Tree Headers (Rep a ()) (Rep a ())
forall (f :: * -> *). GHeaders f => Tree Headers (f ()) (f ())
gHeadersCodec

-- $combined
-- >>> parser twoFields [("x-a", "1"), ("x-b", "2"), ("x-c", "3")]
-- (Right (1,2),[("x-c","3")])
--
-- prop> printParse parser printer twoFields (xy :: (Int, Int))
-- prop> printStable parser printer twoFields (xy :: (Int, Int))