diff --git a/HSP/CGI/CGIEnv.hs b/HSP/CGI/CGIEnv.hs new file mode 100644 --- /dev/null +++ b/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/HSP/CGI/NumberGen.hs b/HSP/CGI/NumberGen.hs new file mode 100644 --- /dev/null +++ b/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/HSP/CGI/RunCGI.hs b/HSP/CGI/RunCGI.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsp-cgi.cabal b/hsp-cgi.cabal new file mode 100644 --- /dev/null +++ b/hsp-cgi.cabal @@ -0,0 +1,24 @@ +Name: hsp-cgi +Version: 0.4 +License: BSD3 +License-File: LICENSE +Author: Niklas Broberg +Maintainer: Niklas Broberg + +Stability: Experimental +Category: Language +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-Type: Simple +Tested-With: GHC==6.8.3 + +Exposed-Modules: HSP.CGI.RunCGI +Other-Modules: HSP.CGI.CGIEnv, HSP.CGI.NumberGen + +GHC-Options: -F -pgmFtrhsx -Wall +Extensions: PatternGuards