RequestEnv.hs

{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  HSP.Data.RequestEnv
-- Copyright   :  (c) Niklas Broberg 2004,
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se
-- Stability   :  experimental
-- Portability :  requires undecidable and overlapping instances
--
-- Defines the RequestEnv object available to HSP pages,
-- either in the form of a complete Request structure,
-- or as a set of CGI environment variables.
-----------------------------------------------------------------------------
module HSP.Data.RequestEnv (
	  RequestEnv		-- ^ The Request type is abstract
	, newRequest		-- ^ :: HTTP.Request.Request -> RequestEnv
	, newCGIReq		-- ^ :: CGI.CGIEnv -> RequestEnv
	, getVarValue		-- ^ :: RequestEnv -> String -> Maybe String
	, getMethod		-- ^ :: RequestEnv -> Method
	, getCookie		-- ^ :: RequestEnv -> String -> Maybe String
	, Method(..)		-- ^ An HTTP Method
	, RequestURI(..)
	, HTTPVersion(..)
	) where

import HTTP.Request

import CGI.CGIEnv
import Network.URI

import qualified Data.Map as M

{- |
   The Request datatype is a repository of request scope variables,
   together with extra information on the incomming HTTP request such
   as headers, method etc.
-}
data RequestEnv = RequestEnv {
	dataRep :: M.Map String [String],
	cookies :: M.Map String String,
	rawData :: Either Request CGIEnv
	}

-- | Build a HSP Request object given a parsed HTTP request.
newRequest :: Request -> RequestEnv
newRequest req =
	let headers = reqHeaders req
	    mch = lookupHeader headers "Cookie"
	    ckies = case mch of
			Nothing -> []
			Just str -> csToVars str
	in case reqMethod req of
	    GET -> let vars = readURIVars (reqURI req)
	 	    in RequestEnv {
	 	 	dataRep = M.fromListWith (++) vars,
			cookies = M.fromList ckies,
	 		rawData = Left req }
	    _   -> RequestEnv {
	 		dataRep = M.empty,
			cookies = M.fromList ckies,
	 		rawData = Left req }
  where	readURIVars :: RequestURI -> [(String, [String])]
	readURIVars uri = case uri of
		AbsURI uri -> qsToVars (uriQuery uri)
		AbsPath p  -> case dropWhile (/='?') p of
				""     -> []
				(_:qs) -> qsToVars qs
		_ -> []

lookupHeader :: [Header] -> String -> Maybe String
lookupHeader [] _ = Nothing
lookupHeader ((Header (fn, fv)):hs) str =
	if fn == str then Just fv else lookupHeader hs str


newCGIReq :: CGIEnv -> RequestEnv
newCGIReq cgienv@(rvars,rbody) =
        let vars = case lookup "REQUEST_METHOD" rvars of
                     Just "POST" -> newCGIPostReq cgienv
                     _           -> newCGIGetReq rvars
            ckies = case lookup "HTTP_COOKIE" rvars of
		     Just cs -> M.fromList $ csToVars cs
		     Nothing -> M.empty
	 in RequestEnv {
		dataRep = vars,
		cookies = ckies,
		rawData = Right cgienv }

newCGIGetReq :: [CGIVariable] -> M.Map String [String]
newCGIGetReq cgienv =
	case lookup "QUERY_STRING" cgienv of
	    Just qs -> M.fromListWith (++) $ qsToVars qs
	    Nothing -> M.empty

newCGIPostReq :: CGIEnv -> M.Map String [String]
newCGIPostReq (cgienv,rbody) =
        case lookup "CONTENT_LENGTH" cgienv of
        -- if content length is not a valid int an exception is thrown
            Just l  -> M.fromListWith (++) $ qsToVars $ take (read l) rbody
            Nothing -> M.empty


qsToVars :: String -> [(String, [String])]
qsToVars [/ ks@_+, '=', vs@_*, (/ '&', kss@:_+, '=', vss@:_* /)* /]
	= zip (ks:kss) $ map (\s -> [unEscape s]) (vs:vss)
qsToVars "" = [] -- TODO: What if there's an error?

csToVars :: String -> [(String, String)]
csToVars [/ ' '*!, ks@_+, ' '*!, '=', ' '*!, vs@_+, ' '*!,
		(/ ';', ' '*!, kss@:_+, ' '*!, '=', ' '*!, vss@:_+, ' '*! /)* /]
	= zip (ks:kss) (vs:vss)
csToVars "" = []

unEscape s = unEscapeString $ map (\ch -> if ch == '+' then ' ' else ch) s

-- | Return the value of a request scope variable, if available.
getVarValue :: RequestEnv -> String -> Maybe [String]
getVarValue req key = M.lookup key (dataRep req)

-- | Return the HTTP method for this request.
getMethod :: RequestEnv -> Method
getMethod = either reqMethod (maybe GET read . lookup "REQUEST_METHOD" . fst) . rawData -- TODO: what to do on error?

-- | Return the value of a Cookie
getCookie :: RequestEnv -> String -> Maybe String
getCookie req co = M.lookup co (cookies req)

{-
-- | Return the URI for this request.
getURI :: RequestEnv -> RequestURI
getURI re = case rawData re of
	     Left req -> reqURI req
	     Right -> ???

-- | Return the HTTP version used in this request.
getVersion :: RequestEnv -> HTTPVersion
getVersion re = either reqVersion
			(maybe http1_1 read . lookup "SERVER_PROTOCOL") -- ?? shouldn't that be client?

-- | Return the value associated with a given header, if
-- the header was set in the incomming request.
getHeader :: RequestEnv -> String -> Maybe String
getHeader req hd =
	let headers = reqHeaders $ rawRequest req
	 in lookupHeader hd headers
  where lookupHeader hd [] = Nothing
  	lookupHeader hd (Header (hn, hv):hds)
  		| hd == hn  = Just hv
  		| otherwise = lookupHeader hd hds
-}