module Okapi.HTTP.Response.Attributes (
    Attributes,
    parser,
    printer,
    attribute,
    attribute',
    flag,
    flag',
    raw,
    maxAge,
    domain,
    path,
    secure,
    httpOnly,
) where

import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.Char (toLower)
import Data.Kind (Type)
import Data.List (find)
import Okapi.Tree (Failure, HasLeaf (..), Info (..), Leaf (..), Parser, Printer, Piece, Context)
import Okapi.Tree qualified as Tree
import Okapi.Tree (Tree (..))
import Okapi.Tree qualified as Tree
import Web.HttpApiData (parseHeader, toHeader)

type Attributes :: Type -> Type
data Attributes a where
    Attr  :: ByteString -> Leaf Attributes a -> Attributes a
    Attr' :: ByteString -> Leaf Attributes a -> Attributes (Maybe a)
    Flag  :: ByteString -> Attributes ()
    Flag' :: ByteString -> Attributes Bool
    Raw   :: Attributes ByteString

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 Piece Attributes = ByteString
type instance Context Attributes = ByteString
type instance Failure Attributes = ParseError

instance HasLeaf Attributes Int     where leaf :: Leaf Attributes Int
leaf = (Piece Attributes -> Either (Failure Attributes) Int)
-> (Int -> Piece Attributes) -> Info -> Leaf Attributes 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 Attributes
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Attributes Integer where leaf :: Leaf Attributes Integer
leaf = (Piece Attributes -> Either (Failure Attributes) Integer)
-> (Integer -> Piece Attributes) -> Info -> Leaf Attributes 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 Attributes
forall a. ToHttpApiData a => a -> ByteString
toHeader (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)
instance HasLeaf Attributes ByteString where leaf :: Leaf Attributes ByteString
leaf = (Piece Attributes -> Either (Failure Attributes) ByteString)
-> (ByteString -> Piece Attributes)
-> Info
-> Leaf Attributes ByteString
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf ByteString -> Either ParseError ByteString
Piece Attributes -> Either (Failure Attributes) ByteString
forall a b. b -> Either a b
Right ByteString -> ByteString
ByteString -> Piece Attributes
forall a. a -> a
id (Text -> Maybe Text -> Info
Info Text
"string" Maybe Text
forall a. Maybe a
Nothing)

attribute :: ByteString -> Leaf Attributes a -> Tree Attributes a a
attribute :: forall a. ByteString -> Leaf Attributes a -> Tree Attributes a a
attribute ByteString
key Leaf Attributes a
vLeaf = Attributes a -> Tree Attributes a a
forall (t :: * -> *) i. t i -> Tree t i i
Node (ByteString -> Leaf Attributes a -> Attributes a
forall a. ByteString -> Leaf Attributes a -> Attributes a
Attr ByteString
key Leaf Attributes a
vLeaf)

attribute' :: ByteString -> Leaf Attributes a -> Tree Attributes (Maybe a) (Maybe a)
attribute' :: forall a.
ByteString
-> Leaf Attributes a -> Tree Attributes (Maybe a) (Maybe a)
attribute' ByteString
key Leaf Attributes a
vLeaf = Attributes (Maybe a) -> Tree Attributes (Maybe a) (Maybe a)
forall (t :: * -> *) i. t i -> Tree t i i
Node (ByteString -> Leaf Attributes a -> Attributes (Maybe a)
forall a. ByteString -> Leaf Attributes a -> Attributes (Maybe a)
Attr' ByteString
key Leaf Attributes a
vLeaf)

flag :: ByteString -> Tree Attributes () ()
flag :: ByteString -> Tree Attributes () ()
flag = Attributes () -> Tree Attributes () ()
forall (t :: * -> *) i. t i -> Tree t i i
Node (Attributes () -> Tree Attributes () ())
-> (ByteString -> Attributes ())
-> ByteString
-> Tree Attributes () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Attributes ()
Flag

flag' :: ByteString -> Tree Attributes Bool Bool
flag' :: ByteString -> Tree Attributes Bool Bool
flag' = Attributes Bool -> Tree Attributes Bool Bool
forall (t :: * -> *) i. t i -> Tree t i i
Node (Attributes Bool -> Tree Attributes Bool Bool)
-> (ByteString -> Attributes Bool)
-> ByteString
-> Tree Attributes Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Attributes Bool
Flag'

raw :: Tree Attributes ByteString ByteString
raw :: Tree Attributes ByteString ByteString
raw = Attributes ByteString -> Tree Attributes ByteString ByteString
forall (t :: * -> *) i. t i -> Tree t i i
Node Attributes ByteString
Raw

maxAge :: Tree Attributes Int Int
maxAge :: Tree Attributes Int Int
maxAge = ByteString -> Leaf Attributes Int -> Tree Attributes Int Int
forall a. ByteString -> Leaf Attributes a -> Tree Attributes a a
attribute ByteString
"Max-Age" (forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf @Attributes @Int)

domain :: Tree Attributes ByteString ByteString
domain :: Tree Attributes ByteString ByteString
domain = ByteString
-> Leaf Attributes ByteString
-> Tree Attributes ByteString ByteString
forall a. ByteString -> Leaf Attributes a -> Tree Attributes a a
attribute ByteString
"Domain" (forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf @Attributes @ByteString)

path :: Tree Attributes ByteString ByteString
path :: Tree Attributes ByteString ByteString
path = ByteString
-> Leaf Attributes ByteString
-> Tree Attributes ByteString ByteString
forall a. ByteString -> Leaf Attributes a -> Tree Attributes a a
attribute ByteString
"Path" (forall (t :: * -> *) a. HasLeaf t a => Leaf t a
leaf @Attributes @ByteString)

secure :: Tree Attributes () ()
secure :: Tree Attributes () ()
secure = ByteString -> Tree Attributes () ()
flag ByteString
"Secure"

httpOnly :: Tree Attributes () ()
httpOnly :: Tree Attributes () ()
httpOnly = ByteString -> Tree Attributes () ()
flag ByteString
"HttpOnly"

parser :: Tree Attributes i o -> Parser Attributes o
parser :: forall i o. Tree Attributes i o -> Parser Attributes o
parser = (forall a. Attributes a -> Parser Attributes a)
-> Tree Attributes i o
-> Context Attributes
-> (Either (Failure Attributes) o, Context Attributes)
forall (t :: * -> *) i o.
(forall a. t a -> Parser t a) -> Tree t i o -> Parser t o
Tree.parser Attributes a -> Parser Attributes a
forall a. Attributes a -> Parser Attributes a
alg
  where
    alg :: Attributes a -> Parser Attributes a
    alg :: forall a. Attributes a -> Parser Attributes a
alg (Attr ByteString
key Leaf Attributes a
vLeaf) Context Attributes
s = case ByteString -> ByteString -> Maybe (Maybe ByteString)
look ByteString
key ByteString
Context Attributes
s of
        Just (Just ByteString
v) -> case Leaf Attributes a
vLeaf.decode ByteString
v of
            Left ParseError
_  -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Attributes
s)
            Right a
x -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
x, Context Attributes
s)
        Maybe (Maybe ByteString)
_ -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Attributes
s)
    alg (Attr' ByteString
key Leaf Attributes a
vLeaf) Context Attributes
s = case ByteString -> ByteString -> Maybe (Maybe ByteString)
look ByteString
key ByteString
Context Attributes
s of
        Just (Just ByteString
v) -> (a -> Either ParseError a
forall a b. b -> Either a b
Right ((ParseError -> a) -> (a -> a) -> Either ParseError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (a -> ParseError -> a
forall a b. a -> b -> a
const a
Maybe a
forall a. Maybe a
Nothing) a -> a
a -> Maybe a
forall a. a -> Maybe a
Just (Leaf Attributes a
vLeaf.decode ByteString
v)), Context Attributes
s)
        Maybe (Maybe ByteString)
_             -> (a -> Either ParseError a
forall a b. b -> Either a b
Right a
Maybe a
forall a. Maybe a
Nothing, Context Attributes
s)
    alg (Flag ByteString
key) Context Attributes
s = case ByteString -> ByteString -> Maybe (Maybe ByteString)
look ByteString
key ByteString
Context Attributes
s of
        Just Maybe ByteString
_  -> (a -> Either ParseError a
forall a b. b -> Either a b
Right (), Context Attributes
s)
        Maybe (Maybe ByteString)
Nothing -> (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError, Context Attributes
s)
    alg (Flag' ByteString
key) Context Attributes
s = (a -> Either ParseError a
forall a b. b -> Either a b
Right (a -> (Maybe ByteString -> a) -> Maybe (Maybe ByteString) -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
Bool
False (a -> Maybe ByteString -> a
forall a b. a -> b -> a
const a
Bool
True) (ByteString -> ByteString -> Maybe (Maybe ByteString)
look ByteString
key ByteString
Context Attributes
s)), Context Attributes
s)
    alg Attributes a
Raw Context Attributes
s = (a -> Either ParseError a
forall a b. b -> Either a b
Right a
Context Attributes
s, Context Attributes
s)

printer :: Tree Attributes i o -> Printer Attributes i
printer :: forall i o. Tree Attributes i o -> Printer Attributes i
printer = (forall a. Attributes a -> Printer Attributes a)
-> Tree Attributes i o -> i -> Context Attributes
forall (t :: * -> *) i o.
Monoid (Context t) =>
(forall a. t a -> Printer t a) -> Tree t i o -> Printer t i
Tree.printer Attributes a -> Printer Attributes a
forall a. Attributes a -> Printer Attributes a
alg
  where
    alg :: Attributes a -> Printer Attributes a
    alg :: forall a. Attributes a -> Printer Attributes a
alg (Attr ByteString
key Leaf Attributes a
vLeaf)  a
v        = ByteString
"; " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Leaf Attributes a
vLeaf.encode a
v
    alg (Attr' ByteString
key Leaf Attributes a
vLeaf) (Just a
v) = ByteString
"; " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Leaf Attributes a
vLeaf.encode a
v
    alg (Attr' ByteString
_ Leaf Attributes a
_)       a
Maybe a
Nothing  = ByteString
Context Attributes
""
    alg (Flag ByteString
key)        ()       = ByteString
"; " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key
    alg (Flag' ByteString
key)       a
Bool
True     = ByteString
"; " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
key
    alg (Flag' ByteString
_)         a
Bool
False    = ByteString
Context Attributes
""
    alg Attributes a
Raw               a
bs       = a
Context Attributes
bs

look :: ByteString -> ByteString -> Maybe (Maybe ByteString)
look :: ByteString -> ByteString -> Maybe (Maybe ByteString)
look ByteString
key ByteString
s = ((ByteString, Maybe ByteString) -> Maybe ByteString)
-> Maybe (ByteString, Maybe ByteString) -> Maybe (Maybe ByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, Maybe ByteString) -> Maybe ByteString
forall a b. (a, b) -> b
snd (((ByteString, Maybe ByteString) -> Bool)
-> [(ByteString, Maybe ByteString)]
-> Maybe (ByteString, Maybe ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
lc ByteString
key) (ByteString -> Bool)
-> ((ByteString, Maybe ByteString) -> ByteString)
-> (ByteString, Maybe ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, Maybe ByteString)]
entries)
  where
    entries :: [(ByteString, Maybe ByteString)]
entries = [ ByteString -> (ByteString, Maybe ByteString)
breakEq (ByteString -> ByteString
strip ByteString
a) | ByteString
a <- Word8 -> ByteString -> [ByteString]
BS.split Word8
59 ByteString
s, Bool -> Bool
not (ByteString -> Bool
BS.null (ByteString -> ByteString
strip ByteString
a)) ]
    breakEq :: ByteString -> (ByteString, Maybe ByteString)
breakEq ByteString
a = case Word8 -> ByteString -> Maybe Int
BS.elemIndex Word8
61 ByteString
a of
        Maybe Int
Nothing -> (ByteString -> ByteString
lc (ByteString -> ByteString
strip ByteString
a), Maybe ByteString
forall a. Maybe a
Nothing)
        Just Int
i  -> (ByteString -> ByteString
lc (ByteString -> ByteString
strip (Int -> ByteString -> ByteString
BS.take Int
i ByteString
a)), ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> ByteString
strip (Int -> ByteString -> ByteString
BS.drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
a)))

lc :: ByteString -> ByteString
lc :: ByteString -> ByteString
lc = (Char -> Char) -> ByteString -> ByteString
BS8.map Char -> Char
toLower

strip :: ByteString -> ByteString
strip :: ByteString -> ByteString
strip = (Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhileEnd Word8 -> Bool
forall {a}. (Eq a, Num a) => a -> Bool
isSp (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile Word8 -> Bool
forall {a}. (Eq a, Num a) => a -> Bool
isSp
  where isSp :: a -> Bool
isSp a
w = a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
32 Bool -> Bool -> Bool
|| a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
9