diff --git a/HSP/CGI/CGIEnv.hs b/HSP/CGI/CGIEnv.hs deleted file mode 100644 --- a/HSP/CGI/CGIEnv.hs +++ /dev/null @@ -1,126 +0,0 @@ -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 diff --git a/HSP/CGI/NumberGen.hs b/HSP/CGI/NumberGen.hs deleted file mode 100644 --- a/HSP/CGI/NumberGen.hs +++ /dev/null @@ -1,16 +0,0 @@ -module HSP.CGI.NumberGen - ( - mkNumberGen - - ) where - -import HSP.Env.NumberGen - -import Data.IORef - -mkNumberGen :: IO NumberGen -mkNumberGen = do - ref <- newIORef 0 - let inc x = (x+1, x) - gen = atomicModifyIORef ref inc - return $ NumberGen gen diff --git a/HSP/CGI/RunCGI.hs b/HSP/CGI/RunCGI.hs deleted file mode 100644 --- a/HSP/CGI/RunCGI.hs +++ /dev/null @@ -1,41 +0,0 @@ -module HSP.CGI.RunCGI (runCGI) where - -import Prelude hiding (catch) - -import System.IO (stdout, hPutStr) -import Control.Exception -- (Exception, catch, finally) - -import HSP hiding (catch) -import HSP.Env.Request (Request) -import HSP.CGI.CGIEnv (getCGIReq) -import HSP.CGI.NumberGen (mkNumberGen) - - -runCGI :: HSP XML -> IO () -runCGI page - = (getCGIReq >>= evalCGI page >>= sendCGIResponse) - `catch` handleError - `finally` return () - - -evalCGI :: HSP XML -> Request -> IO CGIResponse -evalCGI page req = do - gen <- mkNumberGen - runHSP page (HSPEnv req gen) >>= return . cgiResponse . renderXML - - -type CGIResponse = String - -cgiResponse :: String -> CGIResponse -cgiResponse body = - "Content-length: " ++ show (length body) ++ - "\nContent-type: text/html" ++ - "\n\n" ++ - body - -sendCGIResponse :: CGIResponse -> IO () -sendCGIResponse = hPutStr stdout - -handleError :: Exception -> IO () -handleError ex = case ex of - _ -> sendCGIResponse $ "Error: " ++ show ex diff --git a/hsp-cgi.cabal b/hsp-cgi.cabal --- a/hsp-cgi.cabal +++ b/hsp-cgi.cabal @@ -1,24 +1,25 @@ Name: hsp-cgi -Version: 0.4 +Version: 0.4.4 License: BSD3 License-File: LICENSE Author: Niklas Broberg Maintainer: Niklas Broberg Stability: Experimental -Category: Language +Category: Web, Network Synopsis: Facilitates running Haskell Server Pages web pages as CGI programs. Description: Haskell Server Pages (HSP) is an extension of vanilla Haskell, targetted at the task of writing dynamic server-side web pages. This module provides facilities to allow such pages to be run as CGI programs. Homepage: http://code.google.com/p/hsp -Build-Depends: base>3, hsp>=0.4, network, containers, harp +Build-Depends: base>3, hsp>=0.4.4, network, containers, harp Build-Type: Simple Tested-With: GHC==6.8.3 +Hs-Source-Dirs: src Exposed-Modules: HSP.CGI.RunCGI -Other-Modules: HSP.CGI.CGIEnv, HSP.CGI.NumberGen +Other-Modules: HSP.CGI.CGIEnv, HSP.CGI.NumberGen GHC-Options: -F -pgmFtrhsx -Wall Extensions: PatternGuards diff --git a/src/HSP/CGI/CGIEnv.hs b/src/HSP/CGI/CGIEnv.hs new file mode 100644 --- /dev/null +++ b/src/HSP/CGI/CGIEnv.hs @@ -0,0 +1,126 @@ +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 diff --git a/src/HSP/CGI/NumberGen.hs b/src/HSP/CGI/NumberGen.hs new file mode 100644 --- /dev/null +++ b/src/HSP/CGI/NumberGen.hs @@ -0,0 +1,16 @@ +module HSP.CGI.NumberGen + ( + mkNumberGen + + ) where + +import HSP.Env.NumberGen + +import Data.IORef + +mkNumberGen :: IO NumberGen +mkNumberGen = do + ref <- newIORef 0 + let inc x = (x+1, x) + gen = atomicModifyIORef ref inc + return $ NumberGen gen diff --git a/src/HSP/CGI/RunCGI.hs b/src/HSP/CGI/RunCGI.hs new file mode 100644 --- /dev/null +++ b/src/HSP/CGI/RunCGI.hs @@ -0,0 +1,41 @@ +module HSP.CGI.RunCGI (runCGI) where + +import Prelude hiding (catch) + +import System.IO (stdout, hPutStr) +import Control.Exception -- (Exception, catch, finally) + +import HSP hiding (catch) +import HSP.Env.Request (Request) +import HSP.CGI.CGIEnv (getCGIReq) +import HSP.CGI.NumberGen (mkNumberGen) + + +runCGI :: HSP XML -> IO () +runCGI page + = (getCGIReq >>= evalCGI page >>= sendCGIResponse) + `catch` handleError + `finally` return () + + +evalCGI :: HSP XML -> Request -> IO CGIResponse +evalCGI page req = do + gen <- mkNumberGen + runHSP page (HSPEnv req gen) >>= return . cgiResponse . renderXML + + +type CGIResponse = String + +cgiResponse :: String -> CGIResponse +cgiResponse body = + "Content-length: " ++ show (length body) ++ + "\nContent-type: text/html" ++ + "\n\n" ++ + body + +sendCGIResponse :: CGIResponse -> IO () +sendCGIResponse = hPutStr stdout + +handleError :: Exception -> IO () +handleError ex = case ex of + _ -> sendCGIResponse $ "Error: " ++ show ex