cgi 3001.1.8.5 → 3001.5.2.0
raw patch · 24 files changed
Files
- CHANGELOG.md +128/−0
- LICENSE +6/−6
- Network/CGI.hs +0/−645
- Network/CGI/Accept.hs +0/−174
- Network/CGI/Compat.hs +0/−118
- Network/CGI/Cookie.hs +0/−155
- Network/CGI/Header.hs +0/−309
- Network/CGI/Monad.hs +0/−128
- Network/CGI/Multipart.hs +0/−219
- Network/CGI/Protocol.hs +0/−314
- README.md +26/−0
- cgi.cabal +118/−60
- examples/cookie.hs +28/−0
- examples/error.hs +7/−0
- examples/hello.hs +7/−0
- examples/printinput.hs +62/−0
- examples/redirect.hs +11/−0
- examples/showAllInputs.hs +9/−0
- examples/upload.hs +40/−0
- src/Network/CGI.hs +650/−0
- src/Network/CGI/Accept.hs +170/−0
- src/Network/CGI/Cookie.hs +147/−0
- src/Network/CGI/Monad.hs +130/−0
- src/Network/CGI/Protocol.hs +318/−0
+ CHANGELOG.md view
@@ -0,0 +1,128 @@+# Change Log+All notable changes to this project will be documented in this file.+This project adheres to the [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy).++## [3001.5.2.0]+- Add support for containers 0.8.x.+- Add support for time 0.15 and 0.16.+- Depend on 'text' only when using xhtml >= 3000.3.+- Remove noncanonical definitions to appease the -Wnoncanonical-monad-instances+ warning. This warning exists because a future GHC release may treat+ noncanonical definitions as errors. See also:+ https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return++## [3001.5.1.0]+- Add support for GHC 9.12.x.+- Add support for xhtml 3000.5.x.+- Add support for containers 0.7.x.+- Add support for bytestring 0.12.x.+- Add support for mtl 2.3.x.++## [3001.5.0.1]+- Allow building against bytestring version 0.11.x.+- Update our Cabal file to "cabal-version: >= 1.10" so that we can legally use+ the other-extensions field.++## [3001.5.0.0]+- Define a proper `MonadFail` instance for `CGIT`. This is necessary to compile+ successfully with `ghc-8.8.x` Since that change affects our public API, a+ major version bump is necessary.+- The build no longer supports ghc prior to version 8.x.++## [3001.4.0.0]+- Drop obsolete Network.CGI.Compat module. The code in that module relied on+ obsolete functions and types from `network` which have been dropped there in+ the latest 3.x release. Re-writing the Compat module to use the new types+ felt like it would defeat the purpose of the module, so we've dropped it+ instead.+- Dropped the dependency on `network` altogether. We need `network-uri`,+ really. Giving up support for ancient versions of `network` allows us to drop+ the `network-uri` flag, too, simplifying our builds.+- Dropped support for versions of `mtl` prior to 2.2.x. That version was+ released almost 5 years ago, so we can probably drop the compatibility code+ (and the `old-mtl` Cabal flag) without surprising anyone.+- Added new `cookieHttpOnly` flag to the `Cookies` type. When set, the client's+ browser will prevent client side scripts from accessing the cookie.++## [3001.3.1.0]+### Changed+- Our error handling functions `throwCGI`, `catchCGI`, `tryCGI`, and+ `handleExceptionCGI` are deprecated. These functions are trivial aliases for+ the corresponding functions from the `exceptions` library's `MonadCatch`+ class. Users should directly use those functions. They are more general and+ have better documentation.+- Relax version constraints to allow building with network 2.8.x.++## [3001.3.0.3]+### Changed+- Bumped upper version bounds for containers and time.+- Updated to exceptions 0.10.x. This meant extending our `MonadMask` instance+ to provide the `generalBracket` method that was added to the class in recent+ versions of the exceptions library.+- The doctest suite would not work reliably with different versions of Cabal.+ Instead of going all out with a custom written build system to support it+ properly, we now run doctests as part of our CI builds but not as a part of+ the Cabal build any more.+- Fixed several compiler warnings in our code.++## [3001.3.0.2]+### Changed+- Bumped QuickCheck upper bound to version < 2.10++## [3001.3.0.1]+### Changed+- Bumped doctest to version < 0.12++## [3001.3.0.0]+### Changed+- Cookie.hs: cookieExpires now has type `Maybe UTCTime` rather than+`Maybe CalendarTime`+- Protocol.hs: URL decoding functions no longer decode UTF-8 encoding+- Functor and Applicative instance of CGIT no longer constrain Functor or+Applicative parameter to be an instance of Monad++## [3001.2.2.3]+### Changed+* CGI.hs haddock: Use web.archive.org link for CGI specification++## [3001.2.2.2]+### Changed+- Added support for building with mtl < 2.2.1 via flags++## [3001.2.2.1]+### Changed+- Bumped exceptions version to < 0.9++## [3001.2.2.0]+### Added+- MonadMask instance for CGIT++## [3001.2.1.0]+### Added+- Applicative instance for CGI Monad++### Changed+- Deduplicate shared with `multipart` code++## 3001.2.0.0+### Changed+- GHC 7.8.3 support++[Unreleased]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.3.0.2...HEAD+[3001.3.0.2]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.3.0.1...3001.3.0.2+[3001.3.0.1]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.3.0.0...3001.3.0.1+[3001.3.0.0]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.2.2.3...3001.3.0.0+[3001.2.2.3]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.2.2.2...3001.2.2.3+[3001.2.2.2]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.2.2.1...3001.2.2.2+[3001.2.2.1]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.2.2.0...3001.2.2.1+[3001.2.2.0]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.2.1.0...3001.2.2.0+[3001.2.1.0]:+https://github.com/cheecheeo/haskell-cgi/compare/3001.2.0.0...3001.2.1.0
LICENSE view
@@ -1,6 +1,6 @@-Copyright 2001-2010, The University Court of the University of-Glasgow, Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, Erik-Meijer, Sven Panne, Jeremy Shaw+Copyright 2001-2019, The University Court of the University of+Glasgow, Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg,+Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw, Peter Simons All rights reserved. @@ -9,14 +9,14 @@ - 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. +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,
− Network/CGI.hs
@@ -1,645 +0,0 @@-{-# 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 : Anders Kaseorg <andersk@mit.edu>--- 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- , getBody, getBodyFPS- , getInputs, getInputsFPS, getInputNames- , getMultiInput, getMultiInputFPS- , getInputFilename, getInputContentType- -- * Environment- , getVar, getVarWithDefault, getVars- -- * Request information- , serverName, serverPort- , requestMethod, pathInfo- , pathTranslated, scriptName- , queryString- , remoteHost, remoteAddr- , authType, remoteUser- , requestContentType, requestContentLength- , requestHeader- -- * Program and request URI- , progURI, queryURI, requestURI- -- * Content negotiation- , Acceptable, Accept- , Charset(..), ContentEncoding(..), Language(..)- , requestAccept, requestAcceptCharset, requestAcceptEncoding, requestAcceptLanguage- , negotiate- -- * 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--#if MIN_VERSION_base(4,0,0)-import Control.Exception-#else-import Control.Exception.Extensible-#endif- (Exception(..), SomeException, ErrorCall(..))-import Control.Monad (liftM)-import Control.Monad.CatchIO (MonadCatchIO)-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, - escapeURIString, isUnescapedInURI)-import System.IO (stdin, stdout)--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.Accept-import Network.CGI.Header-import Network.CGI.Monad-import Network.CGI.Protocol-import Network.CGI.Compat--import Text.XHtml (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 :: (MonadCGI m, MonadCatchIO m) => m CGIResult -> m CGIResult-handleErrors = flip catchCGI outputException------- * Error output------- | Output a 500 Internal Server Error with information from--- an 'Exception'.-outputException :: (MonadCGI m,MonadIO m) => SomeException -> m CGIResult-outputException e = outputInternalServerError es- where es = case fromException e of- Just (ErrorCall msg) -> [msg]- _ -> [show e]---- | 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- let textType = ContentType "text" "plain" [("charset","ISO-8859-1")]- htmlType = ContentType "text" "html" [("charset","ISO-8859-1")]- cts <- liftM (negotiate [htmlType,textType]) requestAccept- case cts of- ct:_ | ct == textType -> - do setHeader "Content-type" (showContentType textType)- text <- errorText c m es- output text- _ -> do setHeader "Content-type" (showContentType htmlType)- 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)--errorText :: MonadCGI m => - Int -- ^ Status code- -> String -- ^ Status message- -> [String] -- ^ Error information- -> m String-errorText c m es = return $ unlines $ (show c ++ " " ++ m) : es------- * 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------- * Request information------- | 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 @\'\/\'@.------ Note that this function returns an unencoded string.--- Make sure to percent-encode any characters--- that are not allowed in URI paths before using the result of--- this function to construct a URI.--- See 'progURI', 'queryURI' and 'requestURI' for a higher-level--- interface.-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 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 URIs. ------ Note that this function returns an unencoded string.--- Make sure to percent-encode any characters--- that are not allowed in URI paths before using the result of--- this function to construct a URI.--- See 'progURI', 'queryURI' and 'requestURI' for a higher-level--- interface.-scriptName :: MonadCGI m => m String-scriptName = getVarWithDefault "SCRIPT_NAME" ""---- | The information which follows the ? in the URL which referenced --- this program. This is the percent-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)------- * Content negotiation-----requestHeaderValue :: (MonadCGI m, HeaderValue a) => String -> m (Maybe a)-requestHeaderValue h = liftM (>>= parseM parseHeaderValue h) $ requestHeader h--requestAccept :: MonadCGI m => m (Maybe (Accept ContentType))-requestAccept = requestHeaderValue "Accept"--requestAcceptCharset :: MonadCGI m => m (Maybe (Accept Charset))-requestAcceptCharset = requestHeaderValue "Accept-Charset"--requestAcceptEncoding :: MonadCGI m => m (Maybe (Accept ContentEncoding))-requestAcceptEncoding = requestHeaderValue "Accept-Encoding"--requestAcceptLanguage :: MonadCGI m => m (Maybe (Accept Language))-requestAcceptLanguage = requestHeaderValue "Accept-Language"------- * 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'.------ Characters in the components of the returned URI are escaped --- when needed, as required by "Network.URI".-progURI :: MonadCGI m => m URI-progURI =- do -- Use HTTP_HOST if available, otherwise SERVER_NAME- h <- requestHeader "Host" >>= maybe serverName return- p <- serverPort- name <- scriptName- https <- liftM (maybe False (const True)) (getVar "HTTPS")- -- SERVER_PORT might not be the port that the client used- -- if the server listens on multiple ports, so we give priority- -- to the port in HTTP_HOST.- -- HTTP_HOST should include the port according to RFC2616 sec 14.23- -- Some servers (e.g. lighttpd) also seem to include the port in - -- SERVER_NAME. - -- We include the port if it is in HTTP_HOST or SERVER_NAME, or if- -- it is a non-standard port.- let (host,port) = case break (==':') h of- (_,"") -> (h, if (not https && p == 80) - || (https && p == 443) - then "" else ':':show p)- (h',p') -> (h',p')- let auth = URIAuth { uriUserInfo = "", - uriRegName = host,- uriPort = port }- return $ nullURI { uriScheme = if https then "https:" else "http:", - uriAuthority = Just auth,- uriPath = escapePath 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'.------ Characters in the components of the returned URI are escaped --- when needed, as required by "Network.URI".-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 ++ escapePath path, - uriQuery = qs } ---- | Does percent-encoding as needed for URI path components.-escapePath :: String -> String-escapePath = escapeURIString isUnescapedInURIPath- where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#"---- | 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'.------ Characters in the components of the returned URI are escaped --- when needed, as required by "Network.URI".-requestURI :: MonadCGI m => m URI-requestURI =- do uri <- queryURI- -- Apache sets REQUEST_URI to the original request URI,- -- with percent-encoding intact.- 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 = liftM (map BS.unpack) . getMultiInputFPS---- | Same as 'getMultiInput' but using 'ByteString's.-getMultiInputFPS :: MonadCGI m => - String -- ^ The name of the variable.- -> m [ByteString] -- ^ The values of the variable,- -- or the empty list if the variable was not set.-getMultiInputFPS n = do is <- cgiGet cgiInputs- return [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 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.-getInputsFPS :: MonadCGI m => m [(String,ByteString)]-getInputsFPS = do is <- cgiGet cgiInputs- return [ (n, 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---- | Get the uninterpreted request body as a String-getBody :: MonadCGI m => m String-getBody = BS.unpack `liftM` cgiGet cgiRequestBody---- | Get the uninterpreted request body as lazy ByteString-getBodyFPS :: MonadCGI m => m ByteString-getBodyFPS = cgiGet cgiRequestBody------- * 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/Accept.hs
@@ -1,174 +0,0 @@-module Network.CGI.Accept (- -- * Accept-X headers- Acceptable- , Accept- , Charset(..), ContentEncoding(..), Language(..)- -- * Content negotiation- , negotiate- ) where--import Data.Function-import Data.List-import Data.Maybe-import Numeric--import Text.ParserCombinators.Parsec--import Network.CGI.Header----- --- * Accept-X headers-----newtype Accept a = Accept [(a, Quality)]- deriving (Show)--type Quality = Double---- A bounded join-semilattice-class Eq a => Acceptable a where- includes :: a -> a -> Bool- top :: a--instance HeaderValue a => HeaderValue (Accept a) where- parseHeaderValue = fmap Accept $ sepBy p (lexeme (char ','))- where p = do a <- parseHeaderValue- q <- option 1 $ do _ <- lexeme $ char ';'- _ <- lexeme $ char 'q'- _ <- lexeme $ char '='- lexeme pQuality- return (a,q)- pQuality = (char '0' >> option "0" (char '.' >> many digit) >>= \ds -> return (read ("0." ++ ds ++ "0")))- <|> (char '1' >> optional (char '.' >> many (char '0')) >> return 1)- prettyHeaderValue (Accept xs) = concat $ intersperse ", " [prettyHeaderValue a ++ "; q=" ++ showQuality q | (a,q) <- xs]- where showQuality q = showFFloat (Just 3) q ""--starOrEqualTo :: String -> String -> Bool-starOrEqualTo x y = x == "*" || x == y---negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a]-negotiate ys Nothing = ys-negotiate ys (Just xs) = reverse [ z | (q,z) <- sortBy (compare `on` fst) [ (quality xs y,y) | y <- ys], q > 0]----testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a]---testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "<source>") ts] (parseM parseHeaderValue "<source>" a)--quality :: Acceptable a => Accept a -> a -> Quality-quality (Accept xs) y = fromMaybe 0 $ listToMaybe $ sort $ map snd $ sortBy (compareSpecificity `on` fst) $ filter ((`includes` y) . fst) xs--compareSpecificity :: Acceptable a => a -> a -> Ordering-compareSpecificity x y - | x `includes` y && y `includes` x = EQ- | x `includes` y = GT- | y `includes` x = LT- | otherwise = error "Non-comparable Acceptables"------- ** Accept-----instance Acceptable ContentType where- includes x y = ctType x `starOrEqualTo` ctType y- && ctSubtype x `starOrEqualTo` ctSubtype y- && all (hasParameter y) (ctParameters x)- top = ContentType "*" "*" []--hasParameter :: ContentType -> (String, String) -> Bool-hasParameter t (k,v) = maybe False (==v) $ lookup k (ctParameters t)------- ** Accept-Charset-----{--RFC 2616 14.2:--The special value "*", if present in the Accept-Charset field, matches-every character set (including ISO-8859-1) which is not mentioned-elsewhere in the Accept-Charset field. If no "*" is present in an-Accept-Charset field, then all character sets not explicitly mentioned-get a quality value of 0, except for ISO-8859-1, which gets a quality-value of 1 if not explicitly mentioned.--If no Accept-Charset header is present, the default is that any-character set is acceptable. If an Accept-Charset header is present,-and if the server cannot send a response which is acceptable according-to the Accept-Charset header, then the server SHOULD send an error-response with the 406 (not acceptable) status code, though the sending-of an unacceptable response is also allowed.--}--newtype Charset = Charset String- deriving (Show)--instance Eq Charset where- Charset x == Charset y = caseInsensitiveEq x y--instance Ord Charset where- Charset x `compare` Charset y = caseInsensitiveCompare x y--instance HeaderValue Charset where- parseHeaderValue = fmap Charset $ many ws1 >> lexeme p_token- prettyHeaderValue (Charset s) = s--instance Acceptable Charset where- Charset x `includes` Charset y = starOrEqualTo x y- top = Charset "*"------- ** Accept-Encoding-----{--RFC 2616, section 14.3--}--newtype ContentEncoding = ContentEncoding String- deriving (Show)--instance Eq ContentEncoding where- ContentEncoding x == ContentEncoding y = caseInsensitiveEq x y--instance Ord ContentEncoding where- ContentEncoding x `compare` ContentEncoding y = caseInsensitiveCompare x y--instance HeaderValue ContentEncoding where- parseHeaderValue = fmap ContentEncoding $ many ws1 >> lexeme p_token- prettyHeaderValue (ContentEncoding s) = s--instance Acceptable ContentEncoding where- ContentEncoding x `includes` ContentEncoding y = starOrEqualTo x y- top = ContentEncoding "*"------- ** Accept-Language-----newtype Language = Language String- deriving (Show)--instance Eq Language where- Language x == Language y = caseInsensitiveEq x y--instance Ord Language where- Language x `compare` Language y = caseInsensitiveCompare x y--instance HeaderValue Language where- parseHeaderValue = fmap Language $ many ws1 >> lexeme p_token- prettyHeaderValue (Language s) = s--{--RFC 2616 14.4--A language-range matches a language-tag if it exactly equals the tag,-or if it exactly equals a prefix of the tag such that the first tag-character following the prefix is "-". The special range "*", if-present in the Accept-Language field, matches every tag not matched by-any other range present in the Accept-Language field.--}-instance Acceptable Language where- Language x `includes` Language y =- x == "*" || x == y || (x `isPrefixOf` y && "-" `isPrefixOf` drop (length x) y)- top = Language "*"
− Network/CGI/Compat.hs
@@ -1,118 +0,0 @@--------------------------------------------------------------------------------- |--- 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 : Anders Kaseorg <andersk@mit.edu>--- 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)-#if MIN_VERSION_base(4,0,0)-import Control.Exception-#else-import Control.Exception.Extensible-#endif- as Exception (SomeException, 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)- `Exception.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 -> SomeException -> 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
@@ -1,155 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Network.CGI.Cookie--- Copyright : (c) Bjorn Bringert 2004-2005--- (c) Ian Lynagh 2005--- License : BSD-style------ Maintainer : Anders Kaseorg <andersk@mit.edu>--- 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/Header.hs
@@ -1,309 +0,0 @@--- #hide---------------------------------------------------------------------------------- |--- Module : Network.CGI.Header--- Copyright : (c) Peter Thiemann 2001,2002--- (c) Bjorn Bringert 2005-2006--- License : BSD-style------ Maintainer : Anders Kaseorg <andersk@mit.edu>--- Stability : experimental--- Portability : non-portable------ Parsing of HTTP headers (name, value pairs)--- Partly based on code from WASHMail.----------------------------------------------------------------------------------module Network.CGI.Header (- -- * Headers- Headers,- HeaderName(..),- HeaderValue(..),- pHeaders,-- -- * Content-type- ContentType(..), - getContentType,- parseContentType,- showContentType,-- -- * Content-transfer-encoding- ContentTransferEncoding(..),- getContentTransferEncoding,-- -- * Content-disposition- ContentDisposition(..),- getContentDisposition, - - -- * Utilities- parseM,- caseInsensitiveEq,- caseInsensitiveCompare,- lexeme, ws1, p_token- ) where--import Control.Monad-import Data.Char-import Data.List-import Data.Monoid--import Text.ParserCombinators.Parsec------- * Headers------- | HTTP headers.-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---class HeaderValue a where- parseHeaderValue :: Parser a- prettyHeaderValue :: a -> String--pHeaders :: Parser Headers-pHeaders = many pHeader--pHeader :: Parser (HeaderName, String)-pHeader = - do name <- many1 headerNameChar- _ <- char ':'- _ <- many ws1- line <- lineString- _ <- crLf- extraLines <- many extraFieldLine- return (HeaderName name, concat (line:extraLines))--extraFieldLine :: Parser String-extraFieldLine = - do sp <- ws1- line <- lineString- _ <- crLf- return (sp:line)--getHeaderValue :: (Monad m, HeaderValue a) => String -> Headers -> m a-getHeaderValue h hs = lookupM (HeaderName h) hs >>= parseM parseHeaderValue h------- * 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 = try $- do _ <- lexeme $ char ';'- p_name <- lexeme $ p_token- -- Don't allow parameters named q. This is needed for parsing Accept-X - -- headers. From RFC 2616 14.1:- -- Note: Use of the "q" parameter name to separate media type- -- parameters from Accept extension parameters is due to historical- -- practice. Although this prevents any media type parameter named- -- "q" from being used with a media range, such an event is believed- -- to be unlikely given the lack of any "q" parameters in the IANA- -- media type registry and the rare usage of any media type- -- parameters in Accept. Future media types are discouraged from- -- registering any parameter named "q".- when (p_name == "q") pzero- _ <- 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\")@.- ctParameters :: [(String, String)]- }- deriving (Show, Read)--instance Eq ContentType where- x == y = ctType x `caseInsensitiveEq` ctType y - && ctSubtype x `caseInsensitiveEq` ctSubtype y - && ctParameters x == ctParameters y--instance Ord ContentType where- x `compare` y = mconcat [ctType x `caseInsensitiveCompare` ctType y,- ctSubtype x `caseInsensitiveCompare` ctSubtype y,- ctParameters x `compare` ctParameters y]--instance HeaderValue ContentType where- parseHeaderValue = - do _ <- many ws1- c_type <- p_token- _ <- char '/'- c_subtype <- lexeme $ p_token- c_parameters <- many p_parameter- return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters- prettyHeaderValue (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps----- | 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 parseHeaderValue "Content-type"--showContentType :: ContentType -> String-showContentType = prettyHeaderValue--getContentType :: Monad m => Headers -> m ContentType-getContentType = getHeaderValue "content-type"------- * Content transfer encoding-----data ContentTransferEncoding =- ContentTransferEncoding String- deriving (Show, Read, Eq, Ord)--instance HeaderValue ContentTransferEncoding where- parseHeaderValue = - do _ <- many ws1- c_cte <- p_token- return $ ContentTransferEncoding (map toLower c_cte)- prettyHeaderValue (ContentTransferEncoding s) = s--getContentTransferEncoding :: Monad m => Headers -> m ContentTransferEncoding-getContentTransferEncoding = getHeaderValue "content-transfer-encoding"------- * Content disposition-----data ContentDisposition =- ContentDisposition String [(String, String)]- deriving (Show, Read, Eq, Ord)--instance HeaderValue ContentDisposition where- parseHeaderValue = - do _ <- many ws1- c_cd <- p_token- c_parameters <- many p_parameter- return $ ContentDisposition (map toLower c_cd) c_parameters- prettyHeaderValue (ContentDisposition t hs) = - t ++ concat ["; " ++ n ++ "=" ++ quote v | (n,v) <- hs]- where quote x = "\"" ++ x ++ "\"" -- NOTE: silly, but de-facto standard--getContentDisposition :: Monad m => Headers -> m ContentDisposition-getContentDisposition = getHeaderValue "content-disposition"------- * 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--caseInsensitiveEq :: String -> String -> Bool-caseInsensitiveEq x y = map toLower x == map toLower y--caseInsensitiveCompare :: String -> String -> Ordering-caseInsensitiveCompare x y = map toLower x `compare` map toLower y---- --- * 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:"--tspecials, tokenchar :: [Char]-tspecials = "()<>@,;:\\\"/[]?="-tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ tspecials--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
− Network/CGI/Monad.hs
@@ -1,128 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : Network.CGI.Monad--- Copyright : (c) Bjorn Bringert 2006--- License : BSD-style------ Maintainer : Anders Kaseorg <andersk@mit.edu>--- 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 Prelude hiding (catch)-#if MIN_VERSION_base(4,0,0)-import Control.Exception-#else-import Control.Exception.Extensible-#endif- as Exception (SomeException, throwIO)-import Control.Monad (liftM)-import Control.Monad.CatchIO (MonadCatchIO, block, catch, try, unblock)-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.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 (Functor m, 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--instance MonadCatchIO m => MonadCatchIO (CGIT m) where- CGIT m `catch` h = CGIT $ m `catch` (unCGIT . h)- block (CGIT m) = CGIT (block m)- unblock (CGIT m) = CGIT (unblock m)---- | 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 MonadCatchIO m => MonadError SomeException (CGIT m) 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) => SomeException -> 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 :: (MonadCGI m, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a-catchCGI = catch---- | 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 :: (Functor m, MonadCGI m, MonadCatchIO m) => m a -> m (Either SomeException a)-tryCGI = try--{-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-}--- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead.-handleExceptionCGI :: (MonadCGI m, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a-handleExceptionCGI = catchCGI
− Network/CGI/Multipart.hs
@@ -1,219 +0,0 @@--- #hide---------------------------------------------------------------------------------- |--- Module : Network.CGI.Multipart--- Copyright : (c) Peter Thiemann 2001,2002--- (c) Bjorn Bringert 2005-2006--- License : BSD-style------ Maintainer : Anders Kaseorg <andersk@mit.edu>--- 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(..)- , parseMultipartBody, hGetMultipartBody- , showMultipartBody- -- * Headers- , ContentType(..), ContentTransferEncoding(..)- , ContentDisposition(..)- , parseContentType- , getContentType- , getContentTransferEncoding- , getContentDisposition- ) where--import Control.Monad-import Data.Int (Int64)-import Data.List (intersperse)-import Data.Maybe-import System.IO (Handle)--import Network.CGI.Header--import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)------- * Multi-part stuff.-----data MultiPart = MultiPart [BodyPart]- deriving (Show, Eq, Ord)--data BodyPart = BodyPart Headers ByteString- deriving (Show, Eq, Ord)---- | Read a multi-part message from a 'ByteString'.-parseMultipartBody :: String -- ^ Boundary- -> ByteString -> MultiPart-parseMultipartBody b = - MultiPart . mapMaybe parseBodyPart . splitParts (BS.pack b)---- | Read a multi-part message from a 'Handle'.--- Fails on parse errors.-hGetMultipartBody :: String -- ^ Boundary- -> Handle- -> IO MultiPart-hGetMultipartBody b = liftM (parseMultipartBody b) . BS.hGetContents----parseBodyPart :: ByteString -> Maybe BodyPart-parseBodyPart s =- do- let (hdr,bdy) = splitAtEmptyLine s- hs <- parseM pHeaders "<input>" (BS.unpack hdr)- return $ BodyPart hs bdy--showMultipartBody :: String -> MultiPart -> ByteString-showMultipartBody b (MultiPart bs) = - unlinesCRLF $ foldr (\x xs -> d:showBodyPart x:xs) [c,BS.empty] bs- where d = BS.pack ("--" ++ b)- c = BS.pack ("--" ++ b ++ "--") --showBodyPart :: BodyPart -> ByteString-showBodyPart (BodyPart hs c) = - unlinesCRLF $ [BS.pack (n++": "++v) | (HeaderName n,v) <- hs] ++ [BS.empty,c]-------- * Splitting into multipart parts.------- | Split a multipart message into the multipart parts.-splitParts :: ByteString -- ^ The boundary, without the initial dashes- -> ByteString - -> [ByteString]-splitParts b = spl . dropPreamble b- where- spl x = case splitAtBoundary b x of- Nothing -> []- Just (s1,d,s2) | isClose b d -> [s1]- | otherwise -> s1:spl s2---- | Drop everything up to and including the first line starting --- with the boundary.-dropPreamble :: ByteString -- ^ The boundary, without the initial dashes- -> ByteString - -> ByteString-dropPreamble b s | BS.null s = BS.empty- | isBoundary b s = dropLine s- | otherwise = dropPreamble b (dropLine s)---- | 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-----crlf :: ByteString-crlf = BS.pack "\r\n"--unlinesCRLF :: [ByteString] -> ByteString-unlinesCRLF = BS.concat . intersperse crlf---- | Drop everything up to and including the first CRLF.-dropLine :: ByteString -> ByteString-dropLine s = 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.--- If there is no empty line, the entire input is returned--- as the first result.-splitAtEmptyLine :: ByteString -> (ByteString, ByteString)-splitAtEmptyLine s | startsWithCRLF s = (BS.empty, dropCRLF s)- | otherwise = spl 0- where- spl i = case findCRLF (BS.drop i s) of- Nothing -> (s, BS.empty)- Just (j,l) | startsWithCRLF s2 -> (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.--- If there is no CRLF, the entire input is returned--- as the first string.-splitAtCRLF :: ByteString -- ^ String to split.- -> (ByteString,ByteString)-splitAtCRLF s = case findCRLF s of- Nothing -> (s,BS.empty)- Just (i,l) -> (s1, BS.drop l s2)- where (s1,s2) = BS.splitAt i 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 | BS.null (BS.drop (j+1) s) -> 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.null s = BS.empty- | BS.null (BS.drop 1 s) = BS.empty- | 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
@@ -1,314 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Network.CGI.Protocol--- Copyright : (c) Bjorn Bringert 2006--- License : BSD-style------ Maintainer : Anders Kaseorg <andersk@mit.edu>--- 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.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, hSetBinaryMode)--import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)--import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon)--import Network.CGI.Header-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. To avoid memory leaks,- -- this is the empty string if the request body has been- -- interpreted as inputs in- -- "application\/x-www-form-urlencoded" or- -- "multipart\/form-data" format.- 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)------- * 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. 'System.IO.stdin'.- -> Handle -- ^ Handle that output will be written to, e.g. 'System.IO.stdout'.- -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action- -> m ()-hRunCGI env hin hout f = - do liftIO $ hSetBinaryMode hin True- 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 let (inputs,body) = decodeInput vars inp- (hs,outp) <- f $ CGIRequest {- cgiVars = Map.fromList vars,- cgiInputs = inputs,- cgiRequestBody = body- }- 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 = - -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle- -- just LF if there are CRs in the content.- unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs] - ++ [BS.empty,c])- where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n")--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)],ByteString) - -- ^ A list of input variables and values, and the request body- -- if it was not interpreted.-decodeInput env inp =- let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body)---- | 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)]- -> ByteString- -> ([(String,Input)], ByteString)-bodyInput env inp =- case lookup "REQUEST_METHOD" env of- Just "POST" -> - let ctype = lookup "CONTENT_TYPE" env >>= parseContentType- in decodeBody ctype $ takeInput env inp- _ -> ([], inp)---- | Decodes a POST body.-decodeBody :: Maybe ContentType- -> ByteString- -> ([(String,Input)], ByteString)-decodeBody ctype inp = - case ctype of- Just (ContentType "application" "x-www-form-urlencoded" _) - -> (formInput (BS.unpack inp), BS.empty)- Just (ContentType "multipart" "form-data" ps) - -> (multipartDecode ps inp, BS.empty)- Just _ -> ([], inp) -- 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), BS.empty)---- | 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 -> let MultiPart bs = parseMultipartBody b inp- in map bodyPartToInput bs- 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-
+ README.md view
@@ -0,0 +1,26 @@+cgi+===++[](http://hackage.haskell.org/package/cgi)+[](http://stackage.org/lts/package/cgi)+[](http://stackage.org/nightly/package/cgi)+[](https://github.com/cheecheeo/haskell-cgi/actions/workflows/haskell-ci.yml)++This is a Haskell library for writing CGI programs.+Its features include:++- Access to CGI parameters (e.g. form input) from both+ GET and POST requests.+- Access to CGI environment variables.+- Ability to set arbitrary response headers.+- Support for HTTP cookies.+- An efficient implementation of multipart/form-data+ using Data.ByteString. This allows for efficient+ handling of file uploads.+- A CGI monad transformer.+- Basic exception handling and logging (these should be improved)+- Low-level run functions that allow using programs written with+ this package with protocols other than CGI, for example FastCGI.++On hackage: http://hackage.haskell.org/package/cgi+Source: https://github.com/cheecheeo/haskell-cgi
cgi.cabal view
@@ -1,67 +1,125 @@-Name: cgi-Version: 3001.1.8.5-Copyright: Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, - Erik Meijer, Sven Panne, Jeremy Shaw-Category: Network-Maintainer: Anders Kaseorg <andersk@mit.edu>-Author: Bjorn Bringert-Homepage: http://andersk.mit.edu/haskell/cgi/-License: BSD3-License-file: LICENSE-Synopsis: A library for writing CGI programs-Description:- This is a Haskell library for writing CGI programs. -Build-Type: Simple-Cabal-Version: >=1.2+name: cgi+version: 3001.5.2.0+synopsis: A library for writing CGI programs+description: This is a Haskell library for writing CGI programs.+license: BSD3+license-file: LICENSE+copyright: Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg,+ Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw, Peter Simons+author: Bjorn Bringert+maintainer: John Chee <cheecheeo@gmail.com>, Peter Simons <simons@cryp.to>+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4,+ GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.7,+ GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.4, GHC == 9.14.1+category: Network+homepage: https://github.com/cheecheeo/haskell-cgi+bug-reports: https://github.com/cheecheeo/haskell-cgi/issues+build-type: Simple+extra-source-files: README.md+ CHANGELOG.md+cabal-version: >= 1.10 -Flag split-base-Flag bytestring-in-base-Flag extensible-exceptions-in-base+source-repository head+ type: git+ location: https://github.com/cheecheeo/haskell-cgi.git -Library- Exposed-Modules:- Network.CGI,- Network.CGI.Monad,- Network.CGI.Protocol,- Network.CGI.Cookie,- Network.CGI.Compat- Other-modules:- Network.CGI.Accept,- Network.CGI.Multipart,- Network.CGI.Header- Extensions:- CPP,- MultiParamTypeClasses- ghc-options: -Wall+flag xhtml-library-needs-text+ description: xhtml 3000.3.x introduced a dependency on text+ manual: False - Build-depends:- network >= 2.0,- parsec >= 2.0,- mtl >= 1.0,- MonadCatchIO-mtl,- xhtml >= 3000.0.0- If flag(split-base)- Build-depends: base >= 3 && < 5, old-time, old-locale, containers- Else- Build-depends: base < 3- If flag(bytestring-in-base)- Build-depends: base >= 2 && < 3- Else- Build-depends: base < 2 || < 5, bytestring- If flag(extensible-exceptions-in-base)- Build-depends: base >= 4- Else- Build-depends: base < 4, extensible-exceptions+flag install-examples+ default: False+ description: compile (and install) the example programs ---Executable: printinput---Main-Is: printinput.hs---Hs-Source-Dir: examples+library+ exposed-modules: Network.CGI+ Network.CGI.Cookie+ Network.CGI.Monad+ Network.CGI.Protocol+ other-modules: Network.CGI.Accept+ hs-source-dirs: src+ build-depends: base >= 4.9 && < 5+ , bytestring < 0.13+ , containers < 0.9+ , exceptions == 0.10.*+ , mtl > 2.2.0.1 && < 2.4+ , multipart >= 0.1.2 && < 0.3+ , network-uri == 2.6.*+ , parsec >= 2.0 && < 3.2+ , time >= 1.5 && < 1.17+ if flag(xhtml-library-needs-text)+ build-depends: xhtml >= 3000.3 && < 3000.5, text+ else+ build-depends: xhtml >= 3000 && < 3000.3+ other-extensions: MultiParamTypeClasses+ default-language: Haskell2010 ---Executable: redirect---Main-Is: redirect.hs---Hs-Source-Dir: examples+executable cookie.cgi+ main-is: cookie.hs+ hs-source-dirs: examples+ default-language: Haskell2010 ---Executable: upload---Main-Is: upload.hs---Hs-Source-Dir: examples+ if flag(install-examples) && !flag(xhtml-library-needs-text)+ build-depends: base, cgi, xhtml+ else+ buildable: False +executable error.cgi+ main-is: error.hs+ hs-source-dirs: examples+ default-language: Haskell2010++ if flag(install-examples)+ build-depends: base, cgi+ else+ buildable: False++executable hello.cgi+ main-is: hello.hs+ hs-source-dirs: examples+ default-language: Haskell2010++ if flag(install-examples)+ build-depends: base, cgi+ else+ buildable: False++executable printinput.cgi+ main-is: printinput.hs+ hs-source-dirs: examples+ default-language: Haskell2010++ if flag(install-examples)+ build-depends: base, cgi+ else+ buildable: False++executable redirect.cgi+ main-is: redirect.hs+ hs-source-dirs: examples+ default-language: Haskell2010++ if flag(install-examples)+ build-depends: base, cgi+ else+ buildable: False++executable showAllInputs.cgi+ main-is: showAllInputs.hs+ hs-source-dirs: examples+ default-language: Haskell2010++ if flag(install-examples)+ build-depends: base, cgi+ else+ buildable: False++executable upload.cgi+ main-is: upload.hs+ hs-source-dirs: examples+ default-language: Haskell2010++ if flag(install-examples) && !flag(xhtml-library-needs-text)+ build-depends: base, bytestring, cgi+ else+ buildable: False
+ examples/cookie.hs view
@@ -0,0 +1,28 @@+import Network.CGI+ ( CGI, CGIResult, runCGI, output, setCookie, newCookie, getCookie+ )+import Text.XHtml+ ( Html, h1, p, header, body, (+++), thetitle, (<<), renderHtml+ )++setCounterCookie :: Int -> CGI ()+setCounterCookie n = setCookie (newCookie "mycookie" (show n))++firstTime :: CGI [Html]+firstTime = do setCounterCookie 1+ return [h1 << "Welcome!"]++returnVisitor :: Int -> CGI [Html]+returnVisitor c =+ do setCounterCookie (c + 1)+ return [h1 << "Welcome back!",+ p << ("I have seen you " ++ show c ++ " times before.")]++cgiMain :: CGI CGIResult+cgiMain = do mc <- getCookie "mycookie"+ h <- maybe firstTime (returnVisitor . read) mc+ output $ renderHtml $ header << thetitle << "Cookie example"+ +++ body << h++main :: IO ()+main = runCGI cgiMain
+ examples/error.hs view
@@ -0,0 +1,7 @@+import Network.CGI (CGI, CGIResult, runCGI, liftIO, output, handleErrors)++cgiMain :: CGI CGIResult+cgiMain = liftIO (readFile "foo") >> output "bar"++main :: IO ()+main = runCGI (handleErrors cgiMain)
+ examples/hello.hs view
@@ -0,0 +1,7 @@+import Network.CGI (CGI, CGIResult, output, runCGI, handleErrors)++cgiMain :: CGI CGIResult+cgiMain = output "Hello World!"++main :: IO ()+main = runCGI (handleErrors cgiMain)
+ examples/printinput.hs view
@@ -0,0 +1,62 @@+-- Prints the values of all CGI variables and inputs.++import Network.CGI+ ( CGI, CGIResult, runCGI, output, setHeader, getMultiInput+ , serverName, serverPort, getInputFilename, requestMethod, pathInfo+ , pathTranslated, scriptName, remoteHost, remoteAddr, remoteUser+ , queryString, authType, requestContentType, requestContentLength+ , requestHeader, progURI, queryURI, requestURI, getVars, getInputNames+ )++import Data.List (intercalate)+++prInput :: String -> CGI String+prInput i =+ do+ vs <- getMultiInput i+ let v = intercalate "," $ map show vs+ f <- getInputFilename i+ return $ case f of+ Just n -> i ++ ": File\nfilename=" ++ n+ ++ "\ncontents=" ++ v+ Nothing -> i ++ ": " ++ v++envFuns :: CGI [(String, String)]+envFuns = sequence+ [+ f "serverName" serverName,+ f "serverPort" (fmap show serverPort),+ f "requestMethod" requestMethod,+ f "pathInfo" pathInfo,+ f "pathTranslated" pathTranslated,+ f "scriptName" scriptName,+ f "queryString" queryString,+ f "remoteHost" remoteHost,+ f "remoteAddr" remoteAddr,+ f "authType" authType,+ f "remoteUser" remoteUser,+ f "requestContentType" requestContentType ,+ f "requestContentLength" requestContentLength,+ f "requestHeader \"User-Agent\"" (requestHeader "User-Agent"),+ f "progURI" progURI,+ f "queryURI" queryURI,+ f "requestURI" requestURI+ ]+ where f n = fmap ((,) n . show)++prVars :: [(String, String)] -> String+prVars vs = unlines [k ++ ": " ++ x | (k,x) <- vs ]++cgiMain :: CGI CGIResult+cgiMain = do fs <- envFuns+ vs <- getVars+ is <- getInputNames+ i <- mapM prInput is+ setHeader "Content-type" "text/plain"+ output ("Environment:\n" ++ prVars fs+ ++ "\nCGI Environment Variables:\n" ++ prVars vs+ ++ "\nInputs:\n" ++ unlines i)++main :: IO ()+main = runCGI cgiMain
+ examples/redirect.hs view
@@ -0,0 +1,11 @@+-- Redirect to the URL given by the url parameter.++import Network.CGI (MonadCGI, CGIResult, runCGI, getInput, output, redirect)++redirectToURL :: MonadCGI m => m CGIResult+redirectToURL =+ getInput "url" >>= maybe (output "url parameter not set!\n") redirect++main :: IO ()+main =+ runCGI redirectToURL
+ examples/showAllInputs.hs view
@@ -0,0 +1,9 @@+import Network.CGI (runCGI, getInputs, output)++main :: IO ()+main =+ runCGI $+ do allInputs <- getInputs+ output $ "Showing all inputs\n"+ ++ show allInputs+ ++ "\nDone.\n"
+ examples/upload.hs view
@@ -0,0 +1,40 @@+-- Accepts file uploads and saves the files in the given directory.+-- WARNING: this script is a SECURITY RISK and only for+-- demo purposes. Do not put it on a public web server.++import Data.Maybe (fromJust)++import qualified Data.ByteString.Lazy as BS (writeFile)+import Network.CGI+import Text.XHtml+ ( Html, paragraph, (!), href, (+++), form, method, enctype, afile, submit+ , renderHtml, header, thetitle, body, (<<), anchor+ )++dir :: String+dir = "../upload"++saveFile :: (MonadCGI m, MonadIO m) => String -> m Html+saveFile n =+ do cont <- fromJust <$> getInputFPS "file"+ let p = dir ++ "/" ++ basename n+ liftIO $ BS.writeFile p cont+ return $ paragraph << ("Saved as " +++ anchor ! [href p] << p +++ ".")++fileForm :: Html+fileForm = form ! [method "post", enctype "multipart/form-data"]+ << [afile "file", submit "" "Upload"]+++basename :: String -> String+basename = reverse . takeWhile (`notElem` "/\\") . reverse++cgiMain :: CGI CGIResult+cgiMain =+ do mn <- getInputFilename "file"+ h <- maybe (return fileForm) saveFile mn+ output $ renderHtml $ header << thetitle << "Upload example"+ +++ body << h++main :: IO ()+main = runCGI cgiMain
+ src/Network/CGI.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- 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 : John Chee <cheecheeo@gmail.com>+-- Stability : experimental+-- Portability : non-portable (uses Control.Monad.State)+--+-- Simple Library for writing CGI programs.+-- See <https://web.archive.org/web/20100109233524/http://hoohoo.ncsa.illinois.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+ , getBody, getBodyFPS+ , getInputs, getInputsFPS, getInputNames+ , getMultiInput, getMultiInputFPS+ , getInputFilename, getInputContentType+ -- * Environment+ , getVar, getVarWithDefault, getVars+ -- * Request information+ , serverName, serverPort+ , requestMethod, pathInfo+ , pathTranslated, scriptName+ , queryString+ , remoteHost, remoteAddr+ , authType, remoteUser+ , requestContentType, requestContentLength+ , requestHeader+ -- * Program and request URI+ , progURI, queryURI, requestURI+ -- * Content negotiation+ , Acceptable, Accept+ , Charset(..), ContentEncoding(..), Language(..)+ , requestAccept, requestAcceptCharset, requestAcceptEncoding, requestAcceptLanguage+ , negotiate+ -- * Content type+ , ContentType(..), showContentType, parseContentType+ -- * Cookies+ , Cookie(..), newCookie+ , getCookie, readCookie+ , setCookie, deleteCookie+ -- * URL encoding+ , formEncode, urlEncode, formDecode, urlDecode+ ) where++import Control.Exception (Exception(..), SomeException, ErrorCall(..))+import Control.Monad.Catch (MonadCatch(..), handle)+import Control.Monad.Trans (MonadIO, liftIO)+import Data.Char (toUpper)+import Data.List (intercalate, sort, group)+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Map as Map+import Network.Multipart+import Network.Multipart.Header+import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference,+ escapeURIString, isUnescapedInURI)+import System.IO (stdin, stdout)++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.Accept+import Network.CGI.Monad+import Network.CGI.Protocol++import Text.XHtml (Html, renderHtml, header, (<<), thetitle, (+++),+ body, h1, paragraph, hr, address)++#if MIN_VERSION_xhtml(3000,3,0)+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Encoding as LText+import Text.XHtml (Builder)++-- Taken from Text.XHtml.Internal+builderToString :: Builder -> String+builderToString = LText.unpack . LText.decodeUtf8 . toLazyByteString+#endif++-- | 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 :: (MonadCGI m, MonadCatch m, MonadIO m) => m CGIResult -> m CGIResult+handleErrors = handle outputException++--+-- * Error output+--++-- | Output a 500 Internal Server Error with information from+-- an 'Exception'.+outputException :: (MonadCGI m,MonadIO m) => SomeException -> m CGIResult+outputException e = outputInternalServerError es+ where es = case fromException e of+ Just (ErrorCall msg) -> [msg]+ _ -> [show e]++-- | 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+ let textType = ContentType "text" "plain" [("charset","ISO-8859-1")]+ htmlType = ContentType "text" "html" [("charset","ISO-8859-1")]+ cts <- fmap (negotiate [htmlType,textType]) requestAccept+ case cts of+ ct:_ | ct == textType ->+ do setHeader "Content-type" (showContentType textType)+ text <- errorText c m es+ output text+ _ -> do setHeader "Content-type" (showContentType htmlType)+ page <- errorPage c m es+#if MIN_VERSION_xhtml(3000,3,0)+ output $ builderToString $ renderHtml page+#else+ output $ renderHtml page+#endif++-- | 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)++errorText :: MonadCGI m =>+ Int -- ^ Status code+ -> String -- ^ Status message+ -> [String] -- ^ Error information+ -> m String+errorText c m es = return $ unlines $ (show c ++ " " ++ m) : es++--+-- * 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 = intercalate ", " 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 = outputError 500 "Internal Server Error"+++--+-- * 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 = Map.lookup name <$> cgiGet cgiVars++getVarWithDefault :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> String -- ^ Default value+ -> m String+getVarWithDefault name def = fromMaybe def <$> getVar name++-- | Get all CGI environment variables and their values.+getVars :: MonadCGI m =>+ m [(String,String)]+getVars = Map.toList <$> cgiGet cgiVars++--+-- * Request information+--++-- | 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 = fmap (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 @\'\/\'@.+--+-- Note that this function returns an unencoded string.+-- Make sure to percent-encode any characters+-- that are not allowed in URI paths before using the result of+-- this function to construct a URI.+-- See 'progURI', 'queryURI' and 'requestURI' for a higher-level+-- interface.+pathInfo :: MonadCGI m => m String+pathInfo = slash <$> getVarWithDefault "PATH_INFO" ""+ where slash s = if not (null s) && head s /= '/' then '/':s else s++-- | The path returned by 'pathInfo', but with 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 URIs.+--+-- Note that this function returns an unencoded string.+-- Make sure to percent-encode any characters+-- that are not allowed in URI paths before using the result of+-- this function to construct a URI.+-- See 'progURI', 'queryURI' and 'requestURI' for a higher-level+-- interface.+scriptName :: MonadCGI m => m String+scriptName = getVarWithDefault "SCRIPT_NAME" ""++-- | The information which follows the ? in the URL which referenced+-- this program. This is the percent-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 = (>>= 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)++--+-- * Content negotiation+--++requestHeaderValue :: (MonadCGI m, HeaderValue a) => String -> m (Maybe a)+requestHeaderValue h = (>>= parseM parseHeaderValue h) <$> requestHeader h++requestAccept :: MonadCGI m => m (Maybe (Accept ContentType))+requestAccept = requestHeaderValue "Accept"++requestAcceptCharset :: MonadCGI m => m (Maybe (Accept Charset))+requestAcceptCharset = requestHeaderValue "Accept-Charset"++requestAcceptEncoding :: MonadCGI m => m (Maybe (Accept ContentEncoding))+requestAcceptEncoding = requestHeaderValue "Accept-Encoding"++requestAcceptLanguage :: MonadCGI m => m (Maybe (Accept Language))+requestAcceptLanguage = requestHeaderValue "Accept-Language"++--+-- * 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'.+--+-- Characters in the components of the returned URI are escaped+-- when needed, as required by "Network.URI".+progURI :: MonadCGI m => m URI+progURI =+ do -- Use HTTP_HOST if available, otherwise SERVER_NAME+ h <- requestHeader "Host" >>= maybe serverName return+ p <- serverPort+ name <- scriptName+ https <- fmap isJust (getVar "HTTPS")+ -- SERVER_PORT might not be the port that the client used+ -- if the server listens on multiple ports, so we give priority+ -- to the port in HTTP_HOST.+ -- HTTP_HOST should include the port according to RFC2616 sec 14.23+ -- Some servers (e.g. lighttpd) also seem to include the port in+ -- SERVER_NAME.+ -- We include the port if it is in HTTP_HOST or SERVER_NAME, or if+ -- it is a non-standard port.+ let (host,port) = case break (==':') h of+ (_,"") -> (h, if (not https && p == 80)+ || (https && p == 443)+ then "" else ':':show p)+ (h',p') -> (h',p')+ let auth = URIAuth { uriUserInfo = "",+ uriRegName = host,+ uriPort = port }+ return $ nullURI { uriScheme = if https then "https:" else "http:",+ uriAuthority = Just auth,+ uriPath = escapePath 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'.+--+-- Characters in the components of the returned URI are escaped+-- when needed, as required by "Network.URI".+queryURI :: MonadCGI m => m URI+queryURI =+ do uri <- progURI+ path <- pathInfo+ qs <- fmap (\q -> if null q then q else '?':q) queryString+ return $ uri { uriPath = uriPath uri ++ escapePath path,+ uriQuery = qs }++-- | Does percent-encoding as needed for URI path components.+escapePath :: String -> String+escapePath = escapeURIString isUnescapedInURIPath+ where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#"++-- | 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'.+--+-- Characters in the components of the returned URI are escaped+-- when needed, as required by "Network.URI".+requestURI :: MonadCGI m => m URI+requestURI =+ do uri <- queryURI+ -- Apache sets REQUEST_URI to the original request URI,+ -- with percent-encoding intact.+ mreq <- (>>= 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 = fmap (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 = fmap (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 = fmap (map BS.unpack) . getMultiInputFPS++-- | Same as 'getMultiInput' but using 'ByteString's.+getMultiInputFPS :: MonadCGI m =>+ String -- ^ The name of the variable.+ -> m [ByteString] -- ^ The values of the variable,+ -- or the empty list if the variable was not set.+getMultiInputFPS n = do is <- cgiGet cgiInputs+ return [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 = fmap (>>= 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 =+ fmap (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 = fmap (>>= 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 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.+getInputsFPS :: MonadCGI m => m [(String,ByteString)]+getInputsFPS = do is <- cgiGet cgiInputs+ return [ (n, inputValue i) | (n,i) <- is ]++-- | Get the names of all input variables.+getInputNames :: MonadCGI m => m [String]+getInputNames = (sortNub . map fst) `fmap` cgiGet cgiInputs+ where sortNub = map head . group . sort++-- Internal stuff++getInput_ :: MonadCGI m => String -> m (Maybe Input)+getInput_ n = lookup n `fmap` cgiGet cgiInputs++-- | Get the uninterpreted request body as a String+getBody :: MonadCGI m => m String+getBody = BS.unpack `fmap` cgiGet cgiRequestBody++-- | Get the uninterpreted request body as lazy ByteString+getBodyFPS :: MonadCGI m => m ByteString+getBodyFPS = cgiGet cgiRequestBody++--+-- * 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 = fmap (>>= 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 = fmap (>>= 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 = cgiAddHeader (HeaderName n)++-- | 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)
+ src/Network/CGI/Accept.hs view
@@ -0,0 +1,170 @@+module Network.CGI.Accept (+ -- * Accept-X headers+ Acceptable+ , Accept+ , Charset(..), ContentEncoding(..), Language(..)+ -- * Content negotiation+ , negotiate+ ) where++import Data.Function+import Data.List+import Data.Maybe+import Numeric++import Text.ParserCombinators.Parsec++import Network.Multipart+import Network.Multipart.Header+++--+-- * Accept-X headers+--++newtype Accept a = Accept [(a, Quality)]+ deriving (Show)++type Quality = Double++-- A bounded join-semilattice+class Eq a => Acceptable a where+ includes :: a -> a -> Bool++instance HeaderValue a => HeaderValue (Accept a) where+ parseHeaderValue = Accept <$> sepBy p (lexeme (char ','))+ where p = do a <- parseHeaderValue+ q <- option 1 $ do _ <- lexeme $ char ';'+ _ <- lexeme $ char 'q'+ _ <- lexeme $ char '='+ lexeme pQuality+ return (a,q)+ pQuality = (char '0' >> option "0" (char '.' >> many digit) >>= \ds -> return (read ("0." ++ ds ++ "0")))+ <|> (char '1' >> optional (char '.' >> many (char '0')) >> return 1)+ prettyHeaderValue (Accept xs) = intercalate ", " [prettyHeaderValue a ++ "; q=" ++ showQuality q | (a,q) <- xs]+ where showQuality q = showFFloat (Just 3) q ""++starOrEqualTo :: String -> String -> Bool+starOrEqualTo x y = x == "*" || x == y+++negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a]+negotiate ys Nothing = ys+negotiate ys (Just xs) = reverse [ z | (q,z) <- sortBy (compare `on` fst) [ (quality xs y,y) | y <- ys], q > 0]++--testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a]+--testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "<source>") ts] (parseM parseHeaderValue "<source>" a)++quality :: Acceptable a => Accept a -> a -> Quality+quality (Accept xs) y = fromMaybe 0 $ listToMaybe $ sort $ map snd $ sortBy (compareSpecificity `on` fst) $ filter ((`includes` y) . fst) xs++compareSpecificity :: Acceptable a => a -> a -> Ordering+compareSpecificity x y+ | x `includes` y && y `includes` x = EQ+ | x `includes` y = GT+ | y `includes` x = LT+ | otherwise = error "Non-comparable Acceptables"++--+-- ** Accept+--++instance Acceptable ContentType where+ includes x y = ctType x `starOrEqualTo` ctType y+ && ctSubtype x `starOrEqualTo` ctSubtype y+ && all (hasParameter y) (ctParameters x)++hasParameter :: ContentType -> (String, String) -> Bool+hasParameter t (k,v) = (== Just v) $ lookup k (ctParameters t)++--+-- ** Accept-Charset+--++{-+RFC 2616 14.2:++The special value "*", if present in the Accept-Charset field, matches+every character set (including ISO-8859-1) which is not mentioned+elsewhere in the Accept-Charset field. If no "*" is present in an+Accept-Charset field, then all character sets not explicitly mentioned+get a quality value of 0, except for ISO-8859-1, which gets a quality+value of 1 if not explicitly mentioned.++If no Accept-Charset header is present, the default is that any+character set is acceptable. If an Accept-Charset header is present,+and if the server cannot send a response which is acceptable according+to the Accept-Charset header, then the server SHOULD send an error+response with the 406 (not acceptable) status code, though the sending+of an unacceptable response is also allowed.+-}++newtype Charset = Charset String+ deriving (Show)++instance Eq Charset where+ Charset x == Charset y = caseInsensitiveEq x y++instance Ord Charset where+ Charset x `compare` Charset y = caseInsensitiveCompare x y++instance HeaderValue Charset where+ parseHeaderValue = fmap Charset $ many ws1 >> lexeme p_token+ prettyHeaderValue (Charset s) = s++instance Acceptable Charset where+ Charset x `includes` Charset y = starOrEqualTo x y++--+-- ** Accept-Encoding+--++{-+RFC 2616, section 14.3+-}++newtype ContentEncoding = ContentEncoding String+ deriving (Show)++instance Eq ContentEncoding where+ ContentEncoding x == ContentEncoding y = caseInsensitiveEq x y++instance Ord ContentEncoding where+ ContentEncoding x `compare` ContentEncoding y = caseInsensitiveCompare x y++instance HeaderValue ContentEncoding where+ parseHeaderValue = fmap ContentEncoding $ many ws1 >> lexeme p_token+ prettyHeaderValue (ContentEncoding s) = s++instance Acceptable ContentEncoding where+ ContentEncoding x `includes` ContentEncoding y = starOrEqualTo x y++--+-- ** Accept-Language+--++newtype Language = Language String+ deriving (Show)++instance Eq Language where+ Language x == Language y = caseInsensitiveEq x y++instance Ord Language where+ Language x `compare` Language y = caseInsensitiveCompare x y++instance HeaderValue Language where+ parseHeaderValue = fmap Language $ many ws1 >> lexeme p_token+ prettyHeaderValue (Language s) = s++{-+RFC 2616 14.4++A language-range matches a language-tag if it exactly equals the tag,+or if it exactly equals a prefix of the tag such that the first tag+character following the prefix is "-". The special range "*", if+present in the Accept-Language field, matches every tag not matched by+any other range present in the Accept-Language field.+-}+instance Acceptable Language where+ Language x `includes` Language y =+ x == "*" || x == y || (x `isPrefixOf` y && "-" `isPrefixOf` drop (length x) y)
+ src/Network/CGI/Cookie.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Cookie+-- Copyright : (c) Bjorn Bringert 2004-2005+-- (c) Ian Lynagh 2005+-- License : BSD-style+--+-- Maintainer : John Chee <cheecheeo@gmail.com>+-- 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 (intercalate)+import Data.Maybe (catMaybes)+import Data.Time.Calendar (Day(..))+import Data.Time.Clock (UTCTime(..))+import Data.Time.Format (defaultTimeLocale, formatTime, rfc822DateFormat)++--+-- * 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 UTCTime,+ -- | 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,+ -- | 'True' to tell the client's browser to prevent+ -- client side scripts from accessing the cookie.+ cookieHttpOnly :: 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,+ cookieHttpOnly = 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 = UTCTime (ModifiedJulianDay 40587) 0++--+-- * Reading and showing cookies+--++-- | Show a cookie on the format used as the value of the Set-Cookie header.+showCookie :: Cookie -> String+showCookie c = intercalate "; " $+ showPair (cookieName c) (cookieValue c)+ : catMaybes [expires, path, domain, secure, httpOnly]+ 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+ httpOnly = if cookieHttpOnly c then Just "HttpOnly" else Nothing+ dateFmt = formatTime 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)
+ src/Network/CGI/Monad.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Monad+-- Copyright : (c) Bjorn Bringert 2006+-- License : BSD-style+--+-- Maintainer : John Chee <cheecheeo@gmail.com>+-- 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 Prelude hiding ( fail )++import Control.Exception as Exception (SomeException)+import Control.Applicative (Applicative(..))+import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, throwM, catch, try, mask, uninterruptibleMask, generalBracket)+import Control.Monad.Except (MonadError(..))+import Control.Monad.Reader (ReaderT(..), asks)+import Control.Monad.Writer (WriterT(..), tell)+import Control.Monad.Fail (MonadFail(..))+import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift)+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 (Functor m) => Functor (CGIT m) where+ fmap f c = CGIT (fmap f (unCGIT c))++instance (Applicative m) => Applicative (CGIT m) where+ pure = CGIT . pure+ f <*> x = CGIT (unCGIT f <*> unCGIT x)++instance Monad m => Monad (CGIT m) where+ c >>= f = CGIT (unCGIT c >>= unCGIT . f)++instance MonadFail m => MonadFail (CGIT m) where+ fail = CGIT . fail++instance MonadIO m => MonadIO (CGIT m) where+ liftIO = lift . liftIO++instance MonadThrow m => MonadThrow (CGIT m) where+ throwM = CGIT . throwM++instance MonadCatch m => MonadCatch (CGIT m) where+ CGIT m `catch` h = CGIT $ m `catch` (unCGIT . h)++instance MonadMask m => MonadMask (CGIT m) where+ mask a = CGIT $ mask $ \u -> unCGIT $ a $ CGIT . u . unCGIT+ uninterruptibleMask a = CGIT $ uninterruptibleMask $ \u -> unCGIT $ a $ CGIT . u . unCGIT+ generalBracket acquire release f = CGIT $+ generalBracket (unCGIT acquire) (\a b -> unCGIT (release a b)) (unCGIT . f)++instance MonadCatch m => MonadError SomeException (CGIT m) where+ throwError = throwM+ catchError = catch++-- | 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) = fmap (uncurry (flip (,))) . runWriterT . runReaderT c++++--+-- * Deprecated error handling functions.+--+++{-# DEPRECATED throwCGI "Use Control.Monad.Catch.throwM instead." #-}+-- | Deprecated alias for 'throwM'. Please use 'throwM' instead.+throwCGI :: (MonadThrow m) => SomeException -> m a+throwCGI = throwM++{-# DEPRECATED catchCGI "Use Control.Monad.Catch.catch instead." #-}+-- | Deprecated alias for 'catch'. Please use 'catch' instead.+catchCGI :: (MonadCatch m) => m a -> (SomeException -> m a) -> m a+catchCGI = catch++{-# DEPRECATED tryCGI "Use Control.Monad.Catch.try instead." #-}+-- | Deprecated alias for 'try'. Please use 'try' instead.+tryCGI :: (MonadCatch m) => m a -> m (Either SomeException a)+tryCGI = try++{-# DEPRECATED handleExceptionCGI "Use Control.Monad.Catch.catch instead." #-}+-- | Deprecated alias for 'catch'. Please use 'catch' instead.+handleExceptionCGI :: (MonadCatch m) => m a -> (SomeException -> m a) -> m a+handleExceptionCGI = catch
+ src/Network/CGI/Protocol.hs view
@@ -0,0 +1,318 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.Protocol+-- Copyright : (c) Bjorn Bringert 2006+-- License : BSD-style+--+-- Maintainer : John Chee <cheecheeo@gmail.com>+-- 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 (chr, isHexDigit, digitToInt)+import Data.List (intercalate)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe, listToMaybe, isJust)+import Network.URI (escapeURIString,isUnescapedInURI)+import System.Environment (getEnvironment)+import System.IO (Handle, hPutStrLn, stderr, hFlush, hSetBinaryMode)++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++import Network.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. To avoid memory leaks,+ -- this is the empty string if the request body has been+ -- interpreted as inputs in+ -- "application\/x-www-form-urlencoded" or+ -- "multipart\/form-data" format.+ cgiRequestBody :: ByteString+ }+ deriving (Show)++-- | 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)++--+-- * 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. 'System.IO.stdin'.+ -> Handle -- ^ Handle that output will be written to, e.g. 'System.IO.stdout'.+ -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action+ -> m ()+hRunCGI env hin hout f =+ do liftIO $ hSetBinaryMode hin True+ 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 let (inputs,body) = decodeInput vars inp+ (hs,outp) <- f $ CGIRequest {+ cgiVars = Map.fromList vars,+ cgiInputs = inputs,+ cgiRequestBody = body+ }+ 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 =+ -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle+ -- just LF if there are CRs in the content.+ unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs]+ ++ [BS.empty,c])+ where unlinesCrLf = BS.intercalate (BS.pack "\r\n")++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)],ByteString)+ -- ^ A list of input variables and values, and the request body+ -- if it was not interpreted.+decodeInput env inp =+ let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body)++-- | 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" [("charset","windows-1252")]++--+-- * 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 =+ intercalate "&" [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 '+' ' '++-- | Unescape a percent-encoded string, but doesn't decode UTF-8 encoding.+--+-- >>> unEscapeString "Hell%C3%B3 w%C3%B3rld"+-- "Hell\195\179 w\195\179rld"+unEscapeString :: String -> String+unEscapeString [] = ""+unEscapeString ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 =+ chr (digitToInt x1 * 16 + digitToInt x2) : unEscapeString s+unEscapeString (c:s) = c : unEscapeString s++--+-- * Request content and form-data stuff+--++-- | Gets input variables from the body, if any.+bodyInput :: [(String,String)]+ -> ByteString+ -> ([(String,Input)], ByteString)+bodyInput env inp =+ case lookup "REQUEST_METHOD" env of+ Just "POST" ->+ let ctype = lookup "CONTENT_TYPE" env >>= parseContentType+ in decodeBody ctype $ takeInput env inp+ _ -> ([], inp)++-- | Decodes a POST body.+decodeBody :: Maybe ContentType+ -> ByteString+ -> ([(String,Input)], ByteString)+decodeBody ctype inp =+ case ctype of+ Just (ContentType "application" "x-www-form-urlencoded" _)+ -> (formInput (BS.unpack inp), BS.empty)+ Just (ContentType "multipart" "form-data" ps)+ -> (multipartDecode ps inp, BS.empty)+ Just _ -> ([], inp) -- 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), BS.empty)++-- | 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 -> let MultiPart bs = parseMultipartBody b inp+ in map bodyPartToInput bs+ 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