{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
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
data =
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
newtype =
[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
parseHeaders :: T.Text -> Either T.Text Headers
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
= 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
= 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 ()
= 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
= 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
= [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