{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Module defining the Header and Headers types and a parser with a FromJSON
-- instance for the Headers type.
--
-- Headers are parsed from a semi-colon separated sequence of key:value pairs.
-- Some examples:
--
-- > "key: value"
-- > "key1: value1; key2: value2"
--
-- Keys can be any sequence of ASCII characters excluding ':' and must not be
-- all whitespace. For example:
--
-- > " : value"
--
-- is invalid.
--
-- Values can be any sequence of ASCII characters excluding ';' and may be all
-- whitespace. For example:
--
-- > "key : "
--
-- is valid.
module Testing.CurlRunnings.Internal.Headers
    ( Header (..)
    , Headers (..)
    , parseHeaders
    ) where

import           Data.Aeson
import           Data.Aeson.Types           hiding (Parser)
import           Data.Bifunctor             (Bifunctor (..))
import           Data.Char                  (isAscii, isSpace)
import           Data.Functor               (void)
import qualified Data.Text                  as T
import           Data.Void
import           GHC.Generics
import           Text.Megaparsec
import           Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

-- | A representation of a single header
data Header =
  Header T.Text
         T.Text
  deriving (Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
(Int -> Header -> ShowS)
-> (Header -> String) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Header] -> ShowS
$cshowList :: [Header] -> ShowS
show :: Header -> String
$cshow :: Header -> String
showsPrec :: Int -> Header -> ShowS
$cshowsPrec :: Int -> Header -> ShowS
Show, (forall x. Header -> Rep Header x)
-> (forall x. Rep Header x -> Header) -> Generic Header
forall x. Rep Header x -> Header
forall x. Header -> Rep Header x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Header x -> Header
$cfrom :: forall x. Header -> Rep Header x
Generic, Header -> Header -> Bool
(Header -> Header -> Bool)
-> (Header -> Header -> Bool) -> Eq Header
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c== :: Header -> Header -> Bool
Eq)

instance ToJSON Header

instance ToJSON Headers

-- | Simple container for a list of headers, useful for a vehicle for defining a
-- fromJSON
newtype Headers =
  HeaderSet [Header]
  deriving (Int -> Headers -> ShowS
[Headers] -> ShowS
Headers -> String
(Int -> Headers -> ShowS)
-> (Headers -> String) -> ([Headers] -> ShowS) -> Show Headers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Headers] -> ShowS
$cshowList :: [Headers] -> ShowS
show :: Headers -> String
$cshow :: Headers -> String
showsPrec :: Int -> Headers -> ShowS
$cshowsPrec :: Int -> Headers -> ShowS
Show, (forall x. Headers -> Rep Headers x)
-> (forall x. Rep Headers x -> Headers) -> Generic Headers
forall x. Rep Headers x -> Headers
forall x. Headers -> Rep Headers x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Headers x -> Headers
$cfrom :: forall x. Headers -> Rep Headers x
Generic, Headers -> Headers -> Bool
(Headers -> Headers -> Bool)
-> (Headers -> Headers -> Bool) -> Eq Headers
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Headers -> Headers -> Bool
$c/= :: Headers -> Headers -> Bool
== :: Headers -> Headers -> Bool
$c== :: Headers -> Headers -> Bool
Eq)

instance FromJSON Headers where
  parseJSON :: Value -> Parser Headers
parseJSON a :: Value
a@(String Text
v) =
    case Text -> Either Text Headers
parseHeaders Text
v of
      Right Headers
h -> Headers -> Parser Headers
forall (m :: * -> *) a. Monad m => a -> m a
return Headers
h
      Left Text
e  -> String -> Value -> Parser Headers
forall a. String -> Value -> Parser a
typeMismatch (String
"Header failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
e) Value
a
  parseJSON Value
invalid = String -> Value -> Parser Headers
forall a. String -> Value -> Parser a
typeMismatch String
"Header" Value
invalid

-- | Given a header text, attempt to parse it into Headers.
parseHeaders :: T.Text -> Either T.Text Headers
parseHeaders :: Text -> Either Text Headers
parseHeaders Text
hs = let trimmed :: Text
trimmed = Text -> Text
T.strip Text
hs in
  (ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) Headers
-> Either Text Headers
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
T.pack (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) (Parsec Void Text Headers
-> String -> Text -> Either (ParseErrorBundle Text Void) Headers
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Text.Megaparsec.parse Parsec Void Text Headers
headersParser String
"" Text
trimmed)

type Parser = Parsec Void T.Text

headerColon :: Parser T.Text
headerColon :: Parser Text
headerColon = ParsecT Void Text Identity ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Tokens Text
":"

headerSemiColon :: Parser T.Text
headerSemiColon :: Parser Text
headerSemiColon = ParsecT Void Text Identity ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Tokens Text
";"

endOfHeader :: Parser ()
endOfHeader :: ParsecT Void Text Identity ()
endOfHeader = ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Text
headerSemiColon) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

headerParser :: Parser Header
headerParser :: Parser Header
headerParser = do
  Text
key <- do
    Char
firstChar <- (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
asciiExcludingColonAndSpace
    Text
rest <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"header key") Char -> Bool
Token Text -> Bool
asciiExcludingColon Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text
headerColon
    Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
firstChar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest
  Text
value <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"header value") Char -> Bool
Token Text -> Bool
asciiExcludingSemiColon Parser Text -> ParsecT Void Text Identity () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
endOfHeader
  Header -> Parser Header
forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> Parser Header) -> Header -> Parser Header
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Header
Header (Text -> Text
T.strip Text
key) (Text -> Text
T.strip Text
value) where
    asciiExcludingColon :: Char -> Bool
asciiExcludingColon = Char -> Char -> Bool
asciiExcludingChar Char
':'
    asciiExcludingSemiColon :: Char -> Bool
asciiExcludingSemiColon = Char -> Char -> Bool
asciiExcludingChar Char
';'
    asciiExcludingColonAndSpace :: Char -> Bool
asciiExcludingColonAndSpace Char
t = Char -> Bool
asciiExcludingColon Char
t Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isSpace Char
t)
    asciiExcludingChar :: Char -> Char -> Bool
asciiExcludingChar Char
c Char
t =  Char -> Bool
isAscii Char
t Bool -> Bool -> Bool
&& Char
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c

headersParser :: Parser Headers
headersParser :: Parsec Void Text Headers
headersParser = [Header] -> Headers
HeaderSet ([Header] -> Headers)
-> ParsecT Void Text Identity [Header] -> Parsec Void Text Headers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Header -> ParsecT Void Text Identity [Header]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Header
headerParser