Parser.hs

module Network.Protocol.Http.Parser (
    parseRequest
  , parseResponse
  ) where

import Control.Applicative hiding (empty)
import Data.Char (ord)
import Data.List (intercalate)
import Data.Map (insert, empty)
import Misc.Misc (pMaybe)
import Network.Protocol.Http.Data
import Network.Protocol.Http.Status
import Network.Protocol.Uri (pUriReference)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))

{- | Parse a string as an HTTP request message. -}

parseRequest :: String -> Either ParseError Message
parseRequest msg = parse pRequest  "" msg

{- | Parse a string as an HTTP request message. -}

parseResponse :: String -> Either ParseError Message
parseResponse msg = parse pResponse "" msg

lf, ws, ls :: String
lf = "\r\n"
ws = " \t\r\n"
ls = " \t"

pLf :: GenParser Char st Char
pLf = (char '\r' <* pMaybe (char '\n')) <|> char '\n'

pVersion :: GenParser Char st Version
pVersion = 
      (\h l -> Version (ord h - ord '0') (ord l  - ord '0'))
  <$> (string "HTTP/" *> digit)
  <*> (char '.'       *> digit)

pHeaders :: GenParser Char st Headers
pHeaders = insert
  <$> many1 (noneOf (':':ws)) <* string ":"
  <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* pLf))
  <*> option empty pHeaders

pMethod :: GenParser Char st Method
pMethod = choice $ map (\a -> a <$ (try $ string $ show a)) methods

pRequest :: GenParser Char st Message
pRequest = (\m u v h b -> Message (Request m u) v h b)
  <$> (pMethod <* many1 (oneOf ls))
  <*> (pUriReference <* many1 (oneOf ls))
  <*> (pVersion <* pLf)
  <*> (pHeaders <* pLf)
  <*> (many anyToken)

pResponse :: GenParser Char st Message
pResponse = (\v s h b -> Message (Response (statusFromCode $ read s)) v h b)
  <$> (pVersion <* many1 (oneOf ls))
  <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* pLf)
  <*> (pHeaders <* pLf)
  <*> (many anyToken)