CGIEnv.hs

module HSP.CGI.CGIEnv (
	CGIEnv,
	CGIVariable,
	getCGIReq
	) where

import System.Environment (getEnv)
import System.IO.Error (isDoesNotExistError)
import Control.Exception (Exception(..), catch, throw)
import Network.URI (unEscapeString)
import Prelude hiding (catch)

import qualified Data.Map as M

import HSP.Env.Request

type CGIEnv = ([CGIVariable],RequestBody)
type CGIVariable  = (VariableName, Value)
type VariableName = String
type Value        = String
type RequestBody  = String

getCGIReq :: IO Request
getCGIReq = fmap newCGIReq getCGIVars
	

getCGIVars :: IO CGIEnv
getCGIVars = do f <- mapM getCGIVar cgiVars
                s <- getContents
                return (f,s)

getCGIVar :: VariableName -> IO CGIVariable
getCGIVar name
    = do vv <- getEnv name `catch` handleException
         return $ (name, vv)
    where
     handleException :: Exception -> IO Value
     handleException (IOException e)
         | isDoesNotExistError e = return ""
     handleException e = throw e

cgiVars :: [VariableName]
cgiVars
    = [ 
       -- environment variables as specified by CGI/1.1
        "SERVER_SOFTWARE"
      , "SERVER_NAME"
      , "GATEWAY_INTERFACE"
      , "SERVER_PROTOCOL"
      , "SERVER_PORT"
      , "REQUEST_METHOD"
      , "PATH_INFO"
      , "PATH_TRANSLATED"
      , "SCRIPT_NAME"
      , "QUERY_STRING"
      , "REMOTE_HOST"
      , "REMOTE_ADDR"
      , "AUTH_TYPE"
      , "REMOTE_USER"
      , "REMOTE_IDENT"
      , "CONTENT_TYPE"
      , "CONTENT_LENGTH"
       -- environment variables for general HTTP headers, rfc2616
      , "HTTP_CACHE_CONTROL"
      , "HTTP_CONNECTION"
      , "HTTP_DATE"
      , "HTTP_PRAGMA"
      , "HTTP_TRAILER"
      , "HTTP_TRANSFER_ENCODING"
      , "HTTP_UPGRADE"
      , "HTTP_VIA"
      , "HTTP_WARNING"
       -- environment variables for request HTTP headers, rfc2616
      , "HTTP_ACCEPT"
      , "HTTP_ACCEPT_CHARSET"
      , "HTTP_ACCEPT_ENCODING"
      , "HTTP_ACCECPT_LANGUAGE"
      , "HTTP_AUTHORIZATION"
      , "HTTP_EXPECT"
      , "HTTP_FROM"
      , "HTTP_HOST"
      , "HTTP_IF_MATCH"
      , "HTTP_IF_MODIFIED_SINCE"
      , "HTTP_IF_NONE_MATCH"
      , "HTTP_IF_RANGE"
      , "HTTP_IF_UNMODIFIED_SINCE"
      , "HTTP_MAX_FORWARDS"
      , "HTTP_PROXY_AUTHORIZATION"
      , "HTTP_RANGE"
      , "HTTP_REFERER"
      , "HTTP_TE"
      , "HTTP_USER_AGENT"
       -- environment variable for request HTTP header "Cookie", rfc 2109
      , "HTTP_COOKIE"
      ]

newCGIReq :: CGIEnv -> Request
newCGIReq cgienv@(rvars,_) =
        let vars = case lookup "REQUEST_METHOD" rvars of
                     Just "POST" -> newCGIPostReq cgienv
                     _           -> newCGIGetReq rvars
	 in Request { 
		getParameterL = (\s -> maybe [] id $ M.lookup s vars),
		getHeaders = fst 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) -- TODO: List values?
qsToVars "" = []
qsToVars _ = [] -- TODO: What if there's an error?

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