content: {-# 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 (Show, Generic, 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 (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
  
  -- | Given a header text, attempt to parse it into Headers.
  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
  