{-# OPTIONS_GHC -XOverloadedStrings -funbox-strict-fields -XDeriveDataTypeable #-}

module OpenResty.Request (
    parseCGIEnv, Request(..), DataFormat(..), RestyError(..)
) where

import Network.FastCGI
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as B
import Network.URI (unEscapeString, uriPath)
import Data.List (stripPrefix)
import Data.Char (toLower)
import Text.Regex.PCRE.Light
import Control.Exception
import Debug.Trace (trace)
import Data.Typeable
import Text.JSON
import Safe

data RestyError = URIError B.ByteString
                | MiscError B.ByteString
                | UnknownError B.ByteString
  deriving (Typeable)

instance Show RestyError where
    show (URIError s) = B.unpack s
    show (MiscError s) = B.unpack s
    show _ = "Unknown error"

data DataFormat = DFJson | DFYaml
    deriving (Show)

toDataFormat = [
    ("json",DFJson),
    ("js",DFJson),
    ("yaml",DFYaml),
    ("yml",DFYaml)]

data Request = Request {
    category :: B.ByteString,
    method :: B.ByteString,
    content :: BL.ByteString,
    format :: DataFormat,
    pathBits :: [B.ByteString],
    params :: [(String, BL.ByteString)]
}
    deriving (Show)

instance JSON Request where
    showJSON req =
        JSObject $ toJSObject [
            ("category", showJSON $ B.unpack $ category req),
            ("method", showJSON $ B.unpack $ method req),
            ("content", showJSON $ BL.unpack $ content req),
            ("format", showJSON $ format req),
            ("pathBits", showList $ pathBits req),
            ("params", showList' $ params req)]
        where showList = JSArray . map (showJSON . B.unpack)
              showList' = JSArray . map (showJSON . pair2str)
              pair2str p = JSArray $ map showJSON [fst p, BL.unpack $ snd p]
    readJSON = undefined

instance JSON DataFormat where
    showJSON DFYaml = JSString $ toJSString "yaml"
    showJSON DFJson = JSString $ toJSString "json"
    readJSON = undefined

parseCGIEnv :: CGI Request
parseCGIEnv = do
    uri <- requestURI
    inputs <- getInputsFPS
    (prefix, cat, pbits, fmt) <- parsePath $ B.pack $ uriPath uri
    meth <- if prefix /= ""
        then (return prefix) else (fmap B.pack $ requestMethod)
    body <- getBodyFPS -- XXX TODO: check if body is too long
    dataParam <- getInputFPS "_data"
    return $ Request {
        category = unescape cat,
        method = meth,
        content = if (meth == "PUT" || meth == "POST") && body == ""
                    then maybe "" id dataParam
                    else body,
        format = maybe DFJson id $ lookup (lc fmt) toDataFormat,
        pathBits = map unescape $ filter (/="") pbits,
        -- pathBits = map (B.pack . unEscapeString . B.unpack) $ B.split '/' pbits,
        params = inputs
    }

unescape :: B.ByteString -> B.ByteString
unescape = B.pack . unEscapeString . B.unpack

lc :: B.ByteString -> B.ByteString
lc = B.map toLower

parsePath :: B.ByteString -> CGI (B.ByteString, B.ByteString, [B.ByteString], B.ByteString)
parsePath path = if B.isPrefixOf "/=/" path
    then splitPath $ B.drop 3 path
    else throwDyn $ URIError "URL must be preceded by \"/=/\"."

splitPath :: B.ByteString -> CGI (B.ByteString, B.ByteString, [B.ByteString], B.ByteString)
splitPath p = case B.span (/='/') p of
    ("put", s)    -> fmap (prepend "PUT") $ splitBarePath $ B.tail s
    ("post", s)   -> fmap (prepend "POST") $ splitBarePath $ B.tail s
    ("delete", s) -> fmap (prepend "DELETE") $ splitBarePath $ B.tail s
    ("", "")      -> return ("version", "", [], "json")
    _             -> fmap (prepend "") $ splitBarePath p
    where prepend d (a, b, c) = (d, a, b, c)

splitBarePath :: B.ByteString -> CGI (B.ByteString, [B.ByteString], B.ByteString)
splitBarePath p = if null bits
        then return ("version", [], "json")
        else return (head bits, (init bits) ++ [mid], fmt)
    where bits = B.split '/' p
          (mid, fmt) = processSuffix (last bits)

processSuffix :: B.ByteString -> (B.ByteString, B.ByteString)
processSuffix str =
    let regex = compile "(.*?)\\.(json|js|yaml|yml)$" [] in
        case match regex str [] of
            Just res -> (res !! 1, res !! 2)
            Nothing  -> (str, "json")

--dropUtil :: (Char -> Bool) -> B.ByteString
--dropUtil = B.tail . B.dropWhile