HttpRequestParser.hs

module HttpRequestParser
    (
      HttpRequest(..)
    , Method(..)
    , p_request
    , p_query
    ) where

import Control.Applicative
import Text.ParserCombinators.Parsec hiding (optional, (<|>), many)
import Text.Parsec.Char
import Control.Monad (liftM4, liftM)
import System.IO (Handle)

data Method = Get | Post
    deriving (Eq, Ord, Show)

data HttpRequest = HttpRequest {
    reqMethod :: Method
  , reqURL :: String
  , reqHeaders :: [(String, String)]
  , reqBody :: Maybe String
} deriving (Eq, Show)

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
          val = liftM (lookup "Content-Length") p_headers


p_query = undefined

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"