module Network.HTTP.RedHandler.RequestContext where
import Network.HTTP.RedHandler.HTTP_Fork.HTTP (Request, HasHeaders, rqHeaders, rqURI, rqBody, rqMethod, lookupHeader, findHeader, getHeaders, setHeaders, HeaderName(..))
import Text.ParserCombinators.Parsec
import System.Time
import Data.List(intercalate)
import Network.HTTP.RedHandler.Utils (low, fst4, snd4, trd4, fourth4)
import qualified Data.ByteString.Lazy.Char8 as BS
import Network.CGI.Protocol (Input(..), decodeInput)
data RequestContext = RequestContext {
originalRequest :: Request,
requestTime :: CalendarTime,
dirs ::[String],
docName :: String,
format:: String,
customQuery::[(String, String)],
formInputs :: [(String,Input)],
consumedDirs ::[String],
restrictByParentQuery ::[(String, String)]
} deriving Show
query :: RequestContext -> [(String,String)]
query rc = restrictByParentQuery rc ++ customQuery rc
moveForwardDir, moveBackwardDir :: RequestContext -> Maybe (RequestContext, String)
moveForwardDir rc = case dirs rc of
[] -> Nothing
(d:ds) -> Just (rc {dirs = ds, consumedDirs = d:consumedDirs rc}, d)
moveBackwardDir rc = case consumedDirs rc of
[] -> Nothing
(d:ds) -> Just (rc {consumedDirs = ds, dirs = d:dirs rc}, d)
completeDirs :: RequestContext -> [String]
completeDirs rc = reverse (consumedDirs rc) ++ dirs rc
completeURL :: RequestContext -> String
completeURL rc = concat (map ("/"++) $ completeDirs rc) ++ "/" ++ docAndQuery
where docAndQuery = docName rc ++ "." ++ format rc ++ renderQuery (customQuery rc)
pendingURIPath :: RequestContext -> String
pendingURIPath rc = concat (map (++"/") $ dirs rc) ++ docName rc ++ "." ++ format rc
renderQuery :: [(String,String)] -> String
renderQuery [] = ""
renderQuery pairs = "?" ++ intercalate ";" (map (\(k,val) -> k ++ "=" ++ val) pairs)
instance HasHeaders RequestContext where
getHeaders = rqHeaders . originalRequest
setHeaders rqc hdrs = rqc { originalRequest = (originalRequest rqc) {rqHeaders=hdrs} }
mkRqCtx::Request-> IO RequestContext
mkRqCtx rq = do tm <- toCalendarTime =<< getClockTime
let dcurl = case (parse parseURL "" $ (show $ rqURI rq)) of
Left err -> ([], "index","html",[])
Right x -> x
return $ RequestContext rq tm (fst4 dcurl) (snd4 dcurl) (trd4 dcurl) (fourth4 dcurl) buildFormInputs [] []
where
buildFormInputs :: [(String,Input)]
buildFormInputs = fst $ decodeInput cgiLibEnvVars (BS.pack $ rqBody rq)
cgiLibEnvVars :: [(String,String)]
cgiLibEnvVars = methodEnvVar ++ contentTypeEnvVar ++ contentLengthEnvVar
methodEnvVar = [("REQUEST_METHOD", show $ rqMethod rq)]
contentTypeEnvVar = case lookupHeader HdrContentType (rqHeaders rq) of
Nothing -> []
Just v -> [("CONTENT_TYPE",v)]
contentLengthEnvVar = case lookupHeader HdrContentLength (rqHeaders rq) of
Nothing -> []
Just v -> [("CONTENT_LENGTH",v)]
parseURL = do skipMany $ char '/'
_dirs <- try $ many $ try parseDir
_doc <- try $ many $noneOf ".?"
skipMany $ char '.'
_format <- try $ many $ noneOf "?"
q <- try parseQuery
return (_dirs,
_doc `orIfEmpty` "index",
(low _format) `orIfEmpty` "html",
q)
parseDir = do name <- many1 $ noneOf "?/"
char '/'
return $ low name
parseQuery = do skipMany $ char '?'
pair `sepBy` char ';'
where pair = do key <- many1 (alphaNum <|> char '_')
char '='
val <- many1 (noneOf ";")
return ( key,val)
orIfEmpty :: [a]->[a] ->[a]
orIfEmpty [] xs = xs
orIfEmpty ys _ = ys
hasCookie:: String -> RequestContext -> Bool
hasCookie str req = case findHeader HdrCookie req of
Just str->True
_ ->False
postFields :: RequestContext -> [(String,String)]
postFields rq = [ (n, BS.unpack (inputValue i)) | (n,i) <- formInputs rq ]
postFieldFileName :: String -> RequestContext -> Maybe String
postFieldFileName fieldname rq = lookup fieldname (formInputs rq) >>= inputFilename
postField:: String -> RequestContext -> String
postField field req = case lookup field $ postFields req of
Nothing -> ""
Just s -> s
run :: Show a => Parser a -> String -> IO ()
run pars input
= case (parse pars "" input) of
Left err -> do{ putStr "parse error at "
; print err
}
Right x -> print (input++": "++show x)
showParses :: Show a => Parser a -> [String] -> IO ()
showParses pars strs = sequence_ $ map (run pars) strs
tup = showParses parseURL ["/my/folder/index?foo=bar",
"/my/folder/index.html?foo=bar",
"/my/folder/index.json"]
addResourceIdToCollAddr :: String -> RequestContext -> RequestContext
addResourceIdToCollAddr keyString rc = rc {docName = keyString}
addMethodToCollAddr :: String -> RequestContext -> RequestContext
addMethodToCollAddr meth rc = rc {docName = meth}
addMethodNewToCollAddr = addMethodToCollAddr "new"
addMethodToResAddr :: String -> RequestContext -> RequestContext
addMethodToResAddr meth rc = rc {consumedDirs = docName rc : consumedDirs rc, docName = meth}
addMethodEditToResAddr = addMethodToResAddr "edit"
addMethodDeleteToResAddr = addMethodToResAddr "delete"
addHierarchicalCollToResAddr :: String -> [(String, String)] -> RequestContext -> RequestContext
addHierarchicalCollToResAddr resTypeName restrictionQuery rc
= rc' {consumedDirs = resTypeName : docName rc : consumedDirs rc, docName = "index" }
where
rc' = upgradeQueriesForHierarchy restrictionQuery rc
setCollectionFromRootAddr :: String -> RequestContext -> RequestContext
setCollectionFromRootAddr resTypeName rc
= rc {consumedDirs = [resTypeName], docName = "index",
restrictByParentQuery = [], customQuery = [] }
upgradeQueriesForHierarchy :: [(String, String)] -> RequestContext -> RequestContext
upgradeQueriesForHierarchy restrictionQuery rc = rc {restrictByParentQuery = restrictionQuery, customQuery = [] }