{-# 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