HTTP.hs

module Control.Parser.HTTP (
  module Control.Parser,

  URI(..),uriId,uri,

  Request(..),ReqType(..),Response(..),Status(..),Header(..),Host,
  reqLine,request
  ) where

import Control.Parser hiding (space,spaces)
import Data.Char
import Data.List (intercalate)

data URI = URI {
  uriScheme :: String,
  uriUser :: Maybe String,
  uriHost :: String,
  uriPort :: Maybe Int,
  uriPath :: [String],
  uriRequest :: Maybe String,
  uriFragment :: Maybe String
  }
         deriving Show

uriId :: (Monoid w,Stream Char s,Monad m) => ParserT w s m String
uriId = many1 (satisfy (\c -> isAlphaNum c || c`elem`['-','_','~','.']))

uri :: (Monoid w,Stream Char s,Monad m) => ParserT w s m URI
uri = URI<$>(uriId <* several "://")
      <*>tryMay (uriId <* single '@')
      <*>uriId
      <*>tryMay (single ':' *> number)
      <*>many ("/"<$single '/' <+> uriId)
      <*>tryMay (single '?' >> many (noneOf "#"))
      <*>tryMay (single '#' >> many token)


data Request = Request ReqType [Header] Host FilePath
data ReqType = GET | HEAD | POST ByteString
data Response = Response Status [Header] ByteString
data Status = OK | NotFound
data Header = Header String String
type Host = String

space :: (Monoid w, Monad m, Stream Char s) => ParserT w s m Char
space = sp <+> (nl >> sp)
  where sp = oneOf " \t"
spaces :: (Monoid w, Monad m, Stream Char s) => ParserT w s m String
spaces = many space
nl :: (Monoid w, Monad m, Stream Char s) => ParserT w s m ()
nl = try (single '\n') (several "\r\n")
word :: (Monoid w, Monad m, Stream Char s) => ParserT w s m String
word = quotedString '"' <+> many (noneOf " \t\n")
line :: (Monoid w, Monad m, Stream Char s) => ParserT w s m String
line = intercalate " " <$> (spaces >> (word`sepBy`spaces)) <* (spaces >> nl)

reqLine :: (Monoid w, Monad m) => ParserT w String m [String]
reqLine = pureParser (pure<$>words)
request :: (Monoid w, Monad m) => ParserT w String m [String]
request = do
  _ <- line >*> reqLine
  many (line <*= guard . not . null)