diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ -Copyright 2001-2014, The University Court of the University of +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 +Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw, Peter Simons All rights reserved. diff --git a/Network/CGI.hs b/Network/CGI.hs deleted file mode 100644 --- a/Network/CGI.hs +++ /dev/null @@ -1,641 +0,0 @@ -{-# LANGUAGE OverlappingInstances #-} ------------------------------------------------------------------------------ --- | --- 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 --- Stability : experimental --- Portability : non-portable (uses Control.Monad.State) --- --- Simple Library for writing CGI programs. --- See 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 --- --- Based on the original Haskell binding for CGI: --- --- Original Version by Erik Meijer . --- Further hacked on by Sven Panne . --- Further hacking by Andy Gill . --- A new, hopefully more flexible, interface --- and support for file uploads by Bjorn Bringert . --- --- 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 - -import Control.Exception (Exception(..), SomeException, ErrorCall(..)) -import Control.Monad (liftM) -import Control.Monad.Catch (MonadCatch) -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.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 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, MonadCatch m, MonadIO 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) - diff --git a/Network/CGI/Accept.hs b/Network/CGI/Accept.hs deleted file mode 100644 --- a/Network/CGI/Accept.hs +++ /dev/null @@ -1,175 +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.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 - 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 "") ts] (parseM parseHeaderValue "" 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 "*" diff --git a/Network/CGI/Compat.hs b/Network/CGI/Compat.hs deleted file mode 100644 --- a/Network/CGI/Compat.hs +++ /dev/null @@ -1,113 +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 : John Chee --- Stability : experimental --- Portability : non-portable (uses Control.Monad.State) --- --- Compatibility functions for the old Network.CGI API. --- ------------------------------------------------------------------------------ - -module Network.CGI.Compat ( - Html, wrapper, pwrapper, connectToCGIScript - ) where - -import Control.Concurrent (forkIO) -import Control.Exception as Exception (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" ++ - "" ++ msg ++ "") - throw e - -sendBack :: Handle -> IO () -sendBack h = do s <- hGetLine h - putStrLn s - sendBack h diff --git a/Network/CGI/Cookie.hs b/Network/CGI/Cookie.hs deleted file mode 100644 --- a/Network/CGI/Cookie.hs +++ /dev/null @@ -1,155 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Cookie --- Copyright : (c) Bjorn Bringert 2004-2005 --- (c) Ian Lynagh 2005 --- License : BSD-style --- --- Maintainer : John Chee --- Stability : experimental --- Portability : portable --- --- General server side HTTP cookie library. --- Based on --- --- TODO --- --- * Add client side stuff (basically parsing Set-Cookie: value) --- --- * Update for RFC2109 --- ------------------------------------------------------------------------------ -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) diff --git a/Network/CGI/Monad.hs b/Network/CGI/Monad.hs deleted file mode 100644 --- a/Network/CGI/Monad.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -{-# LANGUAGE CPP, DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Monad --- Copyright : (c) Bjorn Bringert 2006 --- License : BSD-style --- --- Maintainer : John Chee --- 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) -import Control.Exception as Exception (SomeException) -import Control.Applicative (Applicative(..)) -import Control.Monad (liftM) -import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, throwM, catch, try, mask, uninterruptibleMask) -import Control.Monad.Except (MonadError(..)) -import Control.Monad.Reader (ReaderT(..), asks) -import Control.Monad.Writer (WriterT(..), tell) -import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift) -#if MIN_VERSION_base(4,7,0) -import Data.Typeable -#else -import Data.Typeable (Typeable(..), Typeable1(..), - mkTyConApp, mkTyCon) -#endif - -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 } -#if MIN_VERSION_base(4,7,0) - deriving (Typeable) - -#else -instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where - typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT") - [typeOf1 (undefined :: m a), typeOf (undefined :: a)] -#endif - -instance (Functor m, Monad m) => Functor (CGIT m) where - fmap f c = CGIT (fmap f (unCGIT c)) - -instance (Applicative m, Monad 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) - 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 MonadThrow m => MonadThrow (CGIT m) where - throwM e = CGIT . throwM $ e - -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 - --- | 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 MonadCatch m => MonadError SomeException (CGIT m) where - throwError = throwM - catchError = catch - --- | Throw an exception in a CGI monad. The monad is required to be --- a 'MonadThrow', so that we can use 'throwM' to guarantee ordering. -throwCGI :: (MonadCGI m, MonadThrow m) => SomeException -> m a -throwCGI = throwM - --- | Catches any expection thrown by a CGI action, and uses the given --- exception handler if an exception is thrown. -catchCGI :: (MonadCGI m, MonadCatch 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, MonadCatch m) => m a -> m (Either SomeException a) -tryCGI = try - -{-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-} --- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead. -handleExceptionCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a -handleExceptionCGI = catchCGI diff --git a/Network/CGI/Protocol.hs b/Network/CGI/Protocol.hs deleted file mode 100644 --- a/Network/CGI/Protocol.hs +++ /dev/null @@ -1,323 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Protocol --- Copyright : (c) Bjorn Bringert 2006 --- License : BSD-style --- --- Maintainer : John Chee --- Stability : experimental --- Portability : non-portable --- --- An implementation of the program side of the CGI protocol. --- ------------------------------------------------------------------------------ -{-# LANGUAGE CPP, DeriveDataTypeable #-} -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) - -#if MIN_VERSION_base(4,7,0) -import Data.Typeable -#else -import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon) -#endif - -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) - -#if ! MIN_VERSION_base(4,7,0) -instance Typeable CGIResult where - typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") [] -#endif - --- | 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 -#if MIN_VERSION_base(4,7,0) - deriving (Show, Read, Eq, Ord, Typeable) -#else - deriving (Show, Read, Eq, Ord) -#endif - --- --- * 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 - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +cgi +=== + +[![hackage release](https://img.shields.io/hackage/v/cgi.svg?label=hackage)](http://hackage.haskell.org/package/cgi) +[![stackage LTS package](http://stackage.org/package/cgi/badge/lts)](http://stackage.org/lts/package/cgi) +[![stackage Nightly package](http://stackage.org/package/cgi/badge/nightly)](http://stackage.org/nightly/package/cgi) +[![CI Status](https://github.com/cheecheeo/haskell-cgi/actions/workflows/haskell-ci.yml/badge.svg)](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 diff --git a/cgi.cabal b/cgi.cabal --- a/cgi.cabal +++ b/cgi.cabal @@ -1,77 +1,125 @@ -Name: cgi -Version: 3001.2.2.3 -Copyright: Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg, - Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw -Category: Network -Maintainer: John Chee -Author: Bjorn Bringert -Homepage: https://github.com/cheecheeo/haskell-cgi -bug-reports: https://github.com/cheecheeo/haskell-cgi/issues -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 -extra-source-files: changelog -Cabal-Version: >=1.6 +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 , Peter Simons +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 source-repository head - type: git - location: git://github.com/cheecheeo/haskell-cgi.git + type: git + location: https://github.com/cheecheeo/haskell-cgi.git -Flag network-uri - description: Get Network.URI from the network-uri package - default: True +flag xhtml-library-needs-text + description: xhtml 3000.3.x introduced a dependency on text + manual: False -Flag old-mtl - description: Use mtl-compat and mtl < 2.2.0.1 - default: False +flag install-examples + default: False + description: compile (and install) the example programs -Library - Exposed-Modules: - Network.CGI, - Network.CGI.Monad, - Network.CGI.Protocol, - Network.CGI.Cookie, - Network.CGI.Compat - Other-modules: - Network.CGI.Accept - Extensions: - CPP, - MultiParamTypeClasses - ghc-options: -Wall +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 - Build-depends: - parsec >= 2.0 && < 3.2, - exceptions < 0.9, - xhtml >= 3000.0.0 && < 3000.3, - bytestring < 0.11, - base >= 4.5 && < 5, - old-time < 1.2, - old-locale < 1.1, - containers < 0.6, - multipart >= 0.1.2 && < 0.2 - If flag(network-uri) - Build-depends: network-uri == 2.6.*, network == 2.6.* - Else - Build-depends: network < 2.6 - If flag(old-mtl) - Build-depends: - mtl>=2.1.3.1 && < 2.3, mtl-compat >= 0.2.1.1 && < 0.3 - Else - Build-depends: - mtl>=2.2.1 && < 2.3 +executable cookie.cgi + main-is: cookie.hs + hs-source-dirs: examples + default-language: Haskell2010 ---Executable: printinput ---Main-Is: printinput.hs ---Hs-Source-Dir: examples + if flag(install-examples) && !flag(xhtml-library-needs-text) + build-depends: base, cgi, xhtml + else + buildable: False ---Executable: redirect ---Main-Is: redirect.hs ---Hs-Source-Dir: examples +executable error.cgi + main-is: error.hs + hs-source-dirs: examples + default-language: Haskell2010 ---Executable: upload ---Main-Is: upload.hs ---Hs-Source-Dir: examples + 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 diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,27 +0,0 @@ -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 - -* MonadMask instance for CGIT - -3001.2.1.0 - -* Applicative instance for CGI Monad -* Deduplicate shared with `multipart` code - -3001.2.0.0 - -* GHC 7.8.3 support diff --git a/examples/cookie.hs b/examples/cookie.hs new file mode 100644 --- /dev/null +++ b/examples/cookie.hs @@ -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 diff --git a/examples/error.hs b/examples/error.hs new file mode 100644 --- /dev/null +++ b/examples/error.hs @@ -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) diff --git a/examples/hello.hs b/examples/hello.hs new file mode 100644 --- /dev/null +++ b/examples/hello.hs @@ -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) diff --git a/examples/printinput.hs b/examples/printinput.hs new file mode 100644 --- /dev/null +++ b/examples/printinput.hs @@ -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 diff --git a/examples/redirect.hs b/examples/redirect.hs new file mode 100644 --- /dev/null +++ b/examples/redirect.hs @@ -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 diff --git a/examples/showAllInputs.hs b/examples/showAllInputs.hs new file mode 100644 --- /dev/null +++ b/examples/showAllInputs.hs @@ -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" diff --git a/examples/upload.hs b/examples/upload.hs new file mode 100644 --- /dev/null +++ b/examples/upload.hs @@ -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 diff --git a/src/Network/CGI.hs b/src/Network/CGI.hs new file mode 100644 --- /dev/null +++ b/src/Network/CGI.hs @@ -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 +-- Stability : experimental +-- Portability : non-portable (uses Control.Monad.State) +-- +-- Simple Library for writing CGI programs. +-- See 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 +-- +-- Based on the original Haskell binding for CGI: +-- +-- Original Version by Erik Meijer . +-- Further hacked on by Sven Panne . +-- Further hacking by Andy Gill . +-- A new, hopefully more flexible, interface +-- and support for file uploads by Bjorn Bringert . +-- +-- 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) diff --git a/src/Network/CGI/Accept.hs b/src/Network/CGI/Accept.hs new file mode 100644 --- /dev/null +++ b/src/Network/CGI/Accept.hs @@ -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 "") ts] (parseM parseHeaderValue "" 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) diff --git a/src/Network/CGI/Cookie.hs b/src/Network/CGI/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Network/CGI/Cookie.hs @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Cookie +-- Copyright : (c) Bjorn Bringert 2004-2005 +-- (c) Ian Lynagh 2005 +-- License : BSD-style +-- +-- Maintainer : John Chee +-- Stability : experimental +-- Portability : portable +-- +-- General server side HTTP cookie library. +-- Based on +-- +-- TODO +-- +-- * Add client side stuff (basically parsing Set-Cookie: value) +-- +-- * Update for RFC2109 +-- +----------------------------------------------------------------------------- +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) diff --git a/src/Network/CGI/Monad.hs b/src/Network/CGI/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Network/CGI/Monad.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Monad +-- Copyright : (c) Bjorn Bringert 2006 +-- License : BSD-style +-- +-- Maintainer : John Chee +-- 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 diff --git a/src/Network/CGI/Protocol.hs b/src/Network/CGI/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/CGI/Protocol.hs @@ -0,0 +1,318 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Protocol +-- Copyright : (c) Bjorn Bringert 2006 +-- License : BSD-style +-- +-- Maintainer : John Chee +-- 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