content: {-- snippet module --}
  module HttpRequestParser
      (
        HttpRequest(..)
      , Method(..)
      , p_request
      , p_query
      ) where
  
  import ApplicativeParsec
  import Numeric (readHex)
  import Control.Monad (liftM4)
  import System.IO (Handle)
  {-- /snippet module --}
  
  {-- snippet p_headers --}
  p_headers :: CharParser st [(String, String)]
  p_headers = header `manyTill` crlf
    where header = liftA2 (,) fieldName (char ':' *> spaces *> contents)
          contents = liftA2 (++) (many1 notEOL <* crlf)
                                 (continuation <|> pure [])
          continuation = liftA2 (:) (' ' <$ many1 (oneOf " \t")) contents
          fieldName = (:) <$> letter <*> many fieldChar
          fieldChar = letter <|> digit <|> oneOf "-_"
  
  crlf :: CharParser st ()
  crlf = (() <$ string "\r\n") <|> (() <$ newline)
  
  notEOL :: CharParser st Char
  notEOL = noneOf "\r\n"
  {-- /snippet p_headers --}
  
  {-- snippet HttpRequest --}
  data Method = Get | Post
            deriving (Eq, Ord, Show)
  
  data HttpRequest = HttpRequest {
        reqMethod :: Method
      , reqURL :: String
      , reqHeaders :: [(String, String)]
      , reqBody :: Maybe String
      } deriving (Eq, Show)
  {-- /snippet HttpRequest --}
  
  {-- snippet p_request --}
  p_request :: CharParser () HttpRequest
  p_request = q "GET" Get (pure Nothing)
          <|> q "POST" Post (Just <$> many anyChar)
    where q name ctor body = liftM4 HttpRequest req url p_headers body
              where req = ctor <$ string name <* char ' '
          url = optional (char '/') *>
                manyTill notEOL (try $ string " HTTP/1." <* oneOf "01")
                <* crlf
  {-- /snippet p_request --}
  
  urlBaseChars :: [Char]
  urlBaseChars = ['a'..'z']++['A'..'Z']++['0'..'9']++"$-_.!*'(),"
  
  p_query :: CharParser () [(String, Maybe String)]
  p_query = pair `sepBy` char '&'
    where pair = (,) <$> many1 safe <*> optional (char '=' *> many safe)
          safe = oneOf urlBaseChars
             <|> char '%' *> liftA2 diddle hexDigit hexDigit
             <|> ' ' <$ char '+'
             <?> "safe"
          diddle a b = toEnum . fst . head . readHex $ [a,b]
  