{-# 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 Header =
Header T.Text
T.Text
deriving (Show, Generic, Eq)
instance ToJSON Header
instance ToJSON Headers
newtype Headers =
HeaderSet [Header]
deriving (Show, Generic, Eq)
instance FromJSON Headers where
parseJSON a@(String v) =
case parseHeaders v of
Right h -> return h
Left e -> typeMismatch ("Header failure: " ++ T.unpack e) a
parseJSON invalid = typeMismatch "Header" invalid
parseHeaders :: T.Text -> Either T.Text Headers
parseHeaders hs = let trimmed = T.strip hs in
first (T.pack . errorBundlePretty) (Text.Megaparsec.parse headersParser "" trimmed)
type Parser = Parsec Void T.Text
headerColon :: Parser T.Text
headerColon = L.symbol space ":"
headerSemiColon :: Parser T.Text
headerSemiColon = L.symbol space ";"
endOfHeader :: Parser ()
endOfHeader = try (void headerSemiColon) <|> eof
headerParser :: Parser Header
headerParser = do
key <- do
firstChar <- satisfy asciiExcludingColonAndSpace
rest <- takeWhileP (Just "header key") asciiExcludingColon <* headerColon
return $ T.singleton firstChar <> rest
value <- takeWhileP (Just "header value") asciiExcludingSemiColon <* endOfHeader
return $ Header (T.strip key) (T.strip value) where
asciiExcludingColon = asciiExcludingChar ':'
asciiExcludingSemiColon = asciiExcludingChar ';'
asciiExcludingColonAndSpace t = asciiExcludingColon t && not (isSpace t)
asciiExcludingChar c t = isAscii t && t /= c
headersParser :: Parser Headers
headersParser = HeaderSet <$> some headerParser