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

import Data.Aeson (Value(..), json)
import Data.Attoparsec
import Data.Attoparsec.Char8 (decimal)
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI)
import Data.Map (Map)
import Data.Maybe (catMaybes)
import Data.Text (Text, uncons)
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word8)
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

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 Request
messageParser = do
  uuid <- uuidParser
  skipSpace
  clientId <- decimal
  skipSpace
  rawPath <- takeTill isSpace
  skipSpace
  rawReqHdr <- netstringParser $ \_ -> json
  skip isComma
  body <- netstringParser take
  -- 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) body uuid clientId

unHeaders :: Value -> Map Text Value
unHeaders (Object m) = m
unHeaders _          = error "Invalid headers received from Mongrel2"

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

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

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

extractHeaders :: Map Text Value -> RequestHeaders
extractHeaders hdrs = catMaybes $ map extractHdr $ M.toList hdrs

extractHdr :: (Text, Value) -> Maybe (CI ByteString, ByteString)
extractHdr (t, String v) = handleHdr t v
extractHdr _             = Nothing

handleHdr :: Text -> Text -> Maybe (CI ByteString, ByteString)
handleHdr k v =
  case uncons k of
    Just (c, _) | (c >= 'A' && c <= 'Z') -> Nothing
    _                                    -> Just (CI.mk $ encodeUtf8 k, encodeUtf8 v)