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], -- in reverse order. The head is the last consumed dir
      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)] -- ^ CGI environment variables.
                                               -- we are wrapping only "REQUEST_METHOD" and the headers "CONTENT_TYPE" and "CONTENT_LENGTH"
                                               -- Not including "QUERYSTRING", since we are only interested in getting inputs for the post for the moment
               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

----

-- cookies and forms

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           


---testing parsing, does not belng here

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"]


-- helpers for building ReSTful links
-- The following functions should be used in combination 
-- with completeURL to build ReSTful links
addResourceIdToCollAddr :: String -> RequestContext -> RequestContext --should be applied when completeDirs address a collection
addResourceIdToCollAddr keyString rc = rc {docName = keyString}

--should be applied when completeDirs address a collection
addMethodToCollAddr :: String -> RequestContext -> RequestContext
addMethodToCollAddr meth rc = rc {docName = meth}

addMethodNewToCollAddr = addMethodToCollAddr "new"

--should be applied when completeDirs address a resource
addMethodToResAddr :: String -> RequestContext -> RequestContext
addMethodToResAddr meth rc = rc {consumedDirs = docName rc : consumedDirs rc, docName = meth}

addMethodEditToResAddr = addMethodToResAddr "edit"
addMethodDeleteToResAddr = addMethodToResAddr "delete"

--should be applied when completeDirs address a resource
addHierarchicalCollToResAddr :: String -> [(String, String)] -> RequestContext -> RequestContext
addHierarchicalCollToResAddr resTypeName restrictionQuery rc
             = rc' {consumedDirs = resTypeName : docName rc : consumedDirs rc, docName = "index" }
               where
                  rc' = upgradeQueriesForHierarchy restrictionQuery rc
--FIXME: hide query fields and others to enforce appropiate usage through narrow API

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 = [] }