cgi (empty) → 3000.0.0
raw patch · 10 files changed
+1785/−0 lines, 10 filesdep +basedep +mtldep +networkbuild-type:Customsetup-changed
Dependencies added: base, mtl, network, parsec, xhtml
Files
- LICENSE +31/−0
- Network/CGI.hs +534/−0
- Network/CGI/Compat.hs +113/−0
- Network/CGI/Cookie.hs +155/−0
- Network/CGI/Monad.hs +119/−0
- Network/CGI/Multipart.hs +211/−0
- Network/CGI/Protocol.hs +316/−0
- Network/CGI/RFC822Headers.hs +264/−0
- Setup.hs +6/−0
- cgi.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright 2001-2005, The University Court of the University of+Glasgow, Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- 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.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "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+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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.
+ Network/CGI.hs view
@@ -0,0 +1,534 @@+{-# OPTIONS_GHC -fallow-overlapping-instances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI+-- Copyright : (c) The University of Glasgow 2001+-- (c) Bjorn Bringert 2004-2006+-- (c) Ian Lynagh 2005+-- (c) Jeremy Shaw 2005+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (uses Control.Monad.State)+--+-- Simple Library for writing CGI programs.+-- See <http://hoohoo.ncsa.uiuc.edu/cgi/interface.html> for the+-- CGI specification.+--+-- This version of the library is for systems with version 2.0 or greater+-- of the network package. This includes GHC 6.6 and later. For older+-- systems, see <http://www.cs.chalmers.se/~bringert/darcs/cgi-compat/doc/>+--+-- Based on the original Haskell binding for CGI:+--+-- Original Version by Erik Meijer <mailto:erik@cs.ruu.nl>.+-- Further hacked on by Sven Panne <mailto:sven.panne@aedion.de>.+-- Further hacking by Andy Gill <mailto:andy@galconn.com>.+-- A new, hopefully more flexible, interface+-- and support for file uploads by Bjorn Bringert <mailto:bjorn@bringert.net>.+--+-- Here is a simple example, including error handling (not that there is +-- much that can go wrong with Hello World):+--+-- > import Network.CGI+-- >+-- > cgiMain :: CGI CGIResult+-- > cgiMain = output "Hello World!"+-- >+-- > main :: IO ()+-- > main = runCGI (handleErrors cgiMain)+--+--+-----------------------------------------------------------------------------++module Network.CGI (+ -- * CGI monad+ MonadCGI, CGIT, CGIResult, CGI+ , MonadIO, liftIO+ , runCGI+ -- * Error handling+ , throwCGI, catchCGI, tryCGI, handleExceptionCGI+ , handleErrors+ -- * Logging+ , logCGI+ -- * Output+ , output, outputFPS, outputNothing, redirect+ , setHeader, setStatus+ -- * Error pages+ , outputError, outputException + , outputNotFound, outputMethodNotAllowed, outputInternalServerError+ -- * Input+ , getInput, getInputFPS, readInput+ , getInputs, getInputNames+ , getMultiInput+ , getInputFilename, getInputContentType+ -- * Environment+ , getVar, getVarWithDefault, getVars+ , serverName, serverPort+ , requestMethod, pathInfo+ , pathTranslated, scriptName+ , queryString+ , remoteHost, remoteAddr+ , authType, remoteUser+ , requestContentType, requestContentLength+ , requestHeader+ -- * Program and request URI+ , progURI, queryURI, requestURI+ -- * Content type+ , ContentType(..), showContentType, parseContentType+ -- * Cookies+ , Cookie(..), newCookie+ , getCookie, readCookie+ , setCookie, deleteCookie+ -- * URL encoding+ , formEncode, urlEncode, formDecode, urlDecode+ -- * Compatibility with the old API+ , module Network.CGI.Compat+ ) where++import Control.Exception (Exception(..))+import Control.Monad (liftM)+import Control.Monad.Trans (MonadIO, liftIO)+import Data.Char (toUpper)+import Data.List (intersperse, sort, group)+import Data.Maybe (fromMaybe)+import qualified Data.Map as Map+import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference)+import System.IO (stdin, stdout)+import System.IO.Error (isUserError, ioeGetErrorString)++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++import Network.CGI.Cookie (Cookie(..), showCookie, newCookie, findCookie)+import qualified Network.CGI.Cookie as Cookie (deleteCookie)+import Network.CGI.RFC822Headers (ContentType(..), + parseContentType, showContentType)+import Network.CGI.Monad+import Network.CGI.Protocol+import Network.CGI.Compat++import Text.XHtml (Html, renderHtml, header, (<<), thetitle, (+++), + body, h1, paragraph, hr, address)+++-- | Run a CGI action. Typically called by the main function.+-- Reads input from stdin and writes to stdout. Gets+-- CGI environment variables from the program environment.+runCGI :: MonadIO m => CGIT m CGIResult -> m ()+runCGI f = do env <- getCGIVars+ hRunCGI env stdin stdout (runCGIT f)+++--+-- * Output \/ redirect+--++-- | Output a 'String'. The output is assumed to be text\/html, encoded using+-- ISO-8859-1. To change this, set the Content-type header using+-- 'setHeader'.+output :: MonadCGI m =>+ String -- ^ The string to output.+ -> m CGIResult+output = return . CGIOutput . BS.pack++-- | Output a 'ByteString'. The output is assumed to be text\/html, +-- encoded using ISO-8859-1. To change this, set the +-- Content-type header using 'setHeader'.+outputFPS :: MonadCGI m =>+ ByteString -- ^ The string to output.+ -> m CGIResult+outputFPS = return . CGIOutput++-- | Do not output anything (except headers).+outputNothing :: MonadCGI m => m CGIResult+outputNothing = return CGINothing++-- | Redirect to some location.+redirect :: MonadCGI m =>+ String -- ^ A URL to redirect to.+ -> m CGIResult+redirect url = do setHeader "Location" url+ outputNothing++--+-- * Error handling+--++-- | Catches any exception thrown by the given CGI action,+-- returns an error page with a 500 Internal Server Error,+-- showing the exception information, and logs the error.+-- +-- Typical usage:+--+-- > cgiMain :: CGI CGIResult+-- > cgiMain = ...+-- >+-- > main :: IO ()+-- > main = runCGI (handleErrors cgiMain)+handleErrors :: CGI CGIResult -> CGI CGIResult+handleErrors = flip catchCGI outputException++--+-- * Error output+--++-- | Output a 500 Internal Server Error with information from+-- an 'Exception'.+outputException :: (MonadCGI m,MonadIO m) => Exception -> m CGIResult+outputException e = outputInternalServerError es+ where es = case e of+ ErrorCall msg -> [msg]+ IOException ie -> ioe ie+ _ -> [show e]+ ioe ie = if isUserError ie then [ioeGetErrorString ie] else [show ie]++-- | Output an error page to the user, with the given+-- HTTP status code in the response. Also logs the error information+-- using 'logCGI'.+outputError :: (MonadCGI m, MonadIO m) =>+ Int -- ^ HTTP Status code+ -> String -- ^ Status message+ -> [String] -- ^ Error information+ -> m CGIResult+outputError c m es = + do logCGI $ show (c,m,es)+ setStatus c m+ setHeader "Content-type" "text/html; charset=ISO-8859-1"+ page <- errorPage c m es + output $ renderHtml page++-- | Create an HTML error page.+errorPage :: MonadCGI m => + Int -- ^ Status code+ -> String -- ^ Status message+ -> [String] -- ^ Error information+ -> m Html+errorPage c m es = + do server <- getVar "SERVER_SOFTWARE"+ host <- getVar "SERVER_NAME"+ port <- getVar "SERVER_PORT"+ let tit = show c ++ " " ++ m+ sig = "Haskell CGI" + ++ " on " ++ fromMaybe "" server+ ++ " at " ++ fromMaybe "" host ++ maybe "" (", port "++) port+ return $ header << thetitle << tit + +++ body << (h1 << tit +++ map (paragraph <<) es + +++ hr +++ address << sig)++--+-- * Specific HTTP errors+--++-- | Use 'outputError' to output and log a 404 Not Found error.+outputNotFound :: (MonadIO m, MonadCGI m) => + String -- ^ The name of the requested resource.+ -> m CGIResult+outputNotFound r =+ outputError 404 "Not Found" ["The requested resource was not found: " ++ r]++-- | Use 'outputError' to output and log a 405 Method Not Allowed error.+outputMethodNotAllowed :: (MonadIO m, MonadCGI m) => + [String] -- ^ The allowed methods.+ -> m CGIResult+outputMethodNotAllowed ms = + do let allow = concat $ intersperse ", " ms+ setHeader "Allow" allow+ outputError 405 "Method Not Allowed" ["Allowed methods : " ++ allow]++-- | Use 'outputError' to output and log a 500 Internal Server Error.+outputInternalServerError :: (MonadIO m, MonadCGI m) =>+ [String] -- ^ Error information.+ -> m CGIResult+outputInternalServerError es = outputError 500 "Internal Server Error" es+++--+-- * Environment variables+--++-- | Get the value of a CGI environment variable. Example:+--+-- > remoteAddr <- getVar "REMOTE_ADDR"+getVar :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> m (Maybe String)+getVar name = liftM (Map.lookup name) $ cgiGet cgiVars++getVarWithDefault :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> String -- ^ Default value + -> m String+getVarWithDefault name def = liftM (fromMaybe def) $ getVar name++-- | Get all CGI environment variables and their values.+getVars :: MonadCGI m =>+ m [(String,String)]+getVars = liftM Map.toList $ cgiGet cgiVars+++-- | The server\'s hostname, DNS alias, or IP address as it would +-- appear in self-referencing URLs.+serverName :: MonadCGI m => m String+serverName = getVarWithDefault "SERVER_NAME" ""++-- | The port number to which the request was sent.+serverPort :: MonadCGI m => m Int+serverPort = liftM (fromMaybe 80 . (>>= maybeRead)) (getVar "SERVER_PORT")++-- | The method with which the request was made. +-- For HTTP, this is \"GET\", \"HEAD\", \"POST\", etc.+requestMethod :: MonadCGI m => m String+requestMethod = getVarWithDefault "REQUEST_METHOD" "GET"++-- | The extra path information, as given by the client.+-- This is any part of the request path that follows the+-- CGI program path.+-- If the string returned by this function is not empty,+-- it is guaranteed to start with a @\'\/\'@.+pathInfo :: MonadCGI m => m String+pathInfo = liftM slash $ getVarWithDefault "PATH_INFO" ""+ where slash s = if not (null s) && head s /= '/' then '/':s else s++-- | The path returned by 'pathInfo', but with any virtual-to-physical+-- mapping applied to it.+pathTranslated :: MonadCGI m => m String+pathTranslated = getVarWithDefault "PATH_TRANSLATED" ""++-- | A virtual path to the script being executed, +-- used for self-referencing URLs.+scriptName :: MonadCGI m => m String+scriptName = getVarWithDefault "SCRIPT_NAME" ""++-- | The information which follows the ? in the URL which referenced +-- this program. This is the encoded query information.+-- For most normal uses, 'getInput' and friends are probably+-- more convenient.+queryString :: MonadCGI m => m String+queryString = getVarWithDefault "QUERY_STRING" ""++-- | The hostname making the request. If the server does not have+-- this information, Nothing is returned. See also 'remoteAddr'.+remoteHost :: MonadCGI m => m (Maybe String)+remoteHost = getVar "REMOTE_HOST"++-- | The IP address of the remote host making the request.+remoteAddr :: MonadCGI m => m String+remoteAddr = getVarWithDefault "REMOTE_ADDR" ""++-- | If the server supports user authentication, and the script is +-- protected, this is the protocol-specific authentication method +-- used to validate the user.+authType :: MonadCGI m => m (Maybe String)+authType = getVar "AUTH_TYPE"++-- | If the server supports user authentication, and the script is +-- protected, this is the username they have authenticated as.+remoteUser :: MonadCGI m => m (Maybe String)+remoteUser = getVar "REMOTE_USER"++-- | For queries which have attached information, such as +-- HTTP POST and PUT, this is the content type of the data.+-- You can use 'parseContentType' to get a structured+-- representation of the the content-type value.+requestContentType :: MonadCGI m => m (Maybe String)+requestContentType = getVar "CONTENT_TYPE"++-- | For queries which have attached information, such as +-- HTTP POST and PUT, this is the length of the content +-- given by the client.+requestContentLength :: MonadCGI m => m (Maybe Int)+requestContentLength = liftM (>>= maybeRead) $ getVar "CONTENT_LENGTH"++-- | Gets the value of the request header with the given name.+-- The header name is case-insensitive.+-- Example:+--+-- > requestHeader "User-Agent"+requestHeader :: MonadCGI m => String -> m (Maybe String)+requestHeader name = getVar var+ where var = "HTTP_" ++ map toUpper (replace '-' '_' name)+++--+-- * Program and request URI+--++-- | Attempts to reconstruct the absolute URI of this program. +-- This does not include+-- any extra path information or query parameters. See+-- 'queryURI' for that.+-- If the server is rewriting request URIs, this URI can+-- be different from the one requested by the client.+-- See also 'requestURI'.+progURI :: MonadCGI m => m URI+progURI =+ do host <- serverName+ port <- serverPort+ name <- scriptName+ let scheme = if port == 443 then "https:" else "http:"+ auth = URIAuth { uriUserInfo = "",+ uriRegName = host,+ uriPort = if port == 80 || port == 443 + then "" else ":"++show port }+ return $ nullURI { uriScheme = scheme, + uriAuthority = Just auth,+ uriPath = name }++-- | Like 'progURI', but the returned 'URI' also includes+-- any extra path information, and any query parameters.+-- If the server is rewriting request URIs, this URI can+-- be different from the one requested by the client.+-- See also 'requestURI'.+queryURI :: MonadCGI m => m URI+queryURI = + do uri <- progURI+ path <- pathInfo+ qs <- liftM (\q -> if null q then q else '?':q) $ queryString+ return $ uri { uriPath = uriPath uri ++ path, uriQuery = qs } ++-- | Attempts to reconstruct the absolute URI requested by the client,+-- including extra path information and query parameters.+-- If no request URI rewriting is done, or if the web server does not+-- provide the information needed to reconstruct the request URI,+-- this function returns the same value as 'queryURI'.+requestURI :: MonadCGI m => m URI+requestURI =+ do uri <- queryURI+ -- Apache sets REQUEST_URI to the original request URI+ mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI"+ return $ case mreq of+ Nothing -> uri+ Just req -> uri { + uriPath = uriPath req,+ uriQuery = uriQuery req+ }+++--+-- * Inputs+--++-- | Get the value of an input variable, for example from a form.+-- If the variable has multiple values, the first one is returned.+-- Example:+--+-- > query <- getInput "query"+getInput :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> m (Maybe String) -- ^ The value of the variable,+ -- or Nothing, if it was not set.+getInput = liftM (fmap BS.unpack) . getInputFPS++-- | Like 'getInput', but returns a 'ByteString'.+getInputFPS :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> m (Maybe ByteString) -- ^ The value of the variable,+ -- or Nothing, if it was not set.+getInputFPS = liftM (fmap inputValue) . getInput_++-- | Get all the values of an input variable, for example from a form.+-- This can be used to get all the values from form controls+-- which allow multiple values to be selected.+-- Example:+--+-- > vals <- getMultiInput "my_checkboxes"+getMultiInput :: MonadCGI m => + String -- ^ The name of the variable.+ -> m [String] -- ^ The values of the variable,+ -- or the empty list if the variable was not set.+getMultiInput n = do is <- cgiGet cgiInputs+ return [BS.unpack (inputValue v) | (p,v) <- is, p == n]++-- | Get the file name of an input.+getInputFilename :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> m (Maybe String) -- ^ The file name corresponding to the+ -- input, if there is one.+getInputFilename = liftM (>>= inputFilename) . getInput_++-- | Get the content-type of an input, if the input exists, e.g. "image\/jpeg".+-- For non-file inputs, this function returns "text\/plain".+-- You can use 'parseContentType' to get a structured+-- representation of the the content-type value.+getInputContentType :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> m (Maybe String) -- ^ The content type, formatted as a string.+getInputContentType = + liftM (fmap (showContentType . inputContentType)) . getInput_++-- | Same as 'getInput', but tries to read the value to the desired type.+readInput :: (Read a, MonadCGI m) =>+ String -- ^ The name of the variable.+ -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist+ -- or if the value could not be interpreted+ -- at the desired type.+readInput = liftM (>>= maybeRead) . getInput++-- | Get the names and values of all inputs.+-- Note: the same name may occur more than once in the output,+-- if there are several values for the name.+getInputs :: MonadCGI m => m [(String,String)]+getInputs = do is <- cgiGet cgiInputs+ return [ (n, BS.unpack (inputValue i)) | (n,i) <- is ]++-- | Get the names of all input variables.+getInputNames :: MonadCGI m => m [String]+getInputNames = (sortNub . map fst) `liftM` cgiGet cgiInputs+ where sortNub = map head . group . sort++-- Internal stuff++getInput_ :: MonadCGI m => String -> m (Maybe Input)+getInput_ n = lookup n `liftM` cgiGet cgiInputs+++--+-- * Cookies+--++-- | Get the value of a cookie.+getCookie :: MonadCGI m =>+ String -- ^ The name of the cookie.+ -> m (Maybe String) -- ^ 'Nothing' if the cookie does not exist.+getCookie name = liftM (>>= findCookie name) (getVar "HTTP_COOKIE")++-- | Same as 'getCookie', but tries to read the value to the desired type.+readCookie :: (Read a, MonadCGI m) =>+ String -- ^ The name of the cookie.+ -> m (Maybe a) -- ^ 'Nothing' if the cookie does not exist+ -- or if the value could not be interpreted+ -- at the desired type.+readCookie = liftM (>>= maybeRead) . getCookie++-- | Set a cookie.+setCookie :: MonadCGI m => Cookie -> m ()+setCookie = setHeader "Set-cookie" . showCookie++-- | Delete a cookie from the client+deleteCookie :: MonadCGI m => Cookie -> m ()+deleteCookie = setCookie . Cookie.deleteCookie+++--+-- * Headers+--++-- | Add a response header. +-- Example:+--+-- > setHeader "Content-type" "text/plain"+setHeader :: MonadCGI m =>+ String -- ^ Header name.+ -> String -- ^ Header value.+ -> m ()+setHeader n v = cgiAddHeader (HeaderName n) v++-- | Set the HTTP response status.+setStatus :: MonadCGI m =>+ Int -- ^ HTTP status code, e.g. @404@+ -> String -- ^ HTTP status message, e.g. @"Not Found"@+ -> m ()+setStatus c m = setHeader "Status" (show c ++ " " ++ m)+
+ Network/CGI/Compat.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Compat+-- Copyright : (c) The University of Glasgow 2001+-- (c) Bjorn Bringert 2004-2006+-- (c) Ian Lynagh 2005+-- (c) Jeremy Shaw 2005+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (uses Control.Monad.State)+--+-- Compatibility functions for the old Network.CGI API.+--+-----------------------------------------------------------------------------++module Network.CGI.Compat (+ Html, wrapper, pwrapper, connectToCGIScript+ ) where++import Control.Concurrent (forkIO)+import Control.Exception as Exception (Exception,throw,catch,finally)+import Control.Monad (unless)+import Control.Monad.Trans (MonadIO, liftIO)+import qualified Data.Map as Map+import Network (PortID, Socket, listenOn, connectTo)+import Network.Socket as Socket (SockAddr(SockAddrInet), accept, socketToHandle)+import System.IO (Handle, hPutStrLn, stdin, stdout,+ hGetLine, hClose, IOMode(ReadWriteMode))+import System.IO.Error (isEOFError)++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++import Text.XHtml (Html, renderHtml)++import Network.CGI.Protocol+++{-# DEPRECATED wrapper, pwrapper, connectToCGIScript "Use the new interface." #-}++-- | Compatibility wrapper for the old CGI interface.+-- Output the output from a function from CGI environment and+-- input variables to an HTML document.+wrapper :: ([(String,String)] -> IO Html) -> IO ()+wrapper = run stdin stdout++-- | Compatibility wrapper for the old CGI interface.+-- Runs a simple CGI server.+-- Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main.+pwrapper :: PortID -- ^ The port to run the server on.+ -> ([(String,String)] -> IO Html)+ -> IO ()+pwrapper pid f = do sock <- listenOn pid+ acceptConnections fn sock+ where fn h = run h h f++acceptConnections :: (Handle -> IO ()) -> Socket -> IO ()+acceptConnections fn sock = do+ (h, SockAddrInet _ _) <- accept' sock+ forkIO (fn h `finally` (hClose h))+ acceptConnections fn sock++accept' :: Socket -- Listening Socket+ -> IO (Handle,SockAddr) -- StdIO Handle for read/write+accept' sock = do+ (sock', addr) <- Socket.accept sock+ handle <- socketToHandle sock' ReadWriteMode+ return (handle,addr)++run :: MonadIO m => Handle -> Handle -> ([(String,String)] -> IO Html) -> m ()+run inh outh f = + do env <- getCGIVars+ hRunCGI env inh outh f'+ where f' req = do let vs = Map.toList (cgiVars req) + is = [ (n,BS.unpack (inputValue i)) | (n,i) <- cgiInputs req ]+ html <- liftIO (f (vs++is))+ return ([], CGIOutput $ BS.pack $ renderHtml html)++-- | Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main.+connectToCGIScript :: String -> PortID -> IO ()+connectToCGIScript host portId+ = do env <- getCGIVars+ input <- BS.hGetContents stdin+ let str = getRequestInput env input+ h <- connectTo host portId+ `Exception.catch`+ (\ e -> abort "Cannot connect to CGI daemon." e)+ BS.hPut h str >> hPutStrLn h ""+ (sendBack h `finally` hClose h)+ `Prelude.catch` (\e -> unless (isEOFError e) (ioError e))++-- | Returns the query string, or the request body if it is+-- a POST request, or the empty string if there is an error.+getRequestInput :: [(String,String)] -- ^ CGI environment variables.+ -> ByteString -- ^ Request body.+ -> ByteString -- ^ Query string.+getRequestInput env req =+ case lookup "REQUEST_METHOD" env of+ Just "POST" -> takeInput env req+ _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env)++abort :: String -> Exception -> IO a+abort msg e =+ do putStrLn ("Content-type: text/html\n\n" +++ "<html><body>" ++ msg ++ "</body></html>")+ throw e++sendBack :: Handle -> IO ()+sendBack h = do s <- hGetLine h+ putStrLn s+ sendBack h
+ Network/CGI/Cookie.hs view
@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Cookie+-- Copyright : (c) Bjorn Bringert 2004-2005+-- (c) Ian Lynagh 2005+-- License : BSD-style+--+-- Maintainer : Bjorn Bringert <bjorn@bringert.net>+-- Stability : experimental+-- Portability : portable+--+-- General server side HTTP cookie library.+-- Based on <http://wp.netscape.com/newsref/std/cookie_spec.html>+--+-- TODO+--+-- * Add client side stuff (basically parsing Set-Cookie: value)+--+-- * Update for RFC2109 <http://www.ietf.org/rfc/rfc2109.txt>+--+-----------------------------------------------------------------------------+module Network.CGI.Cookie (+ Cookie(..)+ , newCookie+ , findCookie, deleteCookie+ , showCookie, readCookies+ ) where++import Data.Char (isSpace)+import Data.List (intersperse)+import Data.Maybe (catMaybes)+import System.Locale (defaultTimeLocale, rfc822DateFormat)+import System.Time (CalendarTime(..), Month(..), Day(..),+ formatCalendarTime)++--+-- * Types+--++-- | Contains all information about a cookie set by the server.+data Cookie = Cookie {+ -- | Name of the cookie.+ cookieName :: String,+ -- | Value of the cookie.+ cookieValue :: String,+ -- | Expiry date of the cookie. If 'Nothing', the+ -- cookie expires when the browser sessions ends.+ -- If the date is in the past, the client should+ -- delete the cookie immediately.+ cookieExpires :: Maybe CalendarTime,+ -- | The domain suffix to which this cookie will be sent.+ cookieDomain :: Maybe String,+ -- | The path to which this cookie will be sent.+ cookiePath :: Maybe String,+ -- | 'True' if this cookie should only be sent using+ -- secure means.+ cookieSecure :: Bool+ }+ deriving (Show, Read, Eq, Ord)++--+-- * Constructing cookies+--++-- | Construct a cookie with only name and value set.+-- This client will expire when the browser sessions ends,+-- will only be sent to the server and path which set it+-- and may be sent using any means.+newCookie :: String -- ^ Name+ -> String -- ^ Value+ -> Cookie -- ^ Cookie+newCookie name value = Cookie { cookieName = name,+ cookieValue = value,+ cookieExpires = Nothing,+ cookieDomain = Nothing,+ cookiePath = Nothing,+ cookieSecure = False+ }++--+-- * Getting and setting cookies+--++-- | Get the value of a cookie from a string on the form+-- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@.+-- This is the format of the @Cookie@ HTTP header.+findCookie :: String -- ^ Cookie name+ -> String -- ^ Semicolon separated list of name-value pairs+ -> Maybe String -- ^ Cookie value, if found+findCookie name s = maybeLast [ cv | (cn,cv) <- readCookies s, cn == name ]++-- | Delete a cookie from the client by setting the cookie expiry date+-- to a date in the past.+deleteCookie :: Cookie -- ^ Cookie to delete. The only fields that matter+ -- are 'cookieName', 'cookieDomain' and 'cookiePath'+ -> Cookie+deleteCookie c = c { cookieExpires = Just epoch }+ where+ epoch = CalendarTime {+ ctYear = 1970,+ ctMonth = January,+ ctDay = 1,+ ctHour = 0,+ ctMin = 0,+ ctSec = 0,+ ctPicosec = 0,+ ctWDay = Thursday,+ ctYDay = 1,+ ctTZName = "GMT",+ ctTZ = 0,+ ctIsDST = False+ }++--+-- * Reading and showing cookies+--++-- | Show a cookie on the format used as the value of the Set-Cookie header.+showCookie :: Cookie -> String+showCookie c = concat $ intersperse "; " $+ showPair (cookieName c) (cookieValue c)+ : catMaybes [expires, path, domain, secure]+ where expires = fmap (showPair "expires" . dateFmt) (cookieExpires c)+ domain = fmap (showPair "domain") (cookieDomain c)+ path = fmap (showPair "path") (cookiePath c)+ secure = if cookieSecure c then Just "secure" else Nothing+ dateFmt = formatCalendarTime defaultTimeLocale rfc822DateFormat++-- | Show a name-value pair. FIXME: if the name or value+-- contains semicolons, this breaks. The problem+-- is that the original cookie spec does not mention+-- how to do escaping or quoting. +showPair :: String -- ^ name+ -> String -- ^ value+ -> String+showPair name value = name ++ "=" ++ value+++-- | Gets all the cookies from a Cookie: header value+readCookies :: String -- ^ String to parse+ -> [(String,String)] -- ^ Cookie name - cookie value pairs+readCookies s = + let (xs,ys) = break (=='=') (dropWhile isSpace s)+ (zs,ws) = break (==';') (dropWhile isSpace (drop 1 ys))+ in if null xs then [] else (xs,zs):readCookies (drop 1 ws)++--+-- Utilities+--++-- | Return 'Nothing' is the list is empty, otherwise return+-- the last element of the list.+maybeLast :: [a] -> Maybe a+maybeLast [] = Nothing+maybeLast xs = Just (last xs)
+ Network/CGI/Monad.hs view
@@ -0,0 +1,119 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Monad+-- Copyright : (c) Bjorn Bringert 2006+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable+--+-- Internal stuff that most people shouldn't have to use.+-- This module mostly deals with the +-- internals of the CGIT monad transformer.+--+-----------------------------------------------------------------------------++module Network.CGI.Monad (+ -- * CGI monad class+ MonadCGI(..), + -- * CGI monad transformer+ CGIT(..), CGI,+ runCGIT,+ -- * Request info+ CGIRequest(..),+ -- * Error handling+ throwCGI, catchCGI, tryCGI, handleExceptionCGI,+ ) where++import Control.Exception as Exception (Exception, try, throwIO)+import Control.Monad (liftM)+import Control.Monad.Error (MonadError(..))+import Control.Monad.Reader (ReaderT(..), asks)+import Control.Monad.Writer (WriterT(..), tell)+import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift)+import Data.Monoid (mempty)+import Data.Typeable (Typeable(..), Typeable1(..), + mkTyConApp, mkTyCon)++import Network.CGI.Protocol+++--+-- * CGIT monad transformer+--++-- | A simple CGI monad with just IO.+type CGI a = CGIT IO a++-- | The CGIT monad transformer.+newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a }++instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where+ typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT") + [typeOf1 (undefined :: m a), typeOf (undefined :: a)]++instance Monad m => Functor (CGIT m) where+ fmap f c = CGIT (fmap f (unCGIT c))++instance Monad m => Monad (CGIT m) where+ c >>= f = CGIT (unCGIT c >>= unCGIT . f)+ return = CGIT . return+ -- FIXME: should we have an error monad instead?+ fail = CGIT . fail++instance MonadIO m => MonadIO (CGIT m) where+ liftIO = lift . liftIO++-- | The class of CGI monads. Most CGI actions can be run in+-- any monad which is an instance of this class, which means that+-- you can use your own monad transformers to add extra functionality.+class Monad m => MonadCGI m where+ -- | Add a response header.+ cgiAddHeader :: HeaderName -> String -> m ()+ -- | Get something from the CGI request.+ cgiGet :: (CGIRequest -> a) -> m a++instance Monad m => MonadCGI (CGIT m) where+ cgiAddHeader n v = CGIT $ lift $ tell [(n,v)]+ cgiGet = CGIT . asks++instance MonadTrans CGIT where+ lift = CGIT . lift . lift++-- | Run a CGI action.+runCGIT :: Monad m => CGIT m a -> CGIRequest -> m (Headers, a)+runCGIT (CGIT c) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c++++--+-- * Error handling+--++instance MonadError Exception (CGIT IO) where+ throwError = throwCGI+ catchError = catchCGI++-- | Throw an exception in a CGI monad. The monad is required to be+-- a 'MonadIO', so that we can use 'throwIO' to guarantee ordering.+throwCGI :: (MonadCGI m, MonadIO m) => Exception -> m a+throwCGI = liftIO . throwIO++-- | Catches any expection thrown by a CGI action, and uses the given +-- exception handler if an exception is thrown.+catchCGI :: CGI a -> (Exception -> CGI a) -> CGI a+catchCGI c h = tryCGI c >>= either h return++-- | Catches any exception thrown by an CGI action, and returns either+-- the exception, or if no exception was raised, the result of the action.+tryCGI :: CGI a -> CGI (Either Exception a)+tryCGI (CGIT c) = CGIT (ReaderT (\r -> WriterT (f (runWriterT (runReaderT c r)))))+ where+ f = liftM (either (\ex -> (Left ex,mempty)) (\(a,w) -> (Right a,w))) . try++{-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-}+-- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead.+handleExceptionCGI :: CGI a -> (Exception -> CGI a) -> CGI a+handleExceptionCGI = catchCGI
+ Network/CGI/Multipart.hs view
@@ -0,0 +1,211 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Multipart+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable+--+-- Parsing of the multipart format from RFC2046.+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module Network.CGI.Multipart + (+ -- * Multi-part messages+ MultiPart(..), BodyPart(..), Header+ , parseMultipartBody, hGetMultipartBody+ -- * Headers+ , ContentType(..), ContentTransferEncoding(..)+ , ContentDisposition(..)+ , parseContentType+ , parseContentTransferEncoding+ , parseContentDisposition+ , getContentType+ , getContentTransferEncoding+ , getContentDisposition+ ) where++import Control.Monad+import Data.Int (Int64)+import Data.Maybe+import System.IO (Handle)++import Network.CGI.RFC822Headers++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++--+-- * Multi-part stuff.+--++data MultiPart = MultiPart [BodyPart]+ deriving (Show, Read, Eq, Ord)++data BodyPart = BodyPart [Header] ByteString+ deriving (Show, Read, Eq, Ord)++-- | Read a multi-part message from a 'ByteString'.+parseMultipartBody :: String -- ^ Boundary+ -> ByteString -> Maybe MultiPart+parseMultipartBody b s = + do+ ps <- splitParts (BS.pack b) s+ liftM MultiPart $ mapM parseBodyPart ps++-- | Read a multi-part message from a 'Handle'.+-- Fails on parse errors.+hGetMultipartBody :: String -- ^ Boundary+ -> Handle+ -> IO MultiPart+hGetMultipartBody b h = + do+ s <- BS.hGetContents h+ case parseMultipartBody b s of+ Nothing -> fail "Error parsing multi-part message"+ Just m -> return m++++parseBodyPart :: ByteString -> Maybe BodyPart+parseBodyPart s =+ do+ (hdr,bdy) <- splitAtEmptyLine s+ hs <- parseM pHeaders "<input>" (BS.unpack hdr)+ return $ BodyPart hs bdy++--+-- * Splitting into multipart parts.+--++-- | Split a multipart message into the multipart parts.+splitParts :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Maybe [ByteString]+splitParts b s = dropPreamble b s >>= spl+ where+ spl x = case splitAtBoundary b x of+ Nothing -> Nothing+ Just (s1,d,s2) | isClose b d -> Just [s1]+ | otherwise -> spl s2 >>= Just . (s1:)++-- | Drop everything up to and including the first line starting +-- with the boundary. Returns 'Nothing' if there is no +-- line starting with a boundary.+dropPreamble :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Maybe ByteString+dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s)+ | otherwise = dropLine s >>= dropPreamble b++-- | Split a string at the first boundary line.+splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString -- ^ String to split.+ -> Maybe (ByteString,ByteString,ByteString)+ -- ^ The part before the boundary, the boundary line,+ -- and the part after the boundary line. The CRLF+ -- before and the CRLF (if any) after the boundary line+ -- are not included in any of the strings returned.+ -- Returns 'Nothing' if there is no boundary.+splitAtBoundary b s = spl 0+ where+ spl i = case findCRLF (BS.drop i s) of+ Nothing -> Nothing+ Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)+ | otherwise -> spl (i+j+l)+ where + s1 = BS.take (i+j) s+ s2 = BS.drop (i+j+l) s+ (d,s3) = splitAtCRLF_ s2++-- | Check whether a string starts with two dashes followed by+-- the given boundary string.+isBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString+ -> Bool+isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s++-- | Check whether a string for which 'isBoundary' returns true+-- has two dashes after the boudary string.+isClose :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Bool+isClose b s = startsWithDashes (BS.drop (2+BS.length b) s)++-- | Checks whether a string starts with two dashes.+startsWithDashes :: ByteString -> Bool+startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s+++--+-- * RFC 2046 CRLF+--++-- | Drop everything up to and including the first CRLF.+dropLine :: ByteString -> Maybe ByteString+dropLine s = fmap snd (splitAtCRLF s)++-- | Split a string at the first empty line. The CRLF (if any) before the+-- empty line is included in the first result. The CRLF after the+-- empty line is not included in the result.+-- 'Nothing' is returned if there is no empty line.+splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)+splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s)+ | otherwise = spl 0+ where+ spl i = case findCRLF (BS.drop i s) of+ Nothing -> Nothing+ Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2)+ | otherwise -> spl (i+j+l)+ where (s1,s2) = BS.splitAt (i+j+l) s++-- | Split a string at the first CRLF. The CRLF is not included+-- in any of the returned strings.+splitAtCRLF :: ByteString -- ^ String to split.+ -> Maybe (ByteString,ByteString)+ -- ^ Returns 'Nothing' if there is no CRLF.+splitAtCRLF s = case findCRLF s of+ Nothing -> Nothing+ Just (i,l) -> Just (s1, BS.drop l s2)+ where (s1,s2) = BS.splitAt i s++-- | Like 'splitAtCRLF', but if no CRLF is found, the first+-- result is the argument string, and the second result is empty.+splitAtCRLF_ :: ByteString -> (ByteString,ByteString)+splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s)++-- | Get the index and length of the first CRLF, if any.+findCRLF :: ByteString -- ^ String to split.+ -> Maybe (Int64,Int64)+findCRLF s = + case findCRorLF s of+ Nothing -> Nothing+ Just j | j == BS.length s - 1 -> Just (j,1)+ Just j -> case (BS.index s j, BS.index s (j+1)) of+ ('\n','\r') -> Just (j,2)+ ('\r','\n') -> Just (j,2)+ _ -> Just (j,1)++findCRorLF :: ByteString -> Maybe Int64+findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s++startsWithCRLF :: ByteString -> Bool+startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')+ where c = BS.index s 0++-- | Drop an initial CRLF, if any. If the string is empty, +-- nothing is done. If the string does not start with CRLF,+-- the first character is dropped.+dropCRLF :: ByteString -> ByteString+dropCRLF s | BS.length s <= 1 = BS.drop 1 s+ | c0 == '\n' && c1 == '\r' = BS.drop 2 s+ | c0 == '\r' && c1 == '\n' = BS.drop 2 s+ | otherwise = BS.drop 1 s+ where c0 = BS.index s 0+ c1 = BS.index s 1
+ Network/CGI/Protocol.hs view
@@ -0,0 +1,316 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Protocol+-- Copyright : (c) Bjorn Bringert 2006+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable+--+-- An implementation of the program side of the CGI protocol.+--+-----------------------------------------------------------------------------++module Network.CGI.Protocol (+ -- * CGI request+ CGIRequest(..), Input(..), + -- * CGI response+ CGIResult(..),+ Headers, HeaderName(..),+ -- * Running CGI actions+ hRunCGI, runCGIEnvFPS,+ -- * Inputs+ decodeInput, takeInput,+ -- * Environment variables+ getCGIVars,+ -- * Logging+ logCGI,+ -- * URL encoding+ formEncode, urlEncode, formDecode, urlDecode,+ -- * Utilities+ maybeRead, replace+ ) where++import Control.Monad.Trans (MonadIO(..))+import Data.Char (toLower)+import Data.List (intersperse)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe, listToMaybe, isJust)+import Network.URI (unEscapeString,escapeURIString,isUnescapedInURI)+import System.Environment (getEnvironment)+import System.IO (Handle, hPutStrLn, stderr, hFlush)++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon)++import Network.CGI.Multipart++++--+-- * CGI request+--++-- | The input to a CGI action.+data CGIRequest = + CGIRequest {+ -- | Environment variables.+ cgiVars :: Map String String,+ -- | Input parameters. For better laziness in reading inputs,+ -- this is not a Map.+ cgiInputs :: [(String, Input)],+ -- | Raw request body. + cgiRequestBody :: ByteString+ }+ deriving (Show)++instance Typeable CGIResult where+ typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") []++-- | The value of an input parameter, and some metadata.+data Input = Input {+ inputValue :: ByteString,+ inputFilename :: Maybe String,+ inputContentType :: ContentType+ }+ deriving Show++--+-- * CGI response+--++-- | The result of a CGI program.+data CGIResult = CGIOutput ByteString+ | CGINothing+ deriving (Show, Read, Eq, Ord)++type Headers = [(HeaderName, String)]++-- | A string with case insensitive equality and comparisons.+newtype HeaderName = HeaderName String deriving (Show)++instance Eq HeaderName where+ HeaderName x == HeaderName y = map toLower x == map toLower y++instance Ord HeaderName where+ HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y++++--+-- * Running CGI actions+--++-- | Runs a CGI action in a given environment. Uses Handles for input and output. +hRunCGI :: MonadIO m =>+ [(String,String)] -- ^ CGI environment variables, e.g. from 'getCGIVars'.+ -> Handle -- ^ Handle that input will be read from, e.g. 'stdin'.+ -> Handle -- ^ Handle that output will be written to, e.g. 'stdout'.+ -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action+ -> m ()+hRunCGI env hin hout f = + do inp <- liftIO $ BS.hGetContents hin+ outp <- runCGIEnvFPS env inp f+ liftIO $ BS.hPut hout outp+ liftIO $ hFlush hout++-- | Runs a CGI action in a given environment. Uses lazy ByteStrings +-- for input and output.+runCGIEnvFPS :: Monad m =>+ [(String,String)] -- ^ CGI environment variables.+ -> ByteString -- ^ Request body.+ -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action.+ -> m ByteString -- ^ Response (headers and content).+runCGIEnvFPS vars inp f+ = do (hs,outp) <- f $ CGIRequest {+ cgiVars = Map.fromList vars,+ cgiInputs = decodeInput vars inp,+ cgiRequestBody = inp+ }+ return $ case outp of+ CGIOutput c -> formatResponse c hs'+ where hs' = if isJust (lookup ct hs)+ then hs else hs ++ [(ct,defaultContentType)]+ ct = HeaderName "Content-type"+ CGINothing -> formatResponse BS.empty hs++formatResponse :: ByteString -> Headers -> ByteString+formatResponse c hs = + BS.unlines ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs] + ++ [BS.empty,c])++defaultContentType :: String+defaultContentType = "text/html; charset=ISO-8859-1"+++--+-- * Inputs+--+++-- | Gets and decodes the input according to the request+-- method and the content-type.+decodeInput :: [(String,String)] -- ^ CGI environment variables.+ -> ByteString -- ^ Request body.+ -> [(String,Input)] -- ^ Input variables and values.+decodeInput env inp = queryInput env ++ bodyInput env inp++-- | Builds an 'Input' object for a simple value.+simpleInput :: String -> Input+simpleInput v = Input { inputValue = BS.pack v,+ inputFilename = Nothing,+ inputContentType = defaultInputType }++-- | The default content-type for variables.+defaultInputType :: ContentType+defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?++--+-- * Environment variables+--++-- | Gets the values of all CGI variables from the program environment.+getCGIVars :: MonadIO m => m [(String,String)]+getCGIVars = liftIO getEnvironment++--+-- * Logging+--++-- | Logs some message using the server\'s logging facility.+-- FIXME: does this have to be more general to support+-- FastCGI etc? Maybe we should store log messages in the+-- CGIState?+logCGI :: MonadIO m => String -> m ()+logCGI s = liftIO (hPutStrLn stderr s)++--+-- * Query string+--++-- | Gets inputs from the query string.+queryInput :: [(String,String)] -- ^ CGI environment variables.+ -> [(String,Input)] -- ^ Input variables and values.+queryInput env = formInput $ lookupOrNil "QUERY_STRING" env++-- | Decodes application\/x-www-form-urlencoded inputs.+formInput :: String+ -> [(String,Input)] -- ^ Input variables and values.+formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs]++--+-- * URL encoding+--++-- | Formats name-value pairs as application\/x-www-form-urlencoded.+formEncode :: [(String,String)] -> String+formEncode xs = + concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs]++-- | Converts a single value to the application\/x-www-form-urlencoded encoding.+urlEncode :: String -> String+urlEncode = replace ' ' '+' . escapeURIString okChar+ where okChar c = c == ' ' || + (isUnescapedInURI c && c `notElem` "&=+")++-- | Gets the name-value pairs from application\/x-www-form-urlencoded data.+formDecode :: String -> [(String,String)]+formDecode "" = []+formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)+ where (nv,rs) = break (=='&') s+ (n,v) = break (=='=') nv++-- | Converts a single value from the +-- application\/x-www-form-urlencoded encoding.+urlDecode :: String -> String+urlDecode = unEscapeString . replace '+' ' '++--+-- * Request content and form-data stuff+--++-- | Gets input variables from the body, if any.+bodyInput :: [(String,String)] -- ^ CGI environment variables.+ -> ByteString -- ^ Request body.+ -> [(String,Input)] -- ^ Input variables and values.+bodyInput env inp =+ case lookup "REQUEST_METHOD" env of+ Just "POST" -> + let ctype = lookup "CONTENT_TYPE" env >>= parseContentType+ in decodeBody ctype $ takeInput env inp+ _ -> []++-- | Decodes a POST body.+decodeBody :: Maybe ContentType -- ^ Content-type, if any+ -> ByteString -- ^ Request body+ -> [(String,Input)] -- ^ Input variables and values.+decodeBody ctype inp = + case ctype of+ Just (ContentType "application" "x-www-form-urlencoded" _) + -> formInput (BS.unpack inp)+ Just (ContentType "multipart" "form-data" ps) + -> multipartDecode ps inp+ Just _ -> [] -- unknown content-type, the user will have to+ -- deal with it by looking at the raw content+ -- No content-type given, assume x-www-form-urlencoded+ Nothing -> formInput (BS.unpack inp)++-- | Takes the right number of bytes from the input.+takeInput :: [(String,String)] -- ^ CGI environment variables.+ -> ByteString -- ^ Request body.+ -> ByteString -- ^ CONTENT_LENGTH bytes from the request + -- body, or the empty string if there is no+ -- CONTENT_LENGTH.+takeInput env req = + case len of+ Just l -> BS.take l req+ Nothing -> BS.empty+ where len = lookup "CONTENT_LENGTH" env >>= maybeRead++-- | Decodes multipart\/form-data input.+multipartDecode :: [(String,String)] -- ^ Content-type parameters+ -> ByteString -- ^ Request body+ -> [(String,Input)] -- ^ Input variables and values.+multipartDecode ps inp =+ case lookup "boundary" ps of+ Just b -> case parseMultipartBody b inp of+ Just (MultiPart bs) -> map bodyPartToInput bs+ Nothing -> [] -- FIXME: report parse error+ Nothing -> [] -- FIXME: report that there was no boundary++bodyPartToInput :: BodyPart -> (String,Input)+bodyPartToInput (BodyPart hs b) = + case getContentDisposition hs of+ Just (ContentDisposition "form-data" ps) -> + (lookupOrNil "name" ps,+ Input { inputValue = b,+ inputFilename = lookup "filename" ps,+ inputContentType = ctype })+ _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error+ where ctype = fromMaybe defaultInputType (getContentType hs)+++--+-- * Utilities+--++-- | Replaces all instances of a value in a list by another value.+replace :: Eq a =>+ a -- ^ Value to look for+ -> a -- ^ Value to replace it with+ -> [a] -- ^ Input list+ -> [a] -- ^ Output list+replace x y = map (\z -> if z == x then y else z)++maybeRead :: Read a => String -> Maybe a+maybeRead = fmap fst . listToMaybe . reads++-- | Same as 'lookup' specialized to strings, but +-- returns the empty string if lookup fails.+lookupOrNil :: String -> [(String,String)] -> String+lookupOrNil n = fromMaybe "" . lookup n+
+ Network/CGI/RFC822Headers.hs view
@@ -0,0 +1,264 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.RFC822Headers+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- License : BSD-style+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable+--+-- Parsing of RFC822-style headers (name, value pairs)+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module Network.CGI.RFC822Headers (+ -- * Headers+ Header, + pHeader,+ pHeaders,+ parseHeaders,++ -- * Content-type+ ContentType(..), + getContentType,+ parseContentType,+ showContentType,++ -- * Content-transfer-encoding+ ContentTransferEncoding(..),+ getContentTransferEncoding,+ parseContentTransferEncoding,++ -- * Content-disposition+ ContentDisposition(..),+ getContentDisposition, + parseContentDisposition,+ + -- * Utilities+ parseM) where++import Data.Char+import Data.List+import Text.ParserCombinators.Parsec++type Header = (String, String)++pHeaders :: Parser [Header]+pHeaders = many pHeader++parseHeaders :: Monad m => SourceName -> String -> m [Header]+parseHeaders s inp = parseM pHeaders s inp++pHeader :: Parser Header+pHeader = + do name <- many1 headerNameChar+ char ':'+ many ws1+ line <- lineString+ crLf+ extraLines <- many extraFieldLine+ return (map toLower name, concat (line:extraLines))++extraFieldLine :: Parser String+extraFieldLine = + do sp <- ws1+ line <- lineString+ crLf+ return (sp:line)++--+-- * Parameters (for Content-type etc.)+--++showParameters :: [(String,String)] -> String+showParameters = concatMap f+ where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""+ esc '\\' = "\\\\"+ esc '"' = "\\\""+ esc c | c `elem` ['\\','"'] = '\\':[c]+ | otherwise = [c]++p_parameter :: Parser (String,String)+p_parameter =+ do lexeme $ char ';'+ p_name <- lexeme $ p_token+ lexeme $ char '='+ -- Workaround for seemingly standardized web browser bug+ -- where nothing is escaped in the filename parameter+ -- of the content-disposition header in multipart/form-data+ let litStr = if p_name == "filename" + then buggyLiteralString+ else literalString+ p_value <- litStr <|> p_token+ return (map toLower p_name, p_value)+++-- +-- * Content type+--++-- | A MIME media type value.+-- The 'Show' instance is derived automatically.+-- Use 'showContentType' to obtain the standard+-- string representation.+-- See <http://www.ietf.org/rfc/rfc2046.txt> for more+-- information about MIME media types.+data ContentType = + ContentType {+ -- | The top-level media type, the general type+ -- of the data. Common examples are+ -- \"text\", \"image\", \"audio\", \"video\",+ -- \"multipart\", and \"application\".+ ctType :: String,+ -- | The media subtype, the specific data format.+ -- Examples include \"plain\", \"html\",+ -- \"jpeg\", \"form-data\", etc.+ ctSubtype :: String,+ -- | Media type parameters. On common example is+ -- the charset parameter for the \"text\" + -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.+ ctParamaters :: [(String, String)]+ }+ deriving (Show, Read, Eq, Ord)++-- | Produce the standard string representation of a content-type,+-- e.g. \"text\/html; charset=ISO-8859-1\".+showContentType :: ContentType -> String+showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps++pContentType :: Parser ContentType+pContentType = + do many ws1+ c_type <- p_token+ lexeme $ char '/'+ c_subtype <- lexeme $ p_token+ c_parameters <- many p_parameter+ return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters++-- | Parse the standard representation of a content-type.+-- If the input cannot be parsed, this function calls+-- 'fail' with a (hopefully) informative error message.+parseContentType :: Monad m => String -> m ContentType+parseContentType = parseM pContentType "Content-type"++getContentType :: Monad m => [Header] -> m ContentType+getContentType hs = lookupM "content-type" hs >>= parseContentType++--+-- * Content transfer encoding+--++data ContentTransferEncoding =+ ContentTransferEncoding String+ deriving (Show, Read, Eq, Ord)++pContentTransferEncoding :: Parser ContentTransferEncoding+pContentTransferEncoding =+ do many ws1+ c_cte <- p_token+ return $ ContentTransferEncoding (map toLower c_cte)++parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding+parseContentTransferEncoding = + parseM pContentTransferEncoding "Content-transfer-encoding"++getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding+getContentTransferEncoding hs = + lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding++--+-- * Content disposition+--++data ContentDisposition =+ ContentDisposition String [(String, String)]+ deriving (Show, Read, Eq, Ord)++pContentDisposition :: Parser ContentDisposition+pContentDisposition =+ do many ws1+ c_cd <- p_token+ c_parameters <- many p_parameter+ return $ ContentDisposition (map toLower c_cd) c_parameters++parseContentDisposition :: Monad m => String -> m ContentDisposition+parseContentDisposition = parseM pContentDisposition "Content-disposition"++getContentDisposition :: Monad m => [Header] -> m ContentDisposition+getContentDisposition hs = + lookupM "content-disposition" hs >>= parseContentDisposition++--+-- * Utilities+--++parseM :: Monad m => Parser a -> SourceName -> String -> m a+parseM p n inp =+ case parse p n inp of+ Left e -> fail (show e)+ Right x -> return x++lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b+lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n++-- +-- * Parsing utilities+--++-- | RFC 822 LWSP-char+ws1 :: Parser Char+ws1 = oneOf " \t"++lexeme :: Parser a -> Parser a+lexeme p = do x <- p; many ws1; return x++-- | RFC 822 CRLF (but more permissive)+crLf :: Parser String+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"++-- | One line+lineString :: Parser String+lineString = many (noneOf "\n\r")++literalString :: Parser String+literalString = do char '\"'+ str <- many (noneOf "\"\\" <|> quoted_pair)+ char '\"'+ return str++-- No web browsers seem to implement RFC 2046 correctly,+-- since they do not escape double quotes and backslashes+-- in the filename parameter in multipart/form-data.+--+-- Note that this eats everything until the last double quote on the line.+buggyLiteralString :: Parser String+buggyLiteralString = + do char '\"'+ str <- manyTill anyChar (try lastQuote)+ return str+ where lastQuote = do char '\"' + notFollowedBy (try (many (noneOf "\"") >> char '\"'))++headerNameChar :: Parser Char+headerNameChar = noneOf "\n\r:"++especials, tokenchar :: [Char]+especials = "()<>@,;:\\\"/[]?.="+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials++p_token :: Parser String+p_token = many1 (oneOf tokenchar)++text_chars :: [Char]+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])++p_text :: Parser Char+p_text = oneOf text_chars++quoted_pair :: Parser Char+quoted_pair = do char '\\'+ p_text
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple (defaultMainWithHooks, defaultUserHooks)++main :: IO ()+main = defaultMainWithHooks defaultUserHooks
+ cgi.cabal view
@@ -0,0 +1,36 @@+Name: cgi+Version: 3000.0.0+Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, + Sven Panne, Jeremy Shaw+Maintainer: bjorn@bringert.net+Author: Bjorn Bringert+License: BSD3+License-file: LICENSE+Build-depends: base >= 2.0, network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0+Extensions: MultiParamTypeClasses+Synopsis: A library for writing CGI programs+Description:+ This is a Haskell library for writing CGI programs. +Exposed-Modules: + Network.CGI,+ Network.CGI.Monad,+ Network.CGI.Protocol,+ Network.CGI.Compat,+ Network.CGI.Cookie+Other-modules:+ Network.CGI.Multipart,+ Network.CGI.RFC822Headers+ghc-options: -O2 -Wall++--Executable: printinput+--Main-Is: printinput.hs+--Hs-Source-Dir: examples++--Executable: redirect+--Main-Is: redirect.hs+--Hs-Source-Dir: examples++--Executable: upload+--Main-Is: upload.hs+--Hs-Source-Dir: examples+