mongrel2-handler-0.2.0: src/Mongrel2/Parser.hs

module Mongrel2.Parser
       ( ClientID
       , UUID
       , messageParser
       ) where

import Data.Attoparsec
import Data.Attoparsec.Char8 (decimal)
import Data.ByteString (ByteString, uncons)
import Data.CaseInsensitive (CI)
import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Data.Word (Word8)
import Mongrel2.Tnetstring (parseTnetstring1, TValue(..))
import Mongrel2.Types (Request(..), UUID, ClientID)
import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders, decodePath, http09, http10, http11, parseMethod)
import Prelude hiding (take)
import qualified Data.CaseInsensitive as CI
import qualified Data.Map as M

-- Predicates for parsing.
isSpace :: Word8 -> Bool
isSpace 0x20 = True
isSpace _    = False

-- Skip spaces.
skipSpace :: Parser ()
skipSpace = skipWhile isSpace

-- Parse a UUID.
uuidParser :: Parser ByteString
uuidParser = takeWhile1 $ \w -> ((w >= 65) && (w <= 90 )) ||   -- A-Z
                                ((w >= 97) && (w <= 122)) ||   -- a-z
                                ((w >= 48) && (w <= 57 )) ||   -- 0-9
                                (w == 45)                      -- Dash

messageParser :: Parser Request
messageParser = do
  uuid <- uuidParser
  skipSpace
  clientId <- decimal
  skipSpace
  rawPath <- takeTill isSpace
  skipSpace
  rawReqHdr <- parseTnetstring1
  rawBody <- parseTnetstring1
  -- Touchups to conform better with Http-types.
  let reqHdr = unHeaders rawReqHdr
  let method = parseMethod $ extractMethod reqHdr
  let version = extractVersion reqHdr
  let (path,query) = extractQuery reqHdr
  return $ Request path query rawPath method version (extractHeaders reqHdr) (extractBody rawBody) uuid clientId

unHeaders :: TValue -> Map ByteString TValue
unHeaders (TDictionary m) = M.fromList m
unHeaders _               = error "Invalid headers received from Mongrel2"

extractBody :: TValue -> ByteString
extractBody (TString body) = body
extractBody _              = error "Invalid body received from Mongrel2"

extractQuery :: Map ByteString TValue -> ([Text], Query)
extractQuery hdrs =
  case M.lookup "URI" hdrs of
    Just (TString uriText) -> decodePath uriText
    _ -> error "Missing/invalid 'URI' in headers received from Mongrel2"

extractMethod :: Map ByteString TValue -> Method
extractMethod hdrs =
  case M.lookup "METHOD" hdrs of
    Just (TString methodText) -> methodText
    _ -> error "Missing/invalid 'METHOD' in headers received from Mongrel2"

extractVersion :: Map ByteString TValue -> HttpVersion
extractVersion hdrs =
  -- TODO: This really should be done in a more general way.
  case M.lookup "VERSION" hdrs of
    Just (TString "HTTP/0.9") -> http09
    Just (TString "HTTP/1.0") -> http10
    Just (TString "HTTP/1.1") -> http11
    Just _                     -> error "Unrecognized HTTP version"
    Nothing -> error "Missing HTTP version in headers received from Mongrel2"

extractHeaders :: Map ByteString TValue -> RequestHeaders
extractHeaders hdrs = catMaybes $ map extractHdr $ M.toList hdrs

extractHdr :: (ByteString, TValue) -> Maybe (CI ByteString, ByteString)
extractHdr (t, TString v) = handleHdr t v
extractHdr _              = Nothing

handleHdr :: ByteString -> ByteString -> Maybe (CI ByteString, ByteString)
handleHdr k v =
  case uncons k of
    Just (c, _) | (c >= 65 && c <= 90) -> Nothing
    _                                  -> Just (CI.mk k, v)