cgi-3001.5.0.0/0000755000000000000000000000000007346545000011031 5ustar0000000000000000cgi-3001.5.0.0/CHANGELOG.md0000755000000000000000000000775007346545000012656 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.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 cgi-3001.5.0.0/LICENSE0000644000000000000000000000323407346545000012040 0ustar0000000000000000Copyright 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. 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.5.0.0/README.md0000755000000000000000000000231507346545000012314 0ustar0000000000000000cgi === [![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) [![travis build status](https://img.shields.io/travis/cheecheeo/haskell-cgi/master.svg?label=travis+build)](https://travis-ci.org/cheecheeo/haskell-cgi) This is a Haskell library for writing CGI programs. Its features include: - Access to CGI parameters (e.g. form input) from both GET and POST requests. - Access to CGI environment variables. - Ability to set arbitrary response headers. - Support for HTTP cookies. - An efficient implementation of multipart/form-data using Data.ByteString. This allows for efficient handling of file uploads. - A CGI monad transformer. - Basic exception handling and logging (these should be improved) - Low-level run functions that allow using programs written with this package with protocols other than CGI, for example FastCGI. On hackage: http://hackage.haskell.org/package/cgi Source: https://github.com/cheecheeo/haskell-cgi cgi-3001.5.0.0/Setup.hs0000644000000000000000000000012707346545000012465 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain cgi-3001.5.0.0/cgi.cabal0000644000000000000000000000565607346545000012573 0ustar0000000000000000name: cgi version: 3001.5.0.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.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.8 source-repository head type: git location: git://github.com/cheecheeo/haskell-cgi.git flag install-examples default: False description: compile (and install) the example programs 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.11 , containers < 0.7 , exceptions == 0.10.* , mtl > 2.2.0.1 && < 2.3 , multipart >= 0.1.2 && < 0.3 , network-uri == 2.6.* , parsec >= 2.0 && < 3.2 , time >= 1.5 && < 1.10 , xhtml >= 3000.0.0 && < 3000.3 other-extensions: MultiParamTypeClasses executable cookie.cgi main-is: cookie.hs hs-source-dirs: examples if flag(install-examples) build-depends: base, cgi, xhtml else buildable: False executable error.cgi main-is: error.hs hs-source-dirs: examples if flag(install-examples) build-depends: base, cgi else buildable: False executable hello.cgi main-is: hello.hs hs-source-dirs: examples if flag(install-examples) build-depends: base, cgi else buildable: False executable printinput.cgi main-is: printinput.hs hs-source-dirs: examples if flag(install-examples) build-depends: base, cgi else buildable: False executable redirect.cgi main-is: redirect.hs hs-source-dirs: examples if flag(install-examples) build-depends: base, cgi else buildable: False executable showAllInputs.cgi main-is: showAllInputs.hs hs-source-dirs: examples if flag(install-examples) build-depends: base, cgi else buildable: False executable upload.cgi main-is: upload.hs hs-source-dirs: examples if flag(install-examples) build-depends: base, bytestring, cgi, xhtml else buildable: False cgi-3001.5.0.0/examples/0000755000000000000000000000000007346545000012647 5ustar0000000000000000cgi-3001.5.0.0/examples/cookie.hs0000644000000000000000000000153707346545000014462 0ustar0000000000000000import 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 cgi-3001.5.0.0/examples/error.hs0000644000000000000000000000031207346545000014330 0ustar0000000000000000import Network.CGI (CGI, CGIResult, runCGI, liftIO, output, handleErrors) cgiMain :: CGI CGIResult cgiMain = liftIO (readFile "foo") >> output "bar" main :: IO () main = runCGI (handleErrors cgiMain) cgi-3001.5.0.0/examples/hello.hs0000644000000000000000000000026007346545000014304 0ustar0000000000000000import Network.CGI (CGI, CGIResult, output, runCGI, handleErrors) cgiMain :: CGI CGIResult cgiMain = output "Hello World!" main :: IO () main = runCGI (handleErrors cgiMain) cgi-3001.5.0.0/examples/printinput.hs0000644000000000000000000000421007346545000015414 0ustar0000000000000000-- 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 cgi-3001.5.0.0/examples/redirect.hs0000644000000000000000000000046507346545000015011 0ustar0000000000000000-- 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 cgi-3001.5.0.0/examples/showAllInputs.hs0000644000000000000000000000033307346545000016016 0ustar0000000000000000import Network.CGI (runCGI, getInputs, output) main :: IO () main = runCGI $ do allInputs <- getInputs output $ "Showing all inputs\n" ++ show allInputs ++ "\nDone.\n" cgi-3001.5.0.0/examples/upload.hs0000644000000000000000000000232707346545000014473 0ustar0000000000000000-- 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 cgi-3001.5.0.0/src/Network/0000755000000000000000000000000007346545000013251 5ustar0000000000000000cgi-3001.5.0.0/src/Network/CGI.hs0000644000000000000000000005611407346545000014216 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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) -- | 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 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 = 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) cgi-3001.5.0.0/src/Network/CGI/0000755000000000000000000000000007346545000013653 5ustar0000000000000000cgi-3001.5.0.0/src/Network/CGI/Accept.hs0000644000000000000000000001256107346545000015413 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 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) cgi-3001.5.0.0/src/Network/CGI/Cookie.hs0000644000000000000000000001304407346545000015422 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 (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) cgi-3001.5.0.0/src/Network/CGI/Monad.hs0000644000000000000000000001044107346545000015245 0ustar0000000000000000{-# 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 Data.Typeable 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 } deriving (Typeable) 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 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 cgi-3001.5.0.0/src/Network/CGI/Protocol.hs0000644000000000000000000002550707346545000016021 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. -- ----------------------------------------------------------------------------- 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 Data.Typeable 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, Typeable) -- -- * 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