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-2010, The University Court of the University of -Glasgow, Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, Erik -Meijer, Sven Panne, Jeremy Shaw +Copyright 2001-2019, The University Court of the University of +Glasgow, Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg, +Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw, Peter Simons All rights reserved. @@ -9,14 +9,14 @@ - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without -specific prior written permission. +specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, diff --git a/Network/CGI.hs b/Network/CGI.hs deleted file mode 100644 --- a/Network/CGI.hs +++ /dev/null @@ -1,645 +0,0 @@ -{-# OPTIONS_GHC -fallow-overlapping-instances #-} ------------------------------------------------------------------------------ --- | --- Module : Network.CGI --- Copyright : (c) The University of Glasgow 2001 --- (c) Bjorn Bringert 2004-2006 --- (c) Ian Lynagh 2005 --- (c) Jeremy Shaw 2005 --- License : BSD-style --- --- Maintainer : Anders Kaseorg --- 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 - -#if MIN_VERSION_base(4,0,0) -import Control.Exception -#else -import Control.Exception.Extensible -#endif - (Exception(..), SomeException, ErrorCall(..)) -import Control.Monad (liftM) -import Control.Monad.CatchIO (MonadCatchIO) -import Control.Monad.Trans (MonadIO, liftIO) -import Data.Char (toUpper) -import Data.List (intersperse, sort, group) -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map -import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference, - escapeURIString, isUnescapedInURI) -import System.IO (stdin, stdout) - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) - -import Network.CGI.Cookie (Cookie(..), showCookie, newCookie, findCookie) -import qualified Network.CGI.Cookie as Cookie (deleteCookie) -import Network.CGI.Accept -import Network.CGI.Header -import Network.CGI.Monad -import Network.CGI.Protocol -import Network.CGI.Compat - -import Text.XHtml (renderHtml, header, (<<), thetitle, (+++), - body, h1, paragraph, hr, address) - - --- | Run a CGI action. Typically called by the main function. --- Reads input from stdin and writes to stdout. Gets --- CGI environment variables from the program environment. -runCGI :: MonadIO m => CGIT m CGIResult -> m () -runCGI f = do env <- getCGIVars - hRunCGI env stdin stdout (runCGIT f) - - --- --- * Output \/ redirect --- - --- | Output a 'String'. The output is assumed to be text\/html, encoded using --- ISO-8859-1. To change this, set the Content-type header using --- 'setHeader'. -output :: MonadCGI m => - String -- ^ The string to output. - -> m CGIResult -output = return . CGIOutput . BS.pack - --- | Output a 'ByteString'. The output is assumed to be text\/html, --- encoded using ISO-8859-1. To change this, set the --- Content-type header using 'setHeader'. -outputFPS :: MonadCGI m => - ByteString -- ^ The string to output. - -> m CGIResult -outputFPS = return . CGIOutput - --- | Do not output anything (except headers). -outputNothing :: MonadCGI m => m CGIResult -outputNothing = return CGINothing - --- | Redirect to some location. -redirect :: MonadCGI m => - String -- ^ A URL to redirect to. - -> m CGIResult -redirect url = do setHeader "Location" url - outputNothing - --- --- * Error handling --- - --- | Catches any exception thrown by the given CGI action, --- returns an error page with a 500 Internal Server Error, --- showing the exception information, and logs the error. --- --- Typical usage: --- --- > cgiMain :: CGI CGIResult --- > cgiMain = ... --- > --- > main :: IO () --- > main = runCGI (handleErrors cgiMain) -handleErrors :: (MonadCGI m, MonadCatchIO m) => m CGIResult -> m CGIResult -handleErrors = flip catchCGI outputException - --- --- * Error output --- - --- | Output a 500 Internal Server Error with information from --- an 'Exception'. -outputException :: (MonadCGI m,MonadIO m) => SomeException -> m CGIResult -outputException e = outputInternalServerError es - where es = case fromException e of - Just (ErrorCall msg) -> [msg] - _ -> [show e] - --- | Output an error page to the user, with the given --- HTTP status code in the response. Also logs the error information --- using 'logCGI'. -outputError :: (MonadCGI m, MonadIO m) => - Int -- ^ HTTP Status code - -> String -- ^ Status message - -> [String] -- ^ Error information - -> m CGIResult -outputError c m es = - do logCGI $ show (c,m,es) - setStatus c m - let textType = ContentType "text" "plain" [("charset","ISO-8859-1")] - htmlType = ContentType "text" "html" [("charset","ISO-8859-1")] - cts <- liftM (negotiate [htmlType,textType]) requestAccept - case cts of - ct:_ | ct == textType -> - do setHeader "Content-type" (showContentType textType) - text <- errorText c m es - output text - _ -> do setHeader "Content-type" (showContentType htmlType) - page <- errorPage c m es - output $ renderHtml page - --- | Create an HTML error page. -errorPage :: MonadCGI m => - Int -- ^ Status code - -> String -- ^ Status message - -> [String] -- ^ Error information - -> m Html -errorPage c m es = - do server <- getVar "SERVER_SOFTWARE" - host <- getVar "SERVER_NAME" - port <- getVar "SERVER_PORT" - let tit = show c ++ " " ++ m - sig = "Haskell CGI" - ++ " on " ++ fromMaybe "" server - ++ " at " ++ fromMaybe "" host ++ maybe "" (", port "++) port - return $ header << thetitle << tit - +++ body << (h1 << tit +++ map (paragraph <<) es - +++ hr +++ address << sig) - -errorText :: MonadCGI m => - Int -- ^ Status code - -> String -- ^ Status message - -> [String] -- ^ Error information - -> m String -errorText c m es = return $ unlines $ (show c ++ " " ++ m) : es - --- --- * Specific HTTP errors --- - --- | Use 'outputError' to output and log a 404 Not Found error. -outputNotFound :: (MonadIO m, MonadCGI m) => - String -- ^ The name of the requested resource. - -> m CGIResult -outputNotFound r = - outputError 404 "Not Found" ["The requested resource was not found: " ++ r] - --- | Use 'outputError' to output and log a 405 Method Not Allowed error. -outputMethodNotAllowed :: (MonadIO m, MonadCGI m) => - [String] -- ^ The allowed methods. - -> m CGIResult -outputMethodNotAllowed ms = - do let allow = concat $ intersperse ", " ms - setHeader "Allow" allow - outputError 405 "Method Not Allowed" ["Allowed methods : " ++ allow] - --- | Use 'outputError' to output and log a 500 Internal Server Error. -outputInternalServerError :: (MonadIO m, MonadCGI m) => - [String] -- ^ Error information. - -> m CGIResult -outputInternalServerError es = outputError 500 "Internal Server Error" es - - --- --- * Environment variables --- - --- | Get the value of a CGI environment variable. Example: --- --- > remoteAddr <- getVar "REMOTE_ADDR" -getVar :: MonadCGI m => - String -- ^ The name of the variable. - -> m (Maybe String) -getVar name = liftM (Map.lookup name) $ cgiGet cgiVars - -getVarWithDefault :: MonadCGI m => - String -- ^ The name of the variable. - -> String -- ^ Default value - -> m String -getVarWithDefault name def = liftM (fromMaybe def) $ getVar name - --- | Get all CGI environment variables and their values. -getVars :: MonadCGI m => - m [(String,String)] -getVars = liftM Map.toList $ cgiGet cgiVars - --- --- * Request information --- - --- | The server\'s hostname, DNS alias, or IP address as it would --- appear in self-referencing URLs. -serverName :: MonadCGI m => m String -serverName = getVarWithDefault "SERVER_NAME" "" - --- | The port number to which the request was sent. -serverPort :: MonadCGI m => m Int -serverPort = liftM (fromMaybe 80 . (>>= maybeRead)) (getVar "SERVER_PORT") - --- | The method with which the request was made. --- For HTTP, this is \"GET\", \"HEAD\", \"POST\", etc. -requestMethod :: MonadCGI m => m String -requestMethod = getVarWithDefault "REQUEST_METHOD" "GET" - --- | The extra path information, as given by the client. --- This is any part of the request path that follows the --- CGI program path. --- If the string returned by this function is not empty, --- it is guaranteed to start with a @\'\/\'@. --- --- Note that this function returns an unencoded string. --- Make sure to percent-encode any characters --- that are not allowed in URI paths before using the result of --- this function to construct a URI. --- See 'progURI', 'queryURI' and 'requestURI' for a higher-level --- interface. -pathInfo :: MonadCGI m => m String -pathInfo = liftM slash $ getVarWithDefault "PATH_INFO" "" - where slash s = if not (null s) && head s /= '/' then '/':s else s - --- | The path returned by 'pathInfo', but with virtual-to-physical --- mapping applied to it. -pathTranslated :: MonadCGI m => m String -pathTranslated = getVarWithDefault "PATH_TRANSLATED" "" - --- | A virtual path to the script being executed, --- used for self-referencing URIs. --- --- Note that this function returns an unencoded string. --- Make sure to percent-encode any characters --- that are not allowed in URI paths before using the result of --- this function to construct a URI. --- See 'progURI', 'queryURI' and 'requestURI' for a higher-level --- interface. -scriptName :: MonadCGI m => m String -scriptName = getVarWithDefault "SCRIPT_NAME" "" - --- | The information which follows the ? in the URL which referenced --- this program. This is the percent-encoded query information. --- For most normal uses, 'getInput' and friends are probably --- more convenient. -queryString :: MonadCGI m => m String -queryString = getVarWithDefault "QUERY_STRING" "" - --- | The hostname making the request. If the server does not have --- this information, Nothing is returned. See also 'remoteAddr'. -remoteHost :: MonadCGI m => m (Maybe String) -remoteHost = getVar "REMOTE_HOST" - --- | The IP address of the remote host making the request. -remoteAddr :: MonadCGI m => m String -remoteAddr = getVarWithDefault "REMOTE_ADDR" "" - --- | If the server supports user authentication, and the script is --- protected, this is the protocol-specific authentication method --- used to validate the user. -authType :: MonadCGI m => m (Maybe String) -authType = getVar "AUTH_TYPE" - --- | If the server supports user authentication, and the script is --- protected, this is the username they have authenticated as. -remoteUser :: MonadCGI m => m (Maybe String) -remoteUser = getVar "REMOTE_USER" - --- | For queries which have attached information, such as --- HTTP POST and PUT, this is the content type of the data. --- You can use 'parseContentType' to get a structured --- representation of the the content-type value. -requestContentType :: MonadCGI m => m (Maybe String) -requestContentType = getVar "CONTENT_TYPE" - --- | For queries which have attached information, such as --- HTTP POST and PUT, this is the length of the content --- given by the client. -requestContentLength :: MonadCGI m => m (Maybe Int) -requestContentLength = liftM (>>= maybeRead) $ getVar "CONTENT_LENGTH" - --- | Gets the value of the request header with the given name. --- The header name is case-insensitive. --- Example: --- --- > requestHeader "User-Agent" -requestHeader :: MonadCGI m => String -> m (Maybe String) -requestHeader name = getVar var - where var = "HTTP_" ++ map toUpper (replace '-' '_' name) - --- --- * Content negotiation --- - -requestHeaderValue :: (MonadCGI m, HeaderValue a) => String -> m (Maybe a) -requestHeaderValue h = liftM (>>= parseM parseHeaderValue h) $ requestHeader h - -requestAccept :: MonadCGI m => m (Maybe (Accept ContentType)) -requestAccept = requestHeaderValue "Accept" - -requestAcceptCharset :: MonadCGI m => m (Maybe (Accept Charset)) -requestAcceptCharset = requestHeaderValue "Accept-Charset" - -requestAcceptEncoding :: MonadCGI m => m (Maybe (Accept ContentEncoding)) -requestAcceptEncoding = requestHeaderValue "Accept-Encoding" - -requestAcceptLanguage :: MonadCGI m => m (Maybe (Accept Language)) -requestAcceptLanguage = requestHeaderValue "Accept-Language" - --- --- * Program and request URI --- - --- | Attempts to reconstruct the absolute URI of this program. --- This does not include --- any extra path information or query parameters. See --- 'queryURI' for that. --- If the server is rewriting request URIs, this URI can --- be different from the one requested by the client. --- See also 'requestURI'. --- --- Characters in the components of the returned URI are escaped --- when needed, as required by "Network.URI". -progURI :: MonadCGI m => m URI -progURI = - do -- Use HTTP_HOST if available, otherwise SERVER_NAME - h <- requestHeader "Host" >>= maybe serverName return - p <- serverPort - name <- scriptName - https <- liftM (maybe False (const True)) (getVar "HTTPS") - -- SERVER_PORT might not be the port that the client used - -- if the server listens on multiple ports, so we give priority - -- to the port in HTTP_HOST. - -- HTTP_HOST should include the port according to RFC2616 sec 14.23 - -- Some servers (e.g. lighttpd) also seem to include the port in - -- SERVER_NAME. - -- We include the port if it is in HTTP_HOST or SERVER_NAME, or if - -- it is a non-standard port. - let (host,port) = case break (==':') h of - (_,"") -> (h, if (not https && p == 80) - || (https && p == 443) - then "" else ':':show p) - (h',p') -> (h',p') - let auth = URIAuth { uriUserInfo = "", - uriRegName = host, - uriPort = port } - return $ nullURI { uriScheme = if https then "https:" else "http:", - uriAuthority = Just auth, - uriPath = escapePath name } - --- | Like 'progURI', but the returned 'URI' also includes --- any extra path information, and any query parameters. --- If the server is rewriting request URIs, this URI can --- be different from the one requested by the client. --- See also 'requestURI'. --- --- Characters in the components of the returned URI are escaped --- when needed, as required by "Network.URI". -queryURI :: MonadCGI m => m URI -queryURI = - do uri <- progURI - path <- pathInfo - qs <- liftM (\q -> if null q then q else '?':q) $ queryString - return $ uri { uriPath = uriPath uri ++ escapePath path, - uriQuery = qs } - --- | Does percent-encoding as needed for URI path components. -escapePath :: String -> String -escapePath = escapeURIString isUnescapedInURIPath - where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#" - --- | Attempts to reconstruct the absolute URI requested by the client, --- including extra path information and query parameters. --- If no request URI rewriting is done, or if the web server does not --- provide the information needed to reconstruct the request URI, --- this function returns the same value as 'queryURI'. --- --- Characters in the components of the returned URI are escaped --- when needed, as required by "Network.URI". -requestURI :: MonadCGI m => m URI -requestURI = - do uri <- queryURI - -- Apache sets REQUEST_URI to the original request URI, - -- with percent-encoding intact. - mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI" - return $ case mreq of - Nothing -> uri - Just req -> uri { - uriPath = uriPath req, - uriQuery = uriQuery req - } - - --- --- * Inputs --- - --- | Get the value of an input variable, for example from a form. --- If the variable has multiple values, the first one is returned. --- Example: --- --- > query <- getInput "query" -getInput :: MonadCGI m => - String -- ^ The name of the variable. - -> m (Maybe String) -- ^ The value of the variable, - -- or Nothing, if it was not set. -getInput = liftM (fmap BS.unpack) . getInputFPS - --- | Like 'getInput', but returns a 'ByteString'. -getInputFPS :: MonadCGI m => - String -- ^ The name of the variable. - -> m (Maybe ByteString) -- ^ The value of the variable, - -- or Nothing, if it was not set. -getInputFPS = liftM (fmap inputValue) . getInput_ - --- | Get all the values of an input variable, for example from a form. --- This can be used to get all the values from form controls --- which allow multiple values to be selected. --- Example: --- --- > vals <- getMultiInput "my_checkboxes" -getMultiInput :: MonadCGI m => - String -- ^ The name of the variable. - -> m [String] -- ^ The values of the variable, - -- or the empty list if the variable was not set. -getMultiInput = liftM (map BS.unpack) . getMultiInputFPS - --- | Same as 'getMultiInput' but using 'ByteString's. -getMultiInputFPS :: MonadCGI m => - String -- ^ The name of the variable. - -> m [ByteString] -- ^ The values of the variable, - -- or the empty list if the variable was not set. -getMultiInputFPS n = do is <- cgiGet cgiInputs - return [inputValue v | (p,v) <- is, p == n] - --- | Get the file name of an input. -getInputFilename :: MonadCGI m => - String -- ^ The name of the variable. - -> m (Maybe String) -- ^ The file name corresponding to the - -- input, if there is one. -getInputFilename = liftM (>>= inputFilename) . getInput_ - --- | Get the content-type of an input, if the input exists, e.g. "image\/jpeg". --- For non-file inputs, this function returns "text\/plain". --- You can use 'parseContentType' to get a structured --- representation of the the content-type value. -getInputContentType :: MonadCGI m => - String -- ^ The name of the variable. - -> m (Maybe String) -- ^ The content type, formatted as a string. -getInputContentType = - liftM (fmap (showContentType . inputContentType)) . getInput_ - --- | Same as 'getInput', but tries to read the value to the desired type. -readInput :: (Read a, MonadCGI m) => - String -- ^ The name of the variable. - -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist - -- or if the value could not be interpreted - -- at the desired type. -readInput = liftM (>>= maybeRead) . getInput - --- | Get the names and values of all inputs. --- Note: the same name may occur more than once in the output, --- if there are several values for the name. -getInputs :: MonadCGI m => m [(String,String)] -getInputs = do is <- cgiGet cgiInputs - return [ (n, BS.unpack (inputValue i)) | (n,i) <- is ] - --- | Get the names and values of all inputs. --- Note: the same name may occur more than once in the output, --- if there are several values for the name. -getInputsFPS :: MonadCGI m => m [(String,ByteString)] -getInputsFPS = do is <- cgiGet cgiInputs - return [ (n, inputValue i) | (n,i) <- is ] - --- | Get the names of all input variables. -getInputNames :: MonadCGI m => m [String] -getInputNames = (sortNub . map fst) `liftM` cgiGet cgiInputs - where sortNub = map head . group . sort - --- Internal stuff - -getInput_ :: MonadCGI m => String -> m (Maybe Input) -getInput_ n = lookup n `liftM` cgiGet cgiInputs - --- | Get the uninterpreted request body as a String -getBody :: MonadCGI m => m String -getBody = BS.unpack `liftM` cgiGet cgiRequestBody - --- | Get the uninterpreted request body as lazy ByteString -getBodyFPS :: MonadCGI m => m ByteString -getBodyFPS = cgiGet cgiRequestBody - --- --- * Cookies --- - --- | Get the value of a cookie. -getCookie :: MonadCGI m => - String -- ^ The name of the cookie. - -> m (Maybe String) -- ^ 'Nothing' if the cookie does not exist. -getCookie name = liftM (>>= findCookie name) (getVar "HTTP_COOKIE") - --- | Same as 'getCookie', but tries to read the value to the desired type. -readCookie :: (Read a, MonadCGI m) => - String -- ^ The name of the cookie. - -> m (Maybe a) -- ^ 'Nothing' if the cookie does not exist - -- or if the value could not be interpreted - -- at the desired type. -readCookie = liftM (>>= maybeRead) . getCookie - --- | Set a cookie. -setCookie :: MonadCGI m => Cookie -> m () -setCookie = setHeader "Set-cookie" . showCookie - --- | Delete a cookie from the client -deleteCookie :: MonadCGI m => Cookie -> m () -deleteCookie = setCookie . Cookie.deleteCookie - - --- --- * Headers --- - --- | Add a response header. --- Example: --- --- > setHeader "Content-type" "text/plain" -setHeader :: MonadCGI m => - String -- ^ Header name. - -> String -- ^ Header value. - -> m () -setHeader n v = cgiAddHeader (HeaderName n) v - --- | Set the HTTP response status. -setStatus :: MonadCGI m => - Int -- ^ HTTP status code, e.g. @404@ - -> String -- ^ HTTP status message, e.g. @"Not Found"@ - -> m () -setStatus c m = setHeader "Status" (show c ++ " " ++ m) - diff --git a/Network/CGI/Accept.hs b/Network/CGI/Accept.hs deleted file mode 100644 --- a/Network/CGI/Accept.hs +++ /dev/null @@ -1,174 +0,0 @@ -module Network.CGI.Accept ( - -- * Accept-X headers - Acceptable - , Accept - , Charset(..), ContentEncoding(..), Language(..) - -- * Content negotiation - , negotiate - ) where - -import Data.Function -import Data.List -import Data.Maybe -import Numeric - -import Text.ParserCombinators.Parsec - -import Network.CGI.Header - - --- --- * Accept-X headers --- - -newtype Accept a = Accept [(a, Quality)] - deriving (Show) - -type Quality = Double - --- A bounded join-semilattice -class Eq a => Acceptable a where - includes :: a -> a -> Bool - top :: a - -instance HeaderValue a => HeaderValue (Accept a) where - parseHeaderValue = fmap Accept $ sepBy p (lexeme (char ',')) - where p = do a <- parseHeaderValue - q <- option 1 $ do _ <- lexeme $ char ';' - _ <- lexeme $ char 'q' - _ <- lexeme $ char '=' - lexeme pQuality - return (a,q) - pQuality = (char '0' >> option "0" (char '.' >> many digit) >>= \ds -> return (read ("0." ++ ds ++ "0"))) - <|> (char '1' >> optional (char '.' >> many (char '0')) >> return 1) - prettyHeaderValue (Accept xs) = concat $ intersperse ", " [prettyHeaderValue a ++ "; q=" ++ showQuality q | (a,q) <- xs] - where showQuality q = showFFloat (Just 3) q "" - -starOrEqualTo :: String -> String -> Bool -starOrEqualTo x y = x == "*" || x == y - - -negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a] -negotiate ys Nothing = ys -negotiate ys (Just xs) = reverse [ z | (q,z) <- sortBy (compare `on` fst) [ (quality xs y,y) | y <- ys], q > 0] - ---testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a] ---testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "") 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,118 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Compat --- Copyright : (c) The University of Glasgow 2001 --- (c) Bjorn Bringert 2004-2006 --- (c) Ian Lynagh 2005 --- (c) Jeremy Shaw 2005 --- License : BSD-style --- --- Maintainer : Anders Kaseorg --- Stability : experimental --- Portability : non-portable (uses Control.Monad.State) --- --- Compatibility functions for the old Network.CGI API. --- ------------------------------------------------------------------------------ - -module Network.CGI.Compat ( - Html, wrapper, pwrapper, connectToCGIScript - ) where - -import Control.Concurrent (forkIO) -#if MIN_VERSION_base(4,0,0) -import Control.Exception -#else -import Control.Exception.Extensible -#endif - as Exception (SomeException, throw, catch, finally) -import Control.Monad (unless) -import Control.Monad.Trans (MonadIO, liftIO) -import qualified Data.Map as Map -import Network (PortID, Socket, listenOn, connectTo) -import Network.Socket as Socket (SockAddr(SockAddrInet), accept, socketToHandle) -import System.IO (Handle, hPutStrLn, stdin, stdout, - hGetLine, hClose, IOMode(ReadWriteMode)) -import System.IO.Error (isEOFError) - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) - -import Text.XHtml (Html, renderHtml) - -import Network.CGI.Protocol - - -{-# DEPRECATED wrapper, pwrapper, connectToCGIScript "Use the new interface." #-} - --- | Compatibility wrapper for the old CGI interface. --- Output the output from a function from CGI environment and --- input variables to an HTML document. -wrapper :: ([(String,String)] -> IO Html) -> IO () -wrapper = run stdin stdout - --- | Compatibility wrapper for the old CGI interface. --- Runs a simple CGI server. --- Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. -pwrapper :: PortID -- ^ The port to run the server on. - -> ([(String,String)] -> IO Html) - -> IO () -pwrapper pid f = do sock <- listenOn pid - acceptConnections fn sock - where fn h = run h h f - -acceptConnections :: (Handle -> IO ()) -> Socket -> IO () -acceptConnections fn sock = do - (h, SockAddrInet _ _) <- accept' sock - _ <- forkIO (fn h `finally` (hClose h)) - acceptConnections fn sock - -accept' :: Socket -- Listening Socket - -> IO (Handle,SockAddr) -- StdIO Handle for read/write -accept' sock = do - (sock', addr) <- Socket.accept sock - handle <- socketToHandle sock' ReadWriteMode - return (handle,addr) - -run :: MonadIO m => Handle -> Handle -> ([(String,String)] -> IO Html) -> m () -run inh outh f = - do env <- getCGIVars - hRunCGI env inh outh f' - where f' req = do let vs = Map.toList (cgiVars req) - is = [ (n,BS.unpack (inputValue i)) | (n,i) <- cgiInputs req ] - html <- liftIO (f (vs++is)) - return ([], CGIOutput $ BS.pack $ renderHtml html) - --- | Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. -connectToCGIScript :: String -> PortID -> IO () -connectToCGIScript host portId - = do env <- getCGIVars - input <- BS.hGetContents stdin - let str = getRequestInput env input - h <- connectTo host portId - `Exception.catch` - (\ e -> abort "Cannot connect to CGI daemon." e) - BS.hPut h str >> hPutStrLn h "" - (sendBack h `finally` hClose h) - `Exception.catch` (\e -> unless (isEOFError e) (ioError e)) - --- | Returns the query string, or the request body if it is --- a POST request, or the empty string if there is an error. -getRequestInput :: [(String,String)] -- ^ CGI environment variables. - -> ByteString -- ^ Request body. - -> ByteString -- ^ Query string. -getRequestInput env req = - case lookup "REQUEST_METHOD" env of - Just "POST" -> takeInput env req - _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env) - -abort :: String -> SomeException -> IO a -abort msg e = - do putStrLn ("Content-type: text/html\n\n" ++ - "" ++ 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 : Anders Kaseorg --- 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/Header.hs b/Network/CGI/Header.hs deleted file mode 100644 --- a/Network/CGI/Header.hs +++ /dev/null @@ -1,309 +0,0 @@ --- #hide - ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Header --- Copyright : (c) Peter Thiemann 2001,2002 --- (c) Bjorn Bringert 2005-2006 --- License : BSD-style --- --- Maintainer : Anders Kaseorg --- Stability : experimental --- Portability : non-portable --- --- Parsing of HTTP headers (name, value pairs) --- Partly based on code from WASHMail. --- ------------------------------------------------------------------------------ -module Network.CGI.Header ( - -- * Headers - Headers, - HeaderName(..), - HeaderValue(..), - pHeaders, - - -- * Content-type - ContentType(..), - getContentType, - parseContentType, - showContentType, - - -- * Content-transfer-encoding - ContentTransferEncoding(..), - getContentTransferEncoding, - - -- * Content-disposition - ContentDisposition(..), - getContentDisposition, - - -- * Utilities - parseM, - caseInsensitiveEq, - caseInsensitiveCompare, - lexeme, ws1, p_token - ) where - -import Control.Monad -import Data.Char -import Data.List -import Data.Monoid - -import Text.ParserCombinators.Parsec - --- --- * Headers --- - --- | HTTP headers. -type Headers = [(HeaderName, String)] - --- | A string with case insensitive equality and comparisons. -newtype HeaderName = HeaderName String deriving (Show) - -instance Eq HeaderName where - HeaderName x == HeaderName y = map toLower x == map toLower y - -instance Ord HeaderName where - HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y - - -class HeaderValue a where - parseHeaderValue :: Parser a - prettyHeaderValue :: a -> String - -pHeaders :: Parser Headers -pHeaders = many pHeader - -pHeader :: Parser (HeaderName, String) -pHeader = - do name <- many1 headerNameChar - _ <- char ':' - _ <- many ws1 - line <- lineString - _ <- crLf - extraLines <- many extraFieldLine - return (HeaderName name, concat (line:extraLines)) - -extraFieldLine :: Parser String -extraFieldLine = - do sp <- ws1 - line <- lineString - _ <- crLf - return (sp:line) - -getHeaderValue :: (Monad m, HeaderValue a) => String -> Headers -> m a -getHeaderValue h hs = lookupM (HeaderName h) hs >>= parseM parseHeaderValue h - --- --- * Parameters (for Content-type etc.) --- - -showParameters :: [(String,String)] -> String -showParameters = concatMap f - where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\"" - esc '\\' = "\\\\" - esc '"' = "\\\"" - esc c | c `elem` ['\\','"'] = '\\':[c] - | otherwise = [c] - -p_parameter :: Parser (String,String) -p_parameter = try $ - do _ <- lexeme $ char ';' - p_name <- lexeme $ p_token - -- Don't allow parameters named q. This is needed for parsing Accept-X - -- headers. From RFC 2616 14.1: - -- Note: Use of the "q" parameter name to separate media type - -- parameters from Accept extension parameters is due to historical - -- practice. Although this prevents any media type parameter named - -- "q" from being used with a media range, such an event is believed - -- to be unlikely given the lack of any "q" parameters in the IANA - -- media type registry and the rare usage of any media type - -- parameters in Accept. Future media types are discouraged from - -- registering any parameter named "q". - when (p_name == "q") pzero - _ <- lexeme $ char '=' - -- Workaround for seemingly standardized web browser bug - -- where nothing is escaped in the filename parameter - -- of the content-disposition header in multipart/form-data - let litStr = if p_name == "filename" - then buggyLiteralString - else literalString - p_value <- litStr <|> p_token - return (map toLower p_name, p_value) - --- --- * Content type --- - --- | A MIME media type value. --- The 'Show' instance is derived automatically. --- Use 'showContentType' to obtain the standard --- string representation. --- See for more --- information about MIME media types. -data ContentType = - ContentType { - -- | The top-level media type, the general type - -- of the data. Common examples are - -- \"text\", \"image\", \"audio\", \"video\", - -- \"multipart\", and \"application\". - ctType :: String, - -- | The media subtype, the specific data format. - -- Examples include \"plain\", \"html\", - -- \"jpeg\", \"form-data\", etc. - ctSubtype :: String, - -- | Media type parameters. On common example is - -- the charset parameter for the \"text\" - -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@. - ctParameters :: [(String, String)] - } - deriving (Show, Read) - -instance Eq ContentType where - x == y = ctType x `caseInsensitiveEq` ctType y - && ctSubtype x `caseInsensitiveEq` ctSubtype y - && ctParameters x == ctParameters y - -instance Ord ContentType where - x `compare` y = mconcat [ctType x `caseInsensitiveCompare` ctType y, - ctSubtype x `caseInsensitiveCompare` ctSubtype y, - ctParameters x `compare` ctParameters y] - -instance HeaderValue ContentType where - parseHeaderValue = - do _ <- many ws1 - c_type <- p_token - _ <- char '/' - c_subtype <- lexeme $ p_token - c_parameters <- many p_parameter - return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters - prettyHeaderValue (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps - - --- | Parse the standard representation of a content-type. --- If the input cannot be parsed, this function calls --- 'fail' with a (hopefully) informative error message. -parseContentType :: Monad m => String -> m ContentType -parseContentType = parseM parseHeaderValue "Content-type" - -showContentType :: ContentType -> String -showContentType = prettyHeaderValue - -getContentType :: Monad m => Headers -> m ContentType -getContentType = getHeaderValue "content-type" - --- --- * Content transfer encoding --- - -data ContentTransferEncoding = - ContentTransferEncoding String - deriving (Show, Read, Eq, Ord) - -instance HeaderValue ContentTransferEncoding where - parseHeaderValue = - do _ <- many ws1 - c_cte <- p_token - return $ ContentTransferEncoding (map toLower c_cte) - prettyHeaderValue (ContentTransferEncoding s) = s - -getContentTransferEncoding :: Monad m => Headers -> m ContentTransferEncoding -getContentTransferEncoding = getHeaderValue "content-transfer-encoding" - --- --- * Content disposition --- - -data ContentDisposition = - ContentDisposition String [(String, String)] - deriving (Show, Read, Eq, Ord) - -instance HeaderValue ContentDisposition where - parseHeaderValue = - do _ <- many ws1 - c_cd <- p_token - c_parameters <- many p_parameter - return $ ContentDisposition (map toLower c_cd) c_parameters - prettyHeaderValue (ContentDisposition t hs) = - t ++ concat ["; " ++ n ++ "=" ++ quote v | (n,v) <- hs] - where quote x = "\"" ++ x ++ "\"" -- NOTE: silly, but de-facto standard - -getContentDisposition :: Monad m => Headers -> m ContentDisposition -getContentDisposition = getHeaderValue "content-disposition" - --- --- * Utilities --- - -parseM :: Monad m => Parser a -> SourceName -> String -> m a -parseM p n inp = - case parse p n inp of - Left e -> fail (show e) - Right x -> return x - -lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b -lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n - -caseInsensitiveEq :: String -> String -> Bool -caseInsensitiveEq x y = map toLower x == map toLower y - -caseInsensitiveCompare :: String -> String -> Ordering -caseInsensitiveCompare x y = map toLower x `compare` map toLower y - --- --- * Parsing utilities --- - --- | RFC 822 LWSP-char -ws1 :: Parser Char -ws1 = oneOf " \t" - -lexeme :: Parser a -> Parser a -lexeme p = do x <- p; _ <- many ws1; return x - --- | RFC 822 CRLF (but more permissive) -crLf :: Parser String -crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r" - --- | One line -lineString :: Parser String -lineString = many (noneOf "\n\r") - -literalString :: Parser String -literalString = do _ <- char '\"' - str <- many (noneOf "\"\\" <|> quoted_pair) - _ <- char '\"' - return str - --- No web browsers seem to implement RFC 2046 correctly, --- since they do not escape double quotes and backslashes --- in the filename parameter in multipart/form-data. --- --- Note that this eats everything until the last double quote on the line. -buggyLiteralString :: Parser String -buggyLiteralString = - do _ <- char '\"' - str <- manyTill anyChar (try lastQuote) - return str - where lastQuote = do _ <- char '\"' - notFollowedBy (try (many (noneOf "\"") >> char '\"')) - -headerNameChar :: Parser Char -headerNameChar = noneOf "\n\r:" - -tspecials, tokenchar :: [Char] -tspecials = "()<>@,;:\\\"/[]?=" -tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ tspecials - -p_token :: Parser String -p_token = many1 (oneOf tokenchar) - -text_chars :: [Char] -text_chars = map chr ([1..9] ++ [11,12] ++ [14..127]) - -p_text :: Parser Char -p_text = oneOf text_chars - -quoted_pair :: Parser Char -quoted_pair = do _ <- char '\\' - p_text diff --git a/Network/CGI/Monad.hs b/Network/CGI/Monad.hs deleted file mode 100644 --- a/Network/CGI/Monad.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Monad --- Copyright : (c) Bjorn Bringert 2006 --- License : BSD-style --- --- Maintainer : Anders Kaseorg --- Stability : experimental --- Portability : non-portable --- --- Internal stuff that most people shouldn't have to use. --- This module mostly deals with the --- internals of the CGIT monad transformer. --- ------------------------------------------------------------------------------ - -module Network.CGI.Monad ( - -- * CGI monad class - MonadCGI(..), - -- * CGI monad transformer - CGIT(..), CGI, - runCGIT, - -- * Request info - CGIRequest(..), - -- * Error handling - throwCGI, catchCGI, tryCGI, handleExceptionCGI, - ) where - -import Prelude hiding (catch) -#if MIN_VERSION_base(4,0,0) -import Control.Exception -#else -import Control.Exception.Extensible -#endif - as Exception (SomeException, throwIO) -import Control.Monad (liftM) -import Control.Monad.CatchIO (MonadCatchIO, block, catch, try, unblock) -import Control.Monad.Error (MonadError(..)) -import Control.Monad.Reader (ReaderT(..), asks) -import Control.Monad.Writer (WriterT(..), tell) -import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift) -import Data.Typeable (Typeable(..), Typeable1(..), - mkTyConApp, mkTyCon) - -import Network.CGI.Protocol - - --- --- * CGIT monad transformer --- - --- | A simple CGI monad with just IO. -type CGI a = CGIT IO a - --- | The CGIT monad transformer. -newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a } - -instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where - typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT") - [typeOf1 (undefined :: m a), typeOf (undefined :: a)] - -instance (Functor m, Monad m) => Functor (CGIT m) where - fmap f c = CGIT (fmap f (unCGIT c)) - -instance Monad m => Monad (CGIT m) where - c >>= f = CGIT (unCGIT c >>= unCGIT . f) - return = CGIT . return - -- FIXME: should we have an error monad instead? - fail = CGIT . fail - -instance MonadIO m => MonadIO (CGIT m) where - liftIO = lift . liftIO - -instance MonadCatchIO m => MonadCatchIO (CGIT m) where - CGIT m `catch` h = CGIT $ m `catch` (unCGIT . h) - block (CGIT m) = CGIT (block m) - unblock (CGIT m) = CGIT (unblock m) - --- | The class of CGI monads. Most CGI actions can be run in --- any monad which is an instance of this class, which means that --- you can use your own monad transformers to add extra functionality. -class Monad m => MonadCGI m where - -- | Add a response header. - cgiAddHeader :: HeaderName -> String -> m () - -- | Get something from the CGI request. - cgiGet :: (CGIRequest -> a) -> m a - -instance Monad m => MonadCGI (CGIT m) where - cgiAddHeader n v = CGIT $ lift $ tell [(n,v)] - cgiGet = CGIT . asks - -instance MonadTrans CGIT where - lift = CGIT . lift . lift - --- | Run a CGI action. -runCGIT :: Monad m => CGIT m a -> CGIRequest -> m (Headers, a) -runCGIT (CGIT c) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c - - - --- --- * Error handling --- - -instance MonadCatchIO m => MonadError SomeException (CGIT m) where - throwError = throwCGI - catchError = catchCGI - --- | Throw an exception in a CGI monad. The monad is required to be --- a 'MonadIO', so that we can use 'throwIO' to guarantee ordering. -throwCGI :: (MonadCGI m, MonadIO m) => SomeException -> m a -throwCGI = liftIO . throwIO - --- | Catches any expection thrown by a CGI action, and uses the given --- exception handler if an exception is thrown. -catchCGI :: (MonadCGI m, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a -catchCGI = catch - --- | Catches any exception thrown by an CGI action, and returns either --- the exception, or if no exception was raised, the result of the action. -tryCGI :: (Functor m, MonadCGI m, MonadCatchIO m) => m a -> m (Either SomeException a) -tryCGI = try - -{-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-} --- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead. -handleExceptionCGI :: (MonadCGI m, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a -handleExceptionCGI = catchCGI diff --git a/Network/CGI/Multipart.hs b/Network/CGI/Multipart.hs deleted file mode 100644 --- a/Network/CGI/Multipart.hs +++ /dev/null @@ -1,219 +0,0 @@ --- #hide - ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Multipart --- Copyright : (c) Peter Thiemann 2001,2002 --- (c) Bjorn Bringert 2005-2006 --- License : BSD-style --- --- Maintainer : Anders Kaseorg --- Stability : experimental --- Portability : non-portable --- --- Parsing of the multipart format from RFC2046. --- Partly based on code from WASHMail. --- ------------------------------------------------------------------------------ -module Network.CGI.Multipart - ( - -- * Multi-part messages - MultiPart(..), BodyPart(..) - , parseMultipartBody, hGetMultipartBody - , showMultipartBody - -- * Headers - , ContentType(..), ContentTransferEncoding(..) - , ContentDisposition(..) - , parseContentType - , getContentType - , getContentTransferEncoding - , getContentDisposition - ) where - -import Control.Monad -import Data.Int (Int64) -import Data.List (intersperse) -import Data.Maybe -import System.IO (Handle) - -import Network.CGI.Header - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) - --- --- * Multi-part stuff. --- - -data MultiPart = MultiPart [BodyPart] - deriving (Show, Eq, Ord) - -data BodyPart = BodyPart Headers ByteString - deriving (Show, Eq, Ord) - --- | Read a multi-part message from a 'ByteString'. -parseMultipartBody :: String -- ^ Boundary - -> ByteString -> MultiPart -parseMultipartBody b = - MultiPart . mapMaybe parseBodyPart . splitParts (BS.pack b) - --- | Read a multi-part message from a 'Handle'. --- Fails on parse errors. -hGetMultipartBody :: String -- ^ Boundary - -> Handle - -> IO MultiPart -hGetMultipartBody b = liftM (parseMultipartBody b) . BS.hGetContents - - - -parseBodyPart :: ByteString -> Maybe BodyPart -parseBodyPart s = - do - let (hdr,bdy) = splitAtEmptyLine s - hs <- parseM pHeaders "" (BS.unpack hdr) - return $ BodyPart hs bdy - -showMultipartBody :: String -> MultiPart -> ByteString -showMultipartBody b (MultiPart bs) = - unlinesCRLF $ foldr (\x xs -> d:showBodyPart x:xs) [c,BS.empty] bs - where d = BS.pack ("--" ++ b) - c = BS.pack ("--" ++ b ++ "--") - -showBodyPart :: BodyPart -> ByteString -showBodyPart (BodyPart hs c) = - unlinesCRLF $ [BS.pack (n++": "++v) | (HeaderName n,v) <- hs] ++ [BS.empty,c] - - --- --- * Splitting into multipart parts. --- - --- | Split a multipart message into the multipart parts. -splitParts :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> [ByteString] -splitParts b = spl . dropPreamble b - where - spl x = case splitAtBoundary b x of - Nothing -> [] - Just (s1,d,s2) | isClose b d -> [s1] - | otherwise -> s1:spl s2 - --- | Drop everything up to and including the first line starting --- with the boundary. -dropPreamble :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> ByteString -dropPreamble b s | BS.null s = BS.empty - | isBoundary b s = dropLine s - | otherwise = dropPreamble b (dropLine s) - --- | Split a string at the first boundary line. -splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString -- ^ String to split. - -> Maybe (ByteString,ByteString,ByteString) - -- ^ The part before the boundary, the boundary line, - -- and the part after the boundary line. The CRLF - -- before and the CRLF (if any) after the boundary line - -- are not included in any of the strings returned. - -- Returns 'Nothing' if there is no boundary. -splitAtBoundary b s = spl 0 - where - spl i = case findCRLF (BS.drop i s) of - Nothing -> Nothing - Just (j,l) | isBoundary b s2 -> Just (s1,d,s3) - | otherwise -> spl (i+j+l) - where - s1 = BS.take (i+j) s - s2 = BS.drop (i+j+l) s - (d,s3) = splitAtCRLF s2 - --- | Check whether a string starts with two dashes followed by --- the given boundary string. -isBoundary :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> Bool -isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s - --- | Check whether a string for which 'isBoundary' returns true --- has two dashes after the boudary string. -isClose :: ByteString -- ^ The boundary, without the initial dashes - -> ByteString - -> Bool -isClose b s = startsWithDashes (BS.drop (2+BS.length b) s) - --- | Checks whether a string starts with two dashes. -startsWithDashes :: ByteString -> Bool -startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s - - --- --- * RFC 2046 CRLF --- - -crlf :: ByteString -crlf = BS.pack "\r\n" - -unlinesCRLF :: [ByteString] -> ByteString -unlinesCRLF = BS.concat . intersperse crlf - --- | Drop everything up to and including the first CRLF. -dropLine :: ByteString -> ByteString -dropLine s = snd (splitAtCRLF s) - --- | Split a string at the first empty line. The CRLF (if any) before the --- empty line is included in the first result. The CRLF after the --- empty line is not included in the result. --- If there is no empty line, the entire input is returned --- as the first result. -splitAtEmptyLine :: ByteString -> (ByteString, ByteString) -splitAtEmptyLine s | startsWithCRLF s = (BS.empty, dropCRLF s) - | otherwise = spl 0 - where - spl i = case findCRLF (BS.drop i s) of - Nothing -> (s, BS.empty) - Just (j,l) | startsWithCRLF s2 -> (s1, dropCRLF s2) - | otherwise -> spl (i+j+l) - where (s1,s2) = BS.splitAt (i+j+l) s - --- | Split a string at the first CRLF. The CRLF is not included --- in any of the returned strings. --- If there is no CRLF, the entire input is returned --- as the first string. -splitAtCRLF :: ByteString -- ^ String to split. - -> (ByteString,ByteString) -splitAtCRLF s = case findCRLF s of - Nothing -> (s,BS.empty) - Just (i,l) -> (s1, BS.drop l s2) - where (s1,s2) = BS.splitAt i s - --- | Get the index and length of the first CRLF, if any. -findCRLF :: ByteString -- ^ String to split. - -> Maybe (Int64,Int64) -findCRLF s = - case findCRorLF s of - Nothing -> Nothing - Just j | BS.null (BS.drop (j+1) s) -> Just (j,1) - Just j -> case (BS.index s j, BS.index s (j+1)) of - ('\n','\r') -> Just (j,2) - ('\r','\n') -> Just (j,2) - _ -> Just (j,1) - -findCRorLF :: ByteString -> Maybe Int64 -findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s - -startsWithCRLF :: ByteString -> Bool -startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r') - where c = BS.index s 0 - --- | Drop an initial CRLF, if any. If the string is empty, --- nothing is done. If the string does not start with CRLF, --- the first character is dropped. -dropCRLF :: ByteString -> ByteString -dropCRLF s | BS.null s = BS.empty - | BS.null (BS.drop 1 s) = BS.empty - | c0 == '\n' && c1 == '\r' = BS.drop 2 s - | c0 == '\r' && c1 == '\n' = BS.drop 2 s - | otherwise = BS.drop 1 s - where c0 = BS.index s 0 - c1 = BS.index s 1 diff --git a/Network/CGI/Protocol.hs b/Network/CGI/Protocol.hs deleted file mode 100644 --- a/Network/CGI/Protocol.hs +++ /dev/null @@ -1,314 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Protocol --- Copyright : (c) Bjorn Bringert 2006 --- License : BSD-style --- --- Maintainer : Anders Kaseorg --- Stability : experimental --- Portability : non-portable --- --- An implementation of the program side of the CGI protocol. --- ------------------------------------------------------------------------------ - -module Network.CGI.Protocol ( - -- * CGI request - CGIRequest(..), Input(..), - -- * CGI response - CGIResult(..), - Headers, HeaderName(..), - -- * Running CGI actions - hRunCGI, runCGIEnvFPS, - -- * Inputs - decodeInput, takeInput, - -- * Environment variables - getCGIVars, - -- * Logging - logCGI, - -- * URL encoding - formEncode, urlEncode, formDecode, urlDecode, - -- * Utilities - maybeRead, replace - ) where - -import Control.Monad.Trans (MonadIO(..)) -import Data.List (intersperse) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe (fromMaybe, listToMaybe, isJust) -import Network.URI (unEscapeString,escapeURIString,isUnescapedInURI) -import System.Environment (getEnvironment) -import System.IO (Handle, hPutStrLn, stderr, hFlush, hSetBinaryMode) - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) - -import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon) - -import Network.CGI.Header -import Network.CGI.Multipart - - - --- --- * CGI request --- - --- | The input to a CGI action. -data CGIRequest = - CGIRequest { - -- | Environment variables. - cgiVars :: Map String String, - -- | Input parameters. For better laziness in reading inputs, - -- this is not a Map. - cgiInputs :: [(String, Input)], - -- | Raw request body. To avoid memory leaks, - -- this is the empty string if the request body has been - -- interpreted as inputs in - -- "application\/x-www-form-urlencoded" or - -- "multipart\/form-data" format. - cgiRequestBody :: ByteString - } - deriving (Show) - -instance Typeable CGIResult where - typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") [] - --- | The value of an input parameter, and some metadata. -data Input = Input { - inputValue :: ByteString, - inputFilename :: Maybe String, - inputContentType :: ContentType - } - deriving Show - --- --- * CGI response --- - --- | The result of a CGI program. -data CGIResult = CGIOutput ByteString - | CGINothing - deriving (Show, Read, Eq, Ord) - --- --- * Running CGI actions --- - --- | Runs a CGI action in a given environment. Uses Handles for input and output. -hRunCGI :: MonadIO m => - [(String,String)] -- ^ CGI environment variables, e.g. from 'getCGIVars'. - -> Handle -- ^ Handle that input will be read from, e.g. 'System.IO.stdin'. - -> Handle -- ^ Handle that output will be written to, e.g. 'System.IO.stdout'. - -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action - -> m () -hRunCGI env hin hout f = - do liftIO $ hSetBinaryMode hin True - inp <- liftIO $ BS.hGetContents hin - outp <- runCGIEnvFPS env inp f - liftIO $ BS.hPut hout outp - liftIO $ hFlush hout - --- | Runs a CGI action in a given environment. Uses lazy ByteStrings --- for input and output. -runCGIEnvFPS :: Monad m => - [(String,String)] -- ^ CGI environment variables. - -> ByteString -- ^ Request body. - -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action. - -> m ByteString -- ^ Response (headers and content). -runCGIEnvFPS vars inp f - = do let (inputs,body) = decodeInput vars inp - (hs,outp) <- f $ CGIRequest { - cgiVars = Map.fromList vars, - cgiInputs = inputs, - cgiRequestBody = body - } - return $ case outp of - CGIOutput c -> formatResponse c hs' - where hs' = if isJust (lookup ct hs) - then hs else hs ++ [(ct,defaultContentType)] - ct = HeaderName "Content-type" - CGINothing -> formatResponse BS.empty hs - -formatResponse :: ByteString -> Headers -> ByteString -formatResponse c hs = - -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle - -- just LF if there are CRs in the content. - unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs] - ++ [BS.empty,c]) - where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n") - -defaultContentType :: String -defaultContentType = "text/html; charset=ISO-8859-1" - - --- --- * Inputs --- - - --- | Gets and decodes the input according to the request --- method and the content-type. -decodeInput :: [(String,String)] -- ^ CGI environment variables. - -> ByteString -- ^ Request body. - -> ([(String,Input)],ByteString) - -- ^ A list of input variables and values, and the request body - -- if it was not interpreted. -decodeInput env inp = - let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body) - --- | Builds an 'Input' object for a simple value. -simpleInput :: String -> Input -simpleInput v = Input { inputValue = BS.pack v, - inputFilename = Nothing, - inputContentType = defaultInputType } - --- | The default content-type for variables. -defaultInputType :: ContentType -defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding? - --- --- * Environment variables --- - --- | Gets the values of all CGI variables from the program environment. -getCGIVars :: MonadIO m => m [(String,String)] -getCGIVars = liftIO getEnvironment - --- --- * Logging --- - --- | Logs some message using the server\'s logging facility. --- FIXME: does this have to be more general to support --- FastCGI etc? Maybe we should store log messages in the --- CGIState? -logCGI :: MonadIO m => String -> m () -logCGI s = liftIO (hPutStrLn stderr s) - --- --- * Query string --- - --- | Gets inputs from the query string. -queryInput :: [(String,String)] -- ^ CGI environment variables. - -> [(String,Input)] -- ^ Input variables and values. -queryInput env = formInput $ lookupOrNil "QUERY_STRING" env - --- | Decodes application\/x-www-form-urlencoded inputs. -formInput :: String - -> [(String,Input)] -- ^ Input variables and values. -formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs] - --- --- * URL encoding --- - --- | Formats name-value pairs as application\/x-www-form-urlencoded. -formEncode :: [(String,String)] -> String -formEncode xs = - concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs] - --- | Converts a single value to the application\/x-www-form-urlencoded encoding. -urlEncode :: String -> String -urlEncode = replace ' ' '+' . escapeURIString okChar - where okChar c = c == ' ' || - (isUnescapedInURI c && c `notElem` "&=+") - --- | Gets the name-value pairs from application\/x-www-form-urlencoded data. -formDecode :: String -> [(String,String)] -formDecode "" = [] -formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs) - where (nv,rs) = break (=='&') s - (n,v) = break (=='=') nv - --- | Converts a single value from the --- application\/x-www-form-urlencoded encoding. -urlDecode :: String -> String -urlDecode = unEscapeString . replace '+' ' ' - --- --- * Request content and form-data stuff --- - --- | Gets input variables from the body, if any. -bodyInput :: [(String,String)] - -> ByteString - -> ([(String,Input)], ByteString) -bodyInput env inp = - case lookup "REQUEST_METHOD" env of - Just "POST" -> - let ctype = lookup "CONTENT_TYPE" env >>= parseContentType - in decodeBody ctype $ takeInput env inp - _ -> ([], inp) - --- | Decodes a POST body. -decodeBody :: Maybe ContentType - -> ByteString - -> ([(String,Input)], ByteString) -decodeBody ctype inp = - case ctype of - Just (ContentType "application" "x-www-form-urlencoded" _) - -> (formInput (BS.unpack inp), BS.empty) - Just (ContentType "multipart" "form-data" ps) - -> (multipartDecode ps inp, BS.empty) - Just _ -> ([], inp) -- unknown content-type, the user will have to - -- deal with it by looking at the raw content - -- No content-type given, assume x-www-form-urlencoded - Nothing -> (formInput (BS.unpack inp), BS.empty) - --- | Takes the right number of bytes from the input. -takeInput :: [(String,String)] -- ^ CGI environment variables. - -> ByteString -- ^ Request body. - -> ByteString -- ^ CONTENT_LENGTH bytes from the request - -- body, or the empty string if there is no - -- CONTENT_LENGTH. -takeInput env req = - case len of - Just l -> BS.take l req - Nothing -> BS.empty - where len = lookup "CONTENT_LENGTH" env >>= maybeRead - --- | Decodes multipart\/form-data input. -multipartDecode :: [(String,String)] -- ^ Content-type parameters - -> ByteString -- ^ Request body - -> [(String,Input)] -- ^ Input variables and values. -multipartDecode ps inp = - case lookup "boundary" ps of - Just b -> let MultiPart bs = parseMultipartBody b inp - in map bodyPartToInput bs - Nothing -> [] -- FIXME: report that there was no boundary - -bodyPartToInput :: BodyPart -> (String,Input) -bodyPartToInput (BodyPart hs b) = - case getContentDisposition hs of - Just (ContentDisposition "form-data" ps) -> - (lookupOrNil "name" ps, - Input { inputValue = b, - inputFilename = lookup "filename" ps, - inputContentType = ctype }) - _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error - where ctype = fromMaybe defaultInputType (getContentType hs) - - --- --- * Utilities --- - --- | Replaces all instances of a value in a list by another value. -replace :: Eq a => - a -- ^ Value to look for - -> a -- ^ Value to replace it with - -> [a] -- ^ Input list - -> [a] -- ^ Output list -replace x y = map (\z -> if z == x then y else z) - -maybeRead :: Read a => String -> Maybe a -maybeRead = fmap fst . listToMaybe . reads - --- | Same as 'lookup' specialized to strings, but --- returns the empty string if lookup fails. -lookupOrNil :: String -> [(String,String)] -> String -lookupOrNil n = fromMaybe "" . lookup n - 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,67 +1,125 @@ -Name: cgi -Version: 3001.1.8.5 -Copyright: Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, - Erik Meijer, Sven Panne, Jeremy Shaw -Category: Network -Maintainer: Anders Kaseorg -Author: Bjorn Bringert -Homepage: http://andersk.mit.edu/haskell/cgi/ -License: BSD3 -License-file: LICENSE -Synopsis: A library for writing CGI programs -Description: - This is a Haskell library for writing CGI programs. -Build-Type: Simple -Cabal-Version: >=1.2 +name: cgi +version: 3001.5.2.0 +synopsis: A library for writing CGI programs +description: This is a Haskell library for writing CGI programs. +license: BSD3 +license-file: LICENSE +copyright: Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg, + Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw, Peter Simons +author: Bjorn Bringert +maintainer: John Chee , 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 -Flag split-base -Flag bytestring-in-base -Flag extensible-exceptions-in-base +source-repository head + type: git + location: https://github.com/cheecheeo/haskell-cgi.git -Library - Exposed-Modules: - Network.CGI, - Network.CGI.Monad, - Network.CGI.Protocol, - Network.CGI.Cookie, - Network.CGI.Compat - Other-modules: - Network.CGI.Accept, - Network.CGI.Multipart, - Network.CGI.Header - Extensions: - CPP, - MultiParamTypeClasses - ghc-options: -Wall +flag xhtml-library-needs-text + description: xhtml 3000.3.x introduced a dependency on text + manual: False - Build-depends: - network >= 2.0, - parsec >= 2.0, - mtl >= 1.0, - MonadCatchIO-mtl, - xhtml >= 3000.0.0 - If flag(split-base) - Build-depends: base >= 3 && < 5, old-time, old-locale, containers - Else - Build-depends: base < 3 - If flag(bytestring-in-base) - Build-depends: base >= 2 && < 3 - Else - Build-depends: base < 2 || < 5, bytestring - If flag(extensible-exceptions-in-base) - Build-depends: base >= 4 - Else - Build-depends: base < 4, extensible-exceptions +flag install-examples + default: False + description: compile (and install) the example programs ---Executable: printinput ---Main-Is: printinput.hs ---Hs-Source-Dir: examples +library + exposed-modules: Network.CGI + Network.CGI.Cookie + Network.CGI.Monad + Network.CGI.Protocol + other-modules: Network.CGI.Accept + hs-source-dirs: src + build-depends: base >= 4.9 && < 5 + , bytestring < 0.13 + , containers < 0.9 + , exceptions == 0.10.* + , mtl > 2.2.0.1 && < 2.4 + , multipart >= 0.1.2 && < 0.3 + , network-uri == 2.6.* + , parsec >= 2.0 && < 3.2 + , time >= 1.5 && < 1.17 + if flag(xhtml-library-needs-text) + build-depends: xhtml >= 3000.3 && < 3000.5, text + else + build-depends: xhtml >= 3000 && < 3000.3 + other-extensions: MultiParamTypeClasses + default-language: Haskell2010 ---Executable: redirect ---Main-Is: redirect.hs ---Hs-Source-Dir: examples +executable cookie.cgi + main-is: cookie.hs + hs-source-dirs: examples + default-language: Haskell2010 ---Executable: upload ---Main-Is: upload.hs ---Hs-Source-Dir: examples + if flag(install-examples) && !flag(xhtml-library-needs-text) + build-depends: base, cgi, xhtml + else + buildable: False +executable error.cgi + main-is: error.hs + hs-source-dirs: examples + default-language: Haskell2010 + + if flag(install-examples) + build-depends: base, cgi + else + buildable: False + +executable hello.cgi + main-is: hello.hs + hs-source-dirs: examples + default-language: Haskell2010 + + if flag(install-examples) + build-depends: base, cgi + else + buildable: False + +executable printinput.cgi + main-is: printinput.hs + hs-source-dirs: examples + default-language: Haskell2010 + + if flag(install-examples) + build-depends: base, cgi + else + buildable: False + +executable redirect.cgi + main-is: redirect.hs + hs-source-dirs: examples + default-language: Haskell2010 + + if flag(install-examples) + build-depends: base, cgi + else + buildable: False + +executable showAllInputs.cgi + main-is: showAllInputs.hs + hs-source-dirs: examples + default-language: Haskell2010 + + if flag(install-examples) + build-depends: base, cgi + else + buildable: False + +executable upload.cgi + main-is: upload.hs + hs-source-dirs: examples + default-language: Haskell2010 + + if flag(install-examples) && !flag(xhtml-library-needs-text) + build-depends: base, bytestring, cgi + else + buildable: False 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