Parsers.hs

-- |
-- Module:     Network.IHttp.Parsers
-- Copyright:  (c) 2010 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
-- Stability:  beta
--
-- HTTP parsers.

{-# LANGUAGE OverloadedStrings #-}

module Network.IHttp.Parsers
    ( -- * Protocol parsers
      httpCodeP,
      httpFirstHeaderP,
      httpMethodP,
      httpMethodP',
      httpVersionP,
      messageP,
      requestLineP,
      responseLineP
    )
    where

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Map as M
import Control.ContStuff
import Data.Attoparsec.Char8 as P
import Data.ByteString (ByteString)
import Network.IHttp.Tools
import Network.IHttp.Types


-- TODO: Parse the content of the *Content-Type* header to MIME type and set
-- of parameters.

-- contentTypeP :: Parser (ByteString, Map ByteString ByteString)
-- contentTypeP =
--     contType <- httpTokenP
--     char '/'
--     subType <- httpTokenP
--     char ';'
--     skipSpace


-- | Parse an HTTP status code.

httpCodeP :: Parser Int
httpCodeP =
    (<?> "HTTP response code") $ do
        code <- P.take 3
        case BC.readInt code of
          Just (n, rest) | B.null rest -> return n
          _                            -> empty <?> "Invalid response code"


-- | Parse first HTTP header line.

httpFirstHeaderP :: Parser (ByteString, ByteString)
httpFirstHeaderP = do
    (,)
    <$> (BC.map asciiToUpper <$> httpTokenP) <* string ": "
    <*> messageP
    <?> "initial header line"


-- | Parse a known HTTP method.

httpMethodP :: Parser HttpMethod
httpMethodP =
    (<?> "HTTP request method") $
    P.choice . map (P.try . httpMethodP') $ methods

    where
    methods :: [HttpMethod]
    methods = [ ConnectMethod, DeleteMethod, GetMethod, HeadMethod,
                OptionsMethod, PatchMethod, PostMethod, PutMethod,
                TraceMethod ]


-- | Parse the given HTTP method.

httpMethodP' :: HttpMethod -> Parser HttpMethod
httpMethodP' method =
    let parser =
            case method of
              ConnectMethod -> string "CONNECT" <?> "CONNECT method"
              DeleteMethod  -> string "DELETE"  <?> "DELETE method"
              GetMethod     -> string "GET"     <?> "GET method"
              HeadMethod    -> string "HEAD"    <?> "HEAD method"
              OptionsMethod -> string "OPTIONS" <?> "OPTIONS method"
              PatchMethod   -> string "PATCH"   <?> "PATCH method"
              PostMethod    -> string "POST"    <?> "POST method"
              PutMethod     -> string "PUT"     <?> "PUT method"
              TraceMethod   -> string "TRACE"   <?> "TRACE method"
              XMethod str   -> return str       <?> BC.unpack str ++ " method"
    in method <$ parser


-- | Parse an HTTP token as specified by RFC 1945.

httpTokenP :: Parser ByteString
httpTokenP =
    P.takeWhile1 isTokenChar <?> "HTTP token"

    where
    tspecials' :: [Char]
    tspecials' = "()<>@,;:\\\"/[]?={}"

    isTokenChar :: Char -> Bool
    isTokenChar c = c > ' ' && c < '\DEL' && notInClass tspecials' c


-- | Parse an HTTP version in the format @HTTP/major.minor@.

httpVersionP :: Parser HttpVersion
httpVersionP =
    (<?> "version string") $ do
         string "HTTP/" <?> "\"HTTP/\" version prefix"
         major <- decimal <?> "major version"
         char '.'
         minor <- decimal <?> "minor version"
         case (major, minor) of
           (1, 0) -> return Http1_0
           (1, 1) -> return Http1_1
           _      -> empty <?> "unsupported version"


-- | Parse the rest of input as a status message.

messageP :: Parser ByteString
messageP =
    P.takeWhile (const True) <* endOfInput <?> "status message"


-- | Parse an HTTP request line.

requestLineP :: Parser Request
requestLineP =
    Request M.empty
    <$> httpMethodP <* char ' '
    <*> uriP <* char ' '
    <*> httpVersionP <* endOfInput


-- | Parse an HTTP response line.

responseLineP :: Parser Response
responseLineP =
    (\ver code msg -> Response code M.empty msg ver)
    <$> httpVersionP <* char ' '
    <*> httpCodeP <* char ' '
    <*> messageP


-- | Parse a URI (which is right now just a nonempty string token
-- without whitespace).

uriP :: Parser ByteString
uriP = P.takeWhile1 (/= ' ') <?> "URI string"