Parser.hs

module Mongrel2.Parser
       ( ClientID
       , Message
       , Path
       , RequestHeaders
       , RequestBody
       , UUID
       , messageParser
       ) where

import Data.Aeson (Value(..), json)
import Data.Attoparsec
import Data.Attoparsec.Char8 (decimal)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word8)
import Mongrel2.Types (UUID, ClientID)
import Network.HTTP.Types (Query, decodePath)
import Prelude hiding (take)
import qualified Data.Map as M

type Path = ByteString

type RequestHeaders = Value

type RequestBody = ByteString

type Message = (UUID, ClientID, Path, RequestHeaders, RequestBody, ([Text], Query))

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

isColon :: Word8 -> Bool
isColon 0x3a = True
isColon _    = False

isComma :: Word8 -> Bool
isComma 0x2c = True
isComma _    = 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

netstringParser :: (Int -> Parser a) -> Parser a
netstringParser contentParser = do
  len <- decimal
  skip isColon
  str <- contentParser len
  return str

messageParser :: Parser Message
messageParser = do
  uuid <- uuidParser
  skipSpace
  clientId <- decimal
  skipSpace
  path <- takeTill isSpace
  skipSpace
  reqHdr <- netstringParser $ \_ -> json
  skip isComma
  reqBody <- netstringParser take
  return (uuid,clientId,path,reqHdr,reqBody,extractQuery reqHdr)

extractQuery :: Value -> ([Text], Query)
extractQuery (Object hdrs) =
  case M.lookup "URI" hdrs of
    Just (String uriText) -> decodePath $ encodeUtf8 uriText
    _ -> fail "Missing/invalid 'URI' in headers received from Mongrel2"
extractQuery _ = fail "Invalid headers received from Mongrel2"