cgi-3001.3.0.1/0000755000000000000000000000000012702242120011015 5ustar0000000000000000cgi-3001.3.0.1/LICENSE0000644000000000000000000000321612702242120012024 0ustar0000000000000000Copyright 2001-2014, The University Court of the University of Glasgow, Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cgi-3001.3.0.1/cgi.cabal0000644000000000000000000000413612702242120012547 0ustar0000000000000000Name: cgi Version: 3001.3.0.1 Copyright: Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw Category: Network Maintainer: John Chee Author: Bjorn Bringert Homepage: https://github.com/cheecheeo/haskell-cgi bug-reports: https://github.com/cheecheeo/haskell-cgi/issues License: BSD3 License-file: LICENSE Synopsis: A library for writing CGI programs Description: This is a Haskell library for writing CGI programs. Build-Type: Simple extra-source-files: CHANGELOG.md Cabal-Version: >=1.8 source-repository head type: git location: git://github.com/cheecheeo/haskell-cgi.git Flag network-uri description: Get Network.URI from the network-uri package default: True Flag old-mtl description: Use mtl-compat and mtl < 2.2.0.1 default: False Library Exposed-Modules: Network.CGI, Network.CGI.Monad, Network.CGI.Protocol, Network.CGI.Cookie, Network.CGI.Compat Other-modules: Network.CGI.Accept Extensions: CPP, MultiParamTypeClasses ghc-options: -Wall Build-depends: parsec >= 2.0 && < 3.2, exceptions < 0.9, xhtml >= 3000.0.0 && < 3000.3, bytestring < 0.11, base >= 4.5 && < 5, time >= 1.5 && < 1.7, containers < 0.6, multipart >= 0.1.2 && < 0.2 If flag(network-uri) Build-depends: network-uri == 2.6.*, network == 2.6.* Else Build-depends: network < 2.6 If flag(old-mtl) Build-depends: mtl>=2.1.3.1 && < 2.3, mtl-compat >= 0.2.1.1 && < 0.3 Else Build-depends: mtl>=2.2.1 && < 2.3 test-suite doctests type: exitcode-stdio-1.0 ghc-options: -threaded main-is: DocTestMain.hs other-modules: DocTest hs-source-dirs: src ghc-options: -Wall build-depends: base , doctest >= 0.8 && < 0.12 , QuickCheck >= 2.8.1 && < 2.9 --Executable: printinput --Main-Is: printinput.hs --Hs-Source-Dir: examples --Executable: redirect --Main-Is: redirect.hs --Hs-Source-Dir: examples --Executable: upload --Main-Is: upload.hs --Hs-Source-Dir: examples cgi-3001.3.0.1/Setup.hs0000644000000000000000000000012712702242120012451 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain cgi-3001.3.0.1/CHANGELOG.md0000644000000000000000000000327612702242120012636 0ustar0000000000000000# 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.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.1...HEAD [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 cgi-3001.3.0.1/Network/0000755000000000000000000000000012702242120012446 5ustar0000000000000000cgi-3001.3.0.1/Network/CGI.hs0000644000000000000000000005646412702242120013423 0ustar0000000000000000{-# LANGUAGE OverlappingInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Network.CGI -- Copyright : (c) The University of Glasgow 2001 -- (c) Bjorn Bringert 2004-2006 -- (c) Ian Lynagh 2005 -- (c) Jeremy Shaw 2005 -- License : BSD-style -- -- Maintainer : John Chee -- Stability : experimental -- Portability : non-portable (uses Control.Monad.State) -- -- Simple Library for writing CGI programs. -- See for the -- CGI specification. -- -- This version of the library is for systems with version 2.0 or greater -- of the network package. This includes GHC 6.6 and later. For older -- systems, see -- -- Based on the original Haskell binding for CGI: -- -- Original Version by Erik Meijer . -- Further hacked on by Sven Panne . -- Further hacking by Andy Gill . -- A new, hopefully more flexible, interface -- and support for file uploads by Bjorn Bringert . -- -- Here is a simple example, including error handling (not that there is -- much that can go wrong with Hello World): -- -- > import Network.CGI -- > -- > cgiMain :: CGI CGIResult -- > cgiMain = output "Hello World!" -- > -- > main :: IO () -- > main = runCGI (handleErrors cgiMain) -- -- ----------------------------------------------------------------------------- module Network.CGI ( -- * CGI monad MonadCGI, CGIT, CGIResult, CGI , MonadIO, liftIO , runCGI -- * Error handling , throwCGI, catchCGI, tryCGI, handleExceptionCGI , handleErrors -- * Logging , logCGI -- * Output , output, outputFPS, outputNothing, redirect , setHeader, setStatus -- * Error pages , outputError, outputException , outputNotFound, outputMethodNotAllowed, outputInternalServerError -- * Input , getInput, getInputFPS, readInput , getBody, getBodyFPS , getInputs, getInputsFPS, getInputNames , getMultiInput, getMultiInputFPS , getInputFilename, getInputContentType -- * Environment , getVar, getVarWithDefault, getVars -- * Request information , serverName, serverPort , requestMethod, pathInfo , pathTranslated, scriptName , queryString , remoteHost, remoteAddr , authType, remoteUser , requestContentType, requestContentLength , requestHeader -- * Program and request URI , progURI, queryURI, requestURI -- * Content negotiation , Acceptable, Accept , Charset(..), ContentEncoding(..), Language(..) , requestAccept, requestAcceptCharset, requestAcceptEncoding, requestAcceptLanguage , negotiate -- * Content type , ContentType(..), showContentType, parseContentType -- * Cookies , Cookie(..), newCookie , getCookie, readCookie , setCookie, deleteCookie -- * URL encoding , formEncode, urlEncode, formDecode, urlDecode -- * Compatibility with the old API , module Network.CGI.Compat ) where import Control.Exception (Exception(..), SomeException, ErrorCall(..)) import Control.Monad (liftM) import Control.Monad.Catch (MonadCatch) import Control.Monad.Trans (MonadIO, liftIO) import Data.Char (toUpper) import Data.List (intersperse, sort, group) import Data.Maybe (fromMaybe) import qualified Data.Map as Map import Network.Multipart import Network.Multipart.Header import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference, escapeURIString, isUnescapedInURI) import System.IO (stdin, stdout) import qualified Data.ByteString.Lazy.Char8 as BS import Data.ByteString.Lazy.Char8 (ByteString) import Network.CGI.Cookie (Cookie(..), showCookie, newCookie, findCookie) import qualified Network.CGI.Cookie as Cookie (deleteCookie) import Network.CGI.Accept import Network.CGI.Monad import Network.CGI.Protocol import Network.CGI.Compat import Text.XHtml (renderHtml, header, (<<), thetitle, (+++), body, h1, paragraph, hr, address) -- | Run a CGI action. Typically called by the main function. -- Reads input from stdin and writes to stdout. Gets -- CGI environment variables from the program environment. runCGI :: MonadIO m => CGIT m CGIResult -> m () runCGI f = do env <- getCGIVars hRunCGI env stdin stdout (runCGIT f) -- -- * Output \/ redirect -- -- | Output a 'String'. The output is assumed to be text\/html, encoded using -- ISO-8859-1. To change this, set the Content-type header using -- 'setHeader'. output :: MonadCGI m => String -- ^ The string to output. -> m CGIResult output = return . CGIOutput . BS.pack -- | Output a 'ByteString'. The output is assumed to be text\/html, -- encoded using ISO-8859-1. To change this, set the -- Content-type header using 'setHeader'. outputFPS :: MonadCGI m => ByteString -- ^ The string to output. -> m CGIResult outputFPS = return . CGIOutput -- | Do not output anything (except headers). outputNothing :: MonadCGI m => m CGIResult outputNothing = return CGINothing -- | Redirect to some location. redirect :: MonadCGI m => String -- ^ A URL to redirect to. -> m CGIResult redirect url = do setHeader "Location" url outputNothing -- -- * Error handling -- -- | Catches any exception thrown by the given CGI action, -- returns an error page with a 500 Internal Server Error, -- showing the exception information, and logs the error. -- -- Typical usage: -- -- > cgiMain :: CGI CGIResult -- > cgiMain = ... -- > -- > main :: IO () -- > main = runCGI (handleErrors cgiMain) handleErrors :: (MonadCGI m, MonadCatch m, MonadIO m) => m CGIResult -> m CGIResult handleErrors = flip catchCGI outputException -- -- * Error output -- -- | Output a 500 Internal Server Error with information from -- an 'Exception'. outputException :: (MonadCGI m,MonadIO m) => SomeException -> m CGIResult outputException e = outputInternalServerError es where es = case fromException e of Just (ErrorCall msg) -> [msg] _ -> [show e] -- | Output an error page to the user, with the given -- HTTP status code in the response. Also logs the error information -- using 'logCGI'. outputError :: (MonadCGI m, MonadIO m) => Int -- ^ HTTP Status code -> String -- ^ Status message -> [String] -- ^ Error information -> m CGIResult outputError c m es = do logCGI $ show (c,m,es) setStatus c m let textType = ContentType "text" "plain" [("charset","ISO-8859-1")] htmlType = ContentType "text" "html" [("charset","ISO-8859-1")] cts <- liftM (negotiate [htmlType,textType]) requestAccept case cts of ct:_ | ct == textType -> do setHeader "Content-type" (showContentType textType) text <- errorText c m es output text _ -> do setHeader "Content-type" (showContentType htmlType) page <- errorPage c m es output $ renderHtml page -- | Create an HTML error page. errorPage :: MonadCGI m => Int -- ^ Status code -> String -- ^ Status message -> [String] -- ^ Error information -> m Html errorPage c m es = do server <- getVar "SERVER_SOFTWARE" host <- getVar "SERVER_NAME" port <- getVar "SERVER_PORT" let tit = show c ++ " " ++ m sig = "Haskell CGI" ++ " on " ++ fromMaybe "" server ++ " at " ++ fromMaybe "" host ++ maybe "" (", port "++) port return $ header << thetitle << tit +++ body << (h1 << tit +++ map (paragraph <<) es +++ hr +++ address << sig) errorText :: MonadCGI m => Int -- ^ Status code -> String -- ^ Status message -> [String] -- ^ Error information -> m String errorText c m es = return $ unlines $ (show c ++ " " ++ m) : es -- -- * Specific HTTP errors -- -- | Use 'outputError' to output and log a 404 Not Found error. outputNotFound :: (MonadIO m, MonadCGI m) => String -- ^ The name of the requested resource. -> m CGIResult outputNotFound r = outputError 404 "Not Found" ["The requested resource was not found: " ++ r] -- | Use 'outputError' to output and log a 405 Method Not Allowed error. outputMethodNotAllowed :: (MonadIO m, MonadCGI m) => [String] -- ^ The allowed methods. -> m CGIResult outputMethodNotAllowed ms = do let allow = concat $ intersperse ", " ms setHeader "Allow" allow outputError 405 "Method Not Allowed" ["Allowed methods : " ++ allow] -- | Use 'outputError' to output and log a 500 Internal Server Error. outputInternalServerError :: (MonadIO m, MonadCGI m) => [String] -- ^ Error information. -> m CGIResult outputInternalServerError es = outputError 500 "Internal Server Error" es -- -- * Environment variables -- -- | Get the value of a CGI environment variable. Example: -- -- > remoteAddr <- getVar "REMOTE_ADDR" getVar :: MonadCGI m => String -- ^ The name of the variable. -> m (Maybe String) getVar name = liftM (Map.lookup name) $ cgiGet cgiVars getVarWithDefault :: MonadCGI m => String -- ^ The name of the variable. -> String -- ^ Default value -> m String getVarWithDefault name def = liftM (fromMaybe def) $ getVar name -- | Get all CGI environment variables and their values. getVars :: MonadCGI m => m [(String,String)] getVars = liftM Map.toList $ cgiGet cgiVars -- -- * Request information -- -- | The server\'s hostname, DNS alias, or IP address as it would -- appear in self-referencing URLs. serverName :: MonadCGI m => m String serverName = getVarWithDefault "SERVER_NAME" "" -- | The port number to which the request was sent. serverPort :: MonadCGI m => m Int serverPort = liftM (fromMaybe 80 . (>>= maybeRead)) (getVar "SERVER_PORT") -- | The method with which the request was made. -- For HTTP, this is \"GET\", \"HEAD\", \"POST\", etc. requestMethod :: MonadCGI m => m String requestMethod = getVarWithDefault "REQUEST_METHOD" "GET" -- | The extra path information, as given by the client. -- This is any part of the request path that follows the -- CGI program path. -- If the string returned by this function is not empty, -- it is guaranteed to start with a @\'\/\'@. -- -- Note that this function returns an unencoded string. -- Make sure to percent-encode any characters -- that are not allowed in URI paths before using the result of -- this function to construct a URI. -- See 'progURI', 'queryURI' and 'requestURI' for a higher-level -- interface. pathInfo :: MonadCGI m => m String pathInfo = liftM slash $ getVarWithDefault "PATH_INFO" "" where slash s = if not (null s) && head s /= '/' then '/':s else s -- | The path returned by 'pathInfo', but with virtual-to-physical -- mapping applied to it. pathTranslated :: MonadCGI m => m String pathTranslated = getVarWithDefault "PATH_TRANSLATED" "" -- | A virtual path to the script being executed, -- used for self-referencing URIs. -- -- Note that this function returns an unencoded string. -- Make sure to percent-encode any characters -- that are not allowed in URI paths before using the result of -- this function to construct a URI. -- See 'progURI', 'queryURI' and 'requestURI' for a higher-level -- interface. scriptName :: MonadCGI m => m String scriptName = getVarWithDefault "SCRIPT_NAME" "" -- | The information which follows the ? in the URL which referenced -- this program. This is the percent-encoded query information. -- For most normal uses, 'getInput' and friends are probably -- more convenient. queryString :: MonadCGI m => m String queryString = getVarWithDefault "QUERY_STRING" "" -- | The hostname making the request. If the server does not have -- this information, Nothing is returned. See also 'remoteAddr'. remoteHost :: MonadCGI m => m (Maybe String) remoteHost = getVar "REMOTE_HOST" -- | The IP address of the remote host making the request. remoteAddr :: MonadCGI m => m String remoteAddr = getVarWithDefault "REMOTE_ADDR" "" -- | If the server supports user authentication, and the script is -- protected, this is the protocol-specific authentication method -- used to validate the user. authType :: MonadCGI m => m (Maybe String) authType = getVar "AUTH_TYPE" -- | If the server supports user authentication, and the script is -- protected, this is the username they have authenticated as. remoteUser :: MonadCGI m => m (Maybe String) remoteUser = getVar "REMOTE_USER" -- | For queries which have attached information, such as -- HTTP POST and PUT, this is the content type of the data. -- You can use 'parseContentType' to get a structured -- representation of the the content-type value. requestContentType :: MonadCGI m => m (Maybe String) requestContentType = getVar "CONTENT_TYPE" -- | For queries which have attached information, such as -- HTTP POST and PUT, this is the length of the content -- given by the client. requestContentLength :: MonadCGI m => m (Maybe Int) requestContentLength = liftM (>>= maybeRead) $ getVar "CONTENT_LENGTH" -- | Gets the value of the request header with the given name. -- The header name is case-insensitive. -- Example: -- -- > requestHeader "User-Agent" requestHeader :: MonadCGI m => String -> m (Maybe String) requestHeader name = getVar var where var = "HTTP_" ++ map toUpper (replace '-' '_' name) -- -- * Content negotiation -- requestHeaderValue :: (MonadCGI m, HeaderValue a) => String -> m (Maybe a) requestHeaderValue h = liftM (>>= parseM parseHeaderValue h) $ requestHeader h requestAccept :: MonadCGI m => m (Maybe (Accept ContentType)) requestAccept = requestHeaderValue "Accept" requestAcceptCharset :: MonadCGI m => m (Maybe (Accept Charset)) requestAcceptCharset = requestHeaderValue "Accept-Charset" requestAcceptEncoding :: MonadCGI m => m (Maybe (Accept ContentEncoding)) requestAcceptEncoding = requestHeaderValue "Accept-Encoding" requestAcceptLanguage :: MonadCGI m => m (Maybe (Accept Language)) requestAcceptLanguage = requestHeaderValue "Accept-Language" -- -- * Program and request URI -- -- | Attempts to reconstruct the absolute URI of this program. -- This does not include -- any extra path information or query parameters. See -- 'queryURI' for that. -- If the server is rewriting request URIs, this URI can -- be different from the one requested by the client. -- See also 'requestURI'. -- -- Characters in the components of the returned URI are escaped -- when needed, as required by "Network.URI". progURI :: MonadCGI m => m URI progURI = do -- Use HTTP_HOST if available, otherwise SERVER_NAME h <- requestHeader "Host" >>= maybe serverName return p <- serverPort name <- scriptName https <- liftM (maybe False (const True)) (getVar "HTTPS") -- SERVER_PORT might not be the port that the client used -- if the server listens on multiple ports, so we give priority -- to the port in HTTP_HOST. -- HTTP_HOST should include the port according to RFC2616 sec 14.23 -- Some servers (e.g. lighttpd) also seem to include the port in -- SERVER_NAME. -- We include the port if it is in HTTP_HOST or SERVER_NAME, or if -- it is a non-standard port. let (host,port) = case break (==':') h of (_,"") -> (h, if (not https && p == 80) || (https && p == 443) then "" else ':':show p) (h',p') -> (h',p') let auth = URIAuth { uriUserInfo = "", uriRegName = host, uriPort = port } return $ nullURI { uriScheme = if https then "https:" else "http:", uriAuthority = Just auth, uriPath = escapePath name } -- | Like 'progURI', but the returned 'URI' also includes -- any extra path information, and any query parameters. -- If the server is rewriting request URIs, this URI can -- be different from the one requested by the client. -- See also 'requestURI'. -- -- Characters in the components of the returned URI are escaped -- when needed, as required by "Network.URI". queryURI :: MonadCGI m => m URI queryURI = do uri <- progURI path <- pathInfo qs <- liftM (\q -> if null q then q else '?':q) $ queryString return $ uri { uriPath = uriPath uri ++ escapePath path, uriQuery = qs } -- | Does percent-encoding as needed for URI path components. escapePath :: String -> String escapePath = escapeURIString isUnescapedInURIPath where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#" -- | Attempts to reconstruct the absolute URI requested by the client, -- including extra path information and query parameters. -- If no request URI rewriting is done, or if the web server does not -- provide the information needed to reconstruct the request URI, -- this function returns the same value as 'queryURI'. -- -- Characters in the components of the returned URI are escaped -- when needed, as required by "Network.URI". requestURI :: MonadCGI m => m URI requestURI = do uri <- queryURI -- Apache sets REQUEST_URI to the original request URI, -- with percent-encoding intact. mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI" return $ case mreq of Nothing -> uri Just req -> uri { uriPath = uriPath req, uriQuery = uriQuery req } -- -- * Inputs -- -- | Get the value of an input variable, for example from a form. -- If the variable has multiple values, the first one is returned. -- Example: -- -- > query <- getInput "query" getInput :: MonadCGI m => String -- ^ The name of the variable. -> m (Maybe String) -- ^ The value of the variable, -- or Nothing, if it was not set. getInput = liftM (fmap BS.unpack) . getInputFPS -- | Like 'getInput', but returns a 'ByteString'. getInputFPS :: MonadCGI m => String -- ^ The name of the variable. -> m (Maybe ByteString) -- ^ The value of the variable, -- or Nothing, if it was not set. getInputFPS = liftM (fmap inputValue) . getInput_ -- | Get all the values of an input variable, for example from a form. -- This can be used to get all the values from form controls -- which allow multiple values to be selected. -- Example: -- -- > vals <- getMultiInput "my_checkboxes" getMultiInput :: MonadCGI m => String -- ^ The name of the variable. -> m [String] -- ^ The values of the variable, -- or the empty list if the variable was not set. getMultiInput = liftM (map BS.unpack) . getMultiInputFPS -- | Same as 'getMultiInput' but using 'ByteString's. getMultiInputFPS :: MonadCGI m => String -- ^ The name of the variable. -> m [ByteString] -- ^ The values of the variable, -- or the empty list if the variable was not set. getMultiInputFPS n = do is <- cgiGet cgiInputs return [inputValue v | (p,v) <- is, p == n] -- | Get the file name of an input. getInputFilename :: MonadCGI m => String -- ^ The name of the variable. -> m (Maybe String) -- ^ The file name corresponding to the -- input, if there is one. getInputFilename = liftM (>>= inputFilename) . getInput_ -- | Get the content-type of an input, if the input exists, e.g. "image\/jpeg". -- For non-file inputs, this function returns "text\/plain". -- You can use 'parseContentType' to get a structured -- representation of the the content-type value. getInputContentType :: MonadCGI m => String -- ^ The name of the variable. -> m (Maybe String) -- ^ The content type, formatted as a string. getInputContentType = liftM (fmap (showContentType . inputContentType)) . getInput_ -- | Same as 'getInput', but tries to read the value to the desired type. readInput :: (Read a, MonadCGI m) => String -- ^ The name of the variable. -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist -- or if the value could not be interpreted -- at the desired type. readInput = liftM (>>= maybeRead) . getInput -- | Get the names and values of all inputs. -- Note: the same name may occur more than once in the output, -- if there are several values for the name. getInputs :: MonadCGI m => m [(String,String)] getInputs = do is <- cgiGet cgiInputs return [ (n, BS.unpack (inputValue i)) | (n,i) <- is ] -- | Get the names and values of all inputs. -- Note: the same name may occur more than once in the output, -- if there are several values for the name. getInputsFPS :: MonadCGI m => m [(String,ByteString)] getInputsFPS = do is <- cgiGet cgiInputs return [ (n, inputValue i) | (n,i) <- is ] -- | Get the names of all input variables. getInputNames :: MonadCGI m => m [String] getInputNames = (sortNub . map fst) `liftM` cgiGet cgiInputs where sortNub = map head . group . sort -- Internal stuff getInput_ :: MonadCGI m => String -> m (Maybe Input) getInput_ n = lookup n `liftM` cgiGet cgiInputs -- | Get the uninterpreted request body as a String getBody :: MonadCGI m => m String getBody = BS.unpack `liftM` cgiGet cgiRequestBody -- | Get the uninterpreted request body as lazy ByteString getBodyFPS :: MonadCGI m => m ByteString getBodyFPS = cgiGet cgiRequestBody -- -- * Cookies -- -- | Get the value of a cookie. getCookie :: MonadCGI m => String -- ^ The name of the cookie. -> m (Maybe String) -- ^ 'Nothing' if the cookie does not exist. getCookie name = liftM (>>= findCookie name) (getVar "HTTP_COOKIE") -- | Same as 'getCookie', but tries to read the value to the desired type. readCookie :: (Read a, MonadCGI m) => String -- ^ The name of the cookie. -> m (Maybe a) -- ^ 'Nothing' if the cookie does not exist -- or if the value could not be interpreted -- at the desired type. readCookie = liftM (>>= maybeRead) . getCookie -- | Set a cookie. setCookie :: MonadCGI m => Cookie -> m () setCookie = setHeader "Set-cookie" . showCookie -- | Delete a cookie from the client deleteCookie :: MonadCGI m => Cookie -> m () deleteCookie = setCookie . Cookie.deleteCookie -- -- * Headers -- -- | Add a response header. -- Example: -- -- > setHeader "Content-type" "text/plain" setHeader :: MonadCGI m => String -- ^ Header name. -> String -- ^ Header value. -> m () setHeader n v = cgiAddHeader (HeaderName n) v -- | Set the HTTP response status. setStatus :: MonadCGI m => Int -- ^ HTTP status code, e.g. @404@ -> String -- ^ HTTP status message, e.g. @"Not Found"@ -> m () setStatus c m = setHeader "Status" (show c ++ " " ++ m) cgi-3001.3.0.1/Network/CGI/0000755000000000000000000000000012702242120013050 5ustar0000000000000000cgi-3001.3.0.1/Network/CGI/Compat.hs0000644000000000000000000001033212702242120014626 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.CGI.Compat -- Copyright : (c) The University of Glasgow 2001 -- (c) Bjorn Bringert 2004-2006 -- (c) Ian Lynagh 2005 -- (c) Jeremy Shaw 2005 -- License : BSD-style -- -- Maintainer : John Chee -- Stability : experimental -- Portability : non-portable (uses Control.Monad.State) -- -- Compatibility functions for the old Network.CGI API. -- ----------------------------------------------------------------------------- module Network.CGI.Compat ( Html, wrapper, pwrapper, connectToCGIScript ) where import Control.Concurrent (forkIO) import Control.Exception as Exception (SomeException, throw, catch, finally) import Control.Monad (unless) import Control.Monad.Trans (MonadIO, liftIO) import qualified Data.Map as Map import Network (PortID, Socket, listenOn, connectTo) import Network.Socket as Socket (SockAddr(SockAddrInet), accept, socketToHandle) import System.IO (Handle, hPutStrLn, stdin, stdout, hGetLine, hClose, IOMode(ReadWriteMode)) import System.IO.Error (isEOFError) import qualified Data.ByteString.Lazy.Char8 as BS import Data.ByteString.Lazy.Char8 (ByteString) import Text.XHtml (Html, renderHtml) import Network.CGI.Protocol {-# DEPRECATED wrapper, pwrapper, connectToCGIScript "Use the new interface." #-} -- | Compatibility wrapper for the old CGI interface. -- Output the output from a function from CGI environment and -- input variables to an HTML document. wrapper :: ([(String,String)] -> IO Html) -> IO () wrapper = run stdin stdout -- | Compatibility wrapper for the old CGI interface. -- Runs a simple CGI server. -- Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. pwrapper :: PortID -- ^ The port to run the server on. -> ([(String,String)] -> IO Html) -> IO () pwrapper pid f = do sock <- listenOn pid acceptConnections fn sock where fn h = run h h f acceptConnections :: (Handle -> IO ()) -> Socket -> IO () acceptConnections fn sock = do (h, SockAddrInet _ _) <- accept' sock _ <- forkIO (fn h `finally` (hClose h)) acceptConnections fn sock accept' :: Socket -- Listening Socket -> IO (Handle,SockAddr) -- StdIO Handle for read/write accept' sock = do (sock', addr) <- Socket.accept sock handle <- socketToHandle sock' ReadWriteMode return (handle,addr) run :: MonadIO m => Handle -> Handle -> ([(String,String)] -> IO Html) -> m () run inh outh f = do env <- getCGIVars hRunCGI env inh outh f' where f' req = do let vs = Map.toList (cgiVars req) is = [ (n,BS.unpack (inputValue i)) | (n,i) <- cgiInputs req ] html <- liftIO (f (vs++is)) return ([], CGIOutput $ BS.pack $ renderHtml html) -- | Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. connectToCGIScript :: String -> PortID -> IO () connectToCGIScript host portId = do env <- getCGIVars input <- BS.hGetContents stdin let str = getRequestInput env input h <- connectTo host portId `Exception.catch` (\ e -> abort "Cannot connect to CGI daemon." e) BS.hPut h str >> hPutStrLn h "" (sendBack h `finally` hClose h) `Exception.catch` (\e -> unless (isEOFError e) (ioError e)) -- | Returns the query string, or the request body if it is -- a POST request, or the empty string if there is an error. getRequestInput :: [(String,String)] -- ^ CGI environment variables. -> ByteString -- ^ Request body. -> ByteString -- ^ Query string. getRequestInput env req = case lookup "REQUEST_METHOD" env of Just "POST" -> takeInput env req _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env) abort :: String -> SomeException -> IO a abort msg e = do putStrLn ("Content-type: text/html\n\n" ++ "" ++ msg ++ "") throw e sendBack :: Handle -> IO () sendBack h = do s <- hGetLine h putStrLn s sendBack h cgi-3001.3.0.1/Network/CGI/Accept.hs0000644000000000000000000001277412702242120014616 0ustar0000000000000000module Network.CGI.Accept ( -- * Accept-X headers Acceptable , Accept , Charset(..), ContentEncoding(..), Language(..) -- * Content negotiation , negotiate ) where import Data.Function import Data.List import Data.Maybe import Numeric import Text.ParserCombinators.Parsec import Network.Multipart import Network.Multipart.Header -- -- * Accept-X headers -- newtype Accept a = Accept [(a, Quality)] deriving (Show) type Quality = Double -- A bounded join-semilattice class Eq a => Acceptable a where includes :: a -> a -> Bool top :: a instance HeaderValue a => HeaderValue (Accept a) where parseHeaderValue = fmap Accept $ sepBy p (lexeme (char ',')) where p = do a <- parseHeaderValue q <- option 1 $ do _ <- lexeme $ char ';' _ <- lexeme $ char 'q' _ <- lexeme $ char '=' lexeme pQuality return (a,q) pQuality = (char '0' >> option "0" (char '.' >> many digit) >>= \ds -> return (read ("0." ++ ds ++ "0"))) <|> (char '1' >> optional (char '.' >> many (char '0')) >> return 1) prettyHeaderValue (Accept xs) = concat $ intersperse ", " [prettyHeaderValue a ++ "; q=" ++ showQuality q | (a,q) <- xs] where showQuality q = showFFloat (Just 3) q "" starOrEqualTo :: String -> String -> Bool starOrEqualTo x y = x == "*" || x == y negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a] negotiate ys Nothing = ys negotiate ys (Just xs) = reverse [ z | (q,z) <- sortBy (compare `on` fst) [ (quality xs y,y) | y <- ys], q > 0] --testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a] --testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "") ts] (parseM parseHeaderValue "" a) quality :: Acceptable a => Accept a -> a -> Quality quality (Accept xs) y = fromMaybe 0 $ listToMaybe $ sort $ map snd $ sortBy (compareSpecificity `on` fst) $ filter ((`includes` y) . fst) xs compareSpecificity :: Acceptable a => a -> a -> Ordering compareSpecificity x y | x `includes` y && y `includes` x = EQ | x `includes` y = GT | y `includes` x = LT | otherwise = error "Non-comparable Acceptables" -- -- ** Accept -- instance Acceptable ContentType where includes x y = ctType x `starOrEqualTo` ctType y && ctSubtype x `starOrEqualTo` ctSubtype y && all (hasParameter y) (ctParameters x) top = ContentType "*" "*" [] hasParameter :: ContentType -> (String, String) -> Bool hasParameter t (k,v) = maybe False (==v) $ lookup k (ctParameters t) -- -- ** Accept-Charset -- {- RFC 2616 14.2: The special value "*", if present in the Accept-Charset field, matches every character set (including ISO-8859-1) which is not mentioned elsewhere in the Accept-Charset field. If no "*" is present in an Accept-Charset field, then all character sets not explicitly mentioned get a quality value of 0, except for ISO-8859-1, which gets a quality value of 1 if not explicitly mentioned. If no Accept-Charset header is present, the default is that any character set is acceptable. If an Accept-Charset header is present, and if the server cannot send a response which is acceptable according to the Accept-Charset header, then the server SHOULD send an error response with the 406 (not acceptable) status code, though the sending of an unacceptable response is also allowed. -} newtype Charset = Charset String deriving (Show) instance Eq Charset where Charset x == Charset y = caseInsensitiveEq x y instance Ord Charset where Charset x `compare` Charset y = caseInsensitiveCompare x y instance HeaderValue Charset where parseHeaderValue = fmap Charset $ many ws1 >> lexeme p_token prettyHeaderValue (Charset s) = s instance Acceptable Charset where Charset x `includes` Charset y = starOrEqualTo x y top = Charset "*" -- -- ** Accept-Encoding -- {- RFC 2616, section 14.3 -} newtype ContentEncoding = ContentEncoding String deriving (Show) instance Eq ContentEncoding where ContentEncoding x == ContentEncoding y = caseInsensitiveEq x y instance Ord ContentEncoding where ContentEncoding x `compare` ContentEncoding y = caseInsensitiveCompare x y instance HeaderValue ContentEncoding where parseHeaderValue = fmap ContentEncoding $ many ws1 >> lexeme p_token prettyHeaderValue (ContentEncoding s) = s instance Acceptable ContentEncoding where ContentEncoding x `includes` ContentEncoding y = starOrEqualTo x y top = ContentEncoding "*" -- -- ** Accept-Language -- newtype Language = Language String deriving (Show) instance Eq Language where Language x == Language y = caseInsensitiveEq x y instance Ord Language where Language x `compare` Language y = caseInsensitiveCompare x y instance HeaderValue Language where parseHeaderValue = fmap Language $ many ws1 >> lexeme p_token prettyHeaderValue (Language s) = s {- RFC 2616 14.4 A language-range matches a language-tag if it exactly equals the tag, or if it exactly equals a prefix of the tag such that the first tag character following the prefix is "-". The special range "*", if present in the Accept-Language field, matches every tag not matched by any other range present in the Accept-Language field. -} instance Acceptable Language where Language x `includes` Language y = x == "*" || x == y || (x `isPrefixOf` y && "-" `isPrefixOf` drop (length x) y) top = Language "*" cgi-3001.3.0.1/Network/CGI/Monad.hs0000644000000000000000000001107012702242120014441 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Network.CGI.Monad -- Copyright : (c) Bjorn Bringert 2006 -- License : BSD-style -- -- Maintainer : John Chee -- Stability : experimental -- Portability : non-portable -- -- Internal stuff that most people shouldn't have to use. -- This module mostly deals with the -- internals of the CGIT monad transformer. -- ----------------------------------------------------------------------------- module Network.CGI.Monad ( -- * CGI monad class MonadCGI(..), -- * CGI monad transformer CGIT(..), CGI, runCGIT, -- * Request info CGIRequest(..), -- * Error handling throwCGI, catchCGI, tryCGI, handleExceptionCGI, ) where import Prelude hiding (catch) import Control.Exception as Exception (SomeException) import Control.Applicative (Applicative(..)) import Control.Monad (liftM) import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, throwM, catch, try, mask, uninterruptibleMask) import Control.Monad.Except (MonadError(..)) import Control.Monad.Reader (ReaderT(..), asks) import Control.Monad.Writer (WriterT(..), tell) import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift) #if MIN_VERSION_base(4,7,0) import Data.Typeable #else import Data.Typeable (Typeable(..), Typeable1(..), mkTyConApp, mkTyCon) #endif import Network.CGI.Protocol -- -- * CGIT monad transformer -- -- | A simple CGI monad with just IO. type CGI a = CGIT IO a -- | The CGIT monad transformer. newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a } #if MIN_VERSION_base(4,7,0) deriving (Typeable) #else instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT") [typeOf1 (undefined :: m a), typeOf (undefined :: a)] #endif instance (Functor m) => 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) return = CGIT . return -- FIXME: should we have an error monad instead? fail = CGIT . fail instance MonadIO m => MonadIO (CGIT m) where liftIO = lift . liftIO instance MonadThrow m => MonadThrow (CGIT m) where throwM e = CGIT . throwM $ e instance MonadCatch m => MonadCatch (CGIT m) where CGIT m `catch` h = CGIT $ m `catch` (unCGIT . h) instance MonadMask m => MonadMask (CGIT m) where mask a = CGIT $ mask $ \u -> unCGIT $ a $ CGIT . u . unCGIT uninterruptibleMask a = CGIT $ uninterruptibleMask $ \u -> unCGIT $ a $ CGIT . u . unCGIT -- | The class of CGI monads. Most CGI actions can be run in -- any monad which is an instance of this class, which means that -- you can use your own monad transformers to add extra functionality. class Monad m => MonadCGI m where -- | Add a response header. cgiAddHeader :: HeaderName -> String -> m () -- | Get something from the CGI request. cgiGet :: (CGIRequest -> a) -> m a instance Monad m => MonadCGI (CGIT m) where cgiAddHeader n v = CGIT $ lift $ tell [(n,v)] cgiGet = CGIT . asks instance MonadTrans CGIT where lift = CGIT . lift . lift -- | Run a CGI action. runCGIT :: Monad m => CGIT m a -> CGIRequest -> m (Headers, a) runCGIT (CGIT c) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c -- -- * Error handling -- instance MonadCatch m => MonadError SomeException (CGIT m) where throwError = throwM catchError = catch -- | Throw an exception in a CGI monad. The monad is required to be -- a 'MonadThrow', so that we can use 'throwM' to guarantee ordering. throwCGI :: (MonadCGI m, MonadThrow m) => SomeException -> m a throwCGI = throwM -- | Catches any expection thrown by a CGI action, and uses the given -- exception handler if an exception is thrown. catchCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a catchCGI = catch -- | Catches any exception thrown by an CGI action, and returns either -- the exception, or if no exception was raised, the result of the action. tryCGI :: (Functor m, MonadCGI m, MonadCatch m) => m a -> m (Either SomeException a) tryCGI = try {-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-} -- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead. handleExceptionCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a handleExceptionCGI = catchCGI cgi-3001.3.0.1/Network/CGI/Cookie.hs0000644000000000000000000001233612702242120014622 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.CGI.Cookie -- Copyright : (c) Bjorn Bringert 2004-2005 -- (c) Ian Lynagh 2005 -- License : BSD-style -- -- Maintainer : John Chee -- Stability : experimental -- Portability : portable -- -- General server side HTTP cookie library. -- Based on -- -- TODO -- -- * Add client side stuff (basically parsing Set-Cookie: value) -- -- * Update for RFC2109 -- ----------------------------------------------------------------------------- module Network.CGI.Cookie ( Cookie(..) , newCookie , findCookie, deleteCookie , showCookie, readCookies ) where import Data.Char (isSpace) import Data.List (intersperse) import Data.Maybe (catMaybes) import 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 } 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 = 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 = 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 = 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) cgi-3001.3.0.1/Network/CGI/Protocol.hs0000644000000000000000000002631512702242120015214 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.CGI.Protocol -- Copyright : (c) Bjorn Bringert 2006 -- License : BSD-style -- -- Maintainer : John Chee -- Stability : experimental -- Portability : non-portable -- -- An implementation of the program side of the CGI protocol. -- ----------------------------------------------------------------------------- {-# LANGUAGE CPP, DeriveDataTypeable #-} module Network.CGI.Protocol ( -- * CGI request CGIRequest(..), Input(..), -- * CGI response CGIResult(..), Headers, HeaderName(..), -- * Running CGI actions hRunCGI, runCGIEnvFPS, -- * Inputs decodeInput, takeInput, -- * Environment variables getCGIVars, -- * Logging logCGI, -- * URL encoding formEncode, urlEncode, formDecode, urlDecode, -- * Utilities maybeRead, replace ) where import Control.Monad.Trans (MonadIO(..)) import Data.Char (chr, isHexDigit, digitToInt) import Data.List (intersperse) 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) #if MIN_VERSION_base(4,7,0) import Data.Typeable #else import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon) #endif import Network.Multipart -- -- * CGI request -- -- | The input to a CGI action. data CGIRequest = CGIRequest { -- | Environment variables. cgiVars :: Map String String, -- | Input parameters. For better laziness in reading inputs, -- this is not a Map. cgiInputs :: [(String, Input)], -- | Raw request body. To avoid memory leaks, -- this is the empty string if the request body has been -- interpreted as inputs in -- "application\/x-www-form-urlencoded" or -- "multipart\/form-data" format. cgiRequestBody :: ByteString } deriving (Show) #if ! MIN_VERSION_base(4,7,0) instance Typeable CGIResult where typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") [] #endif -- | The value of an input parameter, and some metadata. data Input = Input { inputValue :: ByteString, inputFilename :: Maybe String, inputContentType :: ContentType } deriving Show -- -- * CGI response -- -- | The result of a CGI program. data CGIResult = CGIOutput ByteString | CGINothing #if MIN_VERSION_base(4,7,0) deriving (Show, Read, Eq, Ord, Typeable) #else deriving (Show, Read, Eq, Ord) #endif -- -- * Running CGI actions -- -- | Runs a CGI action in a given environment. Uses Handles for input and output. hRunCGI :: MonadIO m => [(String,String)] -- ^ CGI environment variables, e.g. from 'getCGIVars'. -> Handle -- ^ Handle that input will be read from, e.g. 'System.IO.stdin'. -> Handle -- ^ Handle that output will be written to, e.g. 'System.IO.stdout'. -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action -> m () hRunCGI env hin hout f = do liftIO $ hSetBinaryMode hin True inp <- liftIO $ BS.hGetContents hin outp <- runCGIEnvFPS env inp f liftIO $ BS.hPut hout outp liftIO $ hFlush hout -- | Runs a CGI action in a given environment. Uses lazy ByteStrings -- for input and output. runCGIEnvFPS :: Monad m => [(String,String)] -- ^ CGI environment variables. -> ByteString -- ^ Request body. -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action. -> m ByteString -- ^ Response (headers and content). runCGIEnvFPS vars inp f = do let (inputs,body) = decodeInput vars inp (hs,outp) <- f $ CGIRequest { cgiVars = Map.fromList vars, cgiInputs = inputs, cgiRequestBody = body } return $ case outp of CGIOutput c -> formatResponse c hs' where hs' = if isJust (lookup ct hs) then hs else hs ++ [(ct,defaultContentType)] ct = HeaderName "Content-type" CGINothing -> formatResponse BS.empty hs formatResponse :: ByteString -> Headers -> ByteString formatResponse c hs = -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle -- just LF if there are CRs in the content. unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs] ++ [BS.empty,c]) where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n") defaultContentType :: String defaultContentType = "text/html; charset=ISO-8859-1" -- -- * Inputs -- -- | Gets and decodes the input according to the request -- method and the content-type. decodeInput :: [(String,String)] -- ^ CGI environment variables. -> ByteString -- ^ Request body. -> ([(String,Input)],ByteString) -- ^ A list of input variables and values, and the request body -- if it was not interpreted. decodeInput env inp = let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body) -- | Builds an 'Input' object for a simple value. simpleInput :: String -> Input simpleInput v = Input { inputValue = BS.pack v, inputFilename = Nothing, inputContentType = defaultInputType } -- | The default content-type for variables. defaultInputType :: ContentType defaultInputType = ContentType "text" "plain" [("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 = 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 '+' ' ' -- | 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 cgi-3001.3.0.1/src/0000755000000000000000000000000012702242120011604 5ustar0000000000000000cgi-3001.3.0.1/src/DocTest.hs0000644000000000000000000000017512702242120013510 0ustar0000000000000000module DocTest ( test ) where import Test.DocTest test :: IO () test = doctest ["-iNetwork", "Network/CGI/Protocol.hs"] cgi-3001.3.0.1/src/DocTestMain.hs0000644000000000000000000000013412702242120014310 0ustar0000000000000000module Main ( main ) where import qualified DocTest main :: IO () main = DocTest.test