diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ -Copyright 2001-2010, The University Court of the University of -Glasgow, Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, Erik -Meijer, Sven Panne, Jeremy Shaw +Copyright 2001-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. @@ -9,14 +9,14 @@ - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without -specific prior written permission. +specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, diff --git a/Network/CGI.hs b/Network/CGI.hs --- a/Network/CGI.hs +++ b/Network/CGI.hs @@ -28,7 +28,7 @@ -- 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 +-- Here is a simple example, including error handling (not that there is -- much that can go wrong with Hello World): -- -- > import Network.CGI @@ -56,7 +56,7 @@ , output, outputFPS, outputNothing, redirect , setHeader, setStatus -- * Error pages - , outputError, outputException + , outputError, outputException , outputNotFound, outputMethodNotAllowed, outputInternalServerError -- * Input , getInput, getInputFPS, readInput @@ -101,13 +101,13 @@ #endif (Exception(..), SomeException, ErrorCall(..)) import Control.Monad (liftM) -import Control.Monad.CatchIO (MonadCatchIO) +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.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference, +import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference, escapeURIString, isUnescapedInURI) import System.IO (stdin, stdout) @@ -122,7 +122,7 @@ import Network.CGI.Protocol import Network.CGI.Compat -import Text.XHtml (renderHtml, header, (<<), thetitle, (+++), +import Text.XHtml (renderHtml, header, (<<), thetitle, (+++), body, h1, paragraph, hr, address) @@ -146,8 +146,8 @@ -> 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 +-- | 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. @@ -172,7 +172,7 @@ -- | 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 @@ -180,7 +180,7 @@ -- > -- > main :: IO () -- > main = runCGI (handleErrors cgiMain) -handleErrors :: (MonadCGI m, MonadCatchIO m) => m CGIResult -> m CGIResult +handleErrors :: (MonadCGI m, MonadCatch m, MonadIO m) => m CGIResult -> m CGIResult handleErrors = flip catchCGI outputException -- @@ -203,40 +203,40 @@ -> String -- ^ Status message -> [String] -- ^ Error information -> m CGIResult -outputError c m es = +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 -> + 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 + page <- errorPage c m es output $ renderHtml page -- | Create an HTML error page. -errorPage :: MonadCGI m => +errorPage :: MonadCGI m => Int -- ^ Status code -> String -- ^ Status message -> [String] -- ^ Error information -> m Html -errorPage c m es = +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" + sig = "Haskell CGI" ++ " on " ++ fromMaybe "" server ++ " at " ++ fromMaybe "" host ++ maybe "" (", port "++) port - return $ header << thetitle << tit - +++ body << (h1 << tit +++ map (paragraph <<) es + return $ header << thetitle << tit + +++ body << (h1 << tit +++ map (paragraph <<) es +++ hr +++ address << sig) -errorText :: MonadCGI m => +errorText :: MonadCGI m => Int -- ^ Status code -> String -- ^ Status message -> [String] -- ^ Error information @@ -248,17 +248,17 @@ -- -- | Use 'outputError' to output and log a 404 Not Found error. -outputNotFound :: (MonadIO m, MonadCGI m) => +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) => +outputMethodNotAllowed :: (MonadIO m, MonadCGI m) => [String] -- ^ The allowed methods. -> m CGIResult -outputMethodNotAllowed ms = +outputMethodNotAllowed ms = do let allow = concat $ intersperse ", " ms setHeader "Allow" allow outputError 405 "Method Not Allowed" ["Allowed methods : " ++ allow] @@ -284,7 +284,7 @@ getVarWithDefault :: MonadCGI m => String -- ^ The name of the variable. - -> String -- ^ Default value + -> String -- ^ Default value -> m String getVarWithDefault name def = liftM (fromMaybe def) $ getVar name @@ -297,7 +297,7 @@ -- * Request information -- --- | The server\'s hostname, DNS alias, or IP address as it would +-- | 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" "" @@ -306,7 +306,7 @@ serverPort :: MonadCGI m => m Int serverPort = liftM (fromMaybe 80 . (>>= maybeRead)) (getVar "SERVER_PORT") --- | The method with which the request was made. +-- | 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" @@ -332,8 +332,8 @@ pathTranslated :: MonadCGI m => m String pathTranslated = getVarWithDefault "PATH_TRANSLATED" "" --- | A virtual path to the script being executed, --- used for self-referencing URIs. +-- | 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 @@ -344,7 +344,7 @@ scriptName :: MonadCGI m => m String scriptName = getVarWithDefault "SCRIPT_NAME" "" --- | The information which follows the ? in the URL which referenced +-- | 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. @@ -360,26 +360,26 @@ 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 +-- | 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 +-- | 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 +-- | 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 +-- | 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" @@ -416,7 +416,7 @@ -- * Program and request URI -- --- | Attempts to reconstruct the absolute URI of this program. +-- | Attempts to reconstruct the absolute URI of this program. -- This does not include -- any extra path information or query parameters. See -- 'queryURI' for that. @@ -424,7 +424,7 @@ -- be different from the one requested by the client. -- See also 'requestURI'. -- --- Characters in the components of the returned URI are escaped +-- Characters in the components of the returned URI are escaped -- when needed, as required by "Network.URI". progURI :: MonadCGI m => m URI progURI = @@ -437,19 +437,19 @@ -- 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. + -- 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) + (_,"") -> (h, if (not https && p == 80) + || (https && p == 443) then "" else ':':show p) (h',p') -> (h',p') - let auth = URIAuth { uriUserInfo = "", + let auth = URIAuth { uriUserInfo = "", uriRegName = host, uriPort = port } - return $ nullURI { uriScheme = if https then "https:" else "http:", + return $ nullURI { uriScheme = if https then "https:" else "http:", uriAuthority = Just auth, uriPath = escapePath name } @@ -459,15 +459,15 @@ -- be different from the one requested by the client. -- See also 'requestURI'. -- --- Characters in the components of the returned URI are escaped +-- Characters in the components of the returned URI are escaped -- when needed, as required by "Network.URI". queryURI :: MonadCGI m => m URI -queryURI = +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 } + return $ uri { uriPath = uriPath uri ++ escapePath path, + uriQuery = qs } -- | Does percent-encoding as needed for URI path components. escapePath :: String -> String @@ -480,7 +480,7 @@ -- 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 +-- Characters in the components of the returned URI are escaped -- when needed, as required by "Network.URI". requestURI :: MonadCGI m => m URI requestURI = @@ -490,7 +490,7 @@ mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI" return $ case mreq of Nothing -> uri - Just req -> uri { + Just req -> uri { uriPath = uriPath req, uriQuery = uriQuery req } @@ -524,14 +524,14 @@ -- Example: -- -- > vals <- getMultiInput "my_checkboxes" -getMultiInput :: MonadCGI m => +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 => +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. @@ -552,7 +552,7 @@ getInputContentType :: MonadCGI m => String -- ^ The name of the variable. -> m (Maybe String) -- ^ The content type, formatted as a string. -getInputContentType = +getInputContentType = liftM (fmap (showContentType . inputContentType)) . getInput_ -- | Same as 'getInput', but tries to read the value to the desired type. @@ -626,7 +626,7 @@ -- * Headers -- --- | Add a response header. +-- | Add a response header. -- Example: -- -- > setHeader "Content-type" "text/plain" diff --git a/Network/CGI/Monad.hs b/Network/CGI/Monad.hs --- a/Network/CGI/Monad.hs +++ b/Network/CGI/Monad.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Network.CGI.Monad @@ -10,14 +11,14 @@ -- Portability : non-portable -- -- Internal stuff that most people shouldn't have to use. --- This module mostly deals with the +-- This module mostly deals with the -- internals of the CGIT monad transformer. -- ----------------------------------------------------------------------------- module Network.CGI.Monad ( -- * CGI monad class - MonadCGI(..), + MonadCGI(..), -- * CGI monad transformer CGIT(..), CGI, runCGIT, @@ -35,13 +36,17 @@ #endif as Exception (SomeException, throwIO) import Control.Monad (liftM) -import Control.Monad.CatchIO (MonadCatchIO, block, catch, try, unblock) -import Control.Monad.Error (MonadError(..)) +import Control.Monad.Catch (MonadCatch, MonadThrow, throwM, catch, try) +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) -import Data.Typeable (Typeable(..), Typeable1(..), +#if MIN_VERSION_base(4,7,0) +import Data.Typeable +#else +import Data.Typeable (Typeable(..), Typeable1(..), mkTyConApp, mkTyCon) +#endif import Network.CGI.Protocol @@ -55,10 +60,14 @@ -- | 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") + typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT") [typeOf1 (undefined :: m a), typeOf (undefined :: a)] +#endif instance (Functor m, Monad m) => Functor (CGIT m) where fmap f c = CGIT (fmap f (unCGIT c)) @@ -72,10 +81,11 @@ instance MonadIO m => MonadIO (CGIT m) where liftIO = lift . liftIO -instance MonadCatchIO m => MonadCatchIO (CGIT m) where +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) - block (CGIT m) = CGIT (block m) - unblock (CGIT m) = CGIT (unblock m) -- | The class of CGI monads. Most CGI actions can be run in -- any monad which is an instance of this class, which means that @@ -103,26 +113,26 @@ -- * Error handling -- -instance MonadCatchIO m => MonadError SomeException (CGIT m) where - throwError = throwCGI - catchError = catchCGI +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 'MonadIO', so that we can use 'throwIO' to guarantee ordering. -throwCGI :: (MonadCGI m, MonadIO m) => SomeException -> m a -throwCGI = liftIO . throwIO +throwCGI :: (MonadCGI m, MonadThrow m) => SomeException -> m a +throwCGI = throwM --- | Catches any expection thrown by a CGI action, and uses the given +-- | Catches any expection thrown by a CGI action, and uses the given -- exception handler if an exception is thrown. -catchCGI :: (MonadCGI m, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a +catchCGI :: (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, MonadCatchIO m) => m a -> m (Either SomeException a) +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, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a +handleExceptionCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a handleExceptionCGI = catchCGI diff --git a/Network/CGI/Protocol.hs b/Network/CGI/Protocol.hs --- a/Network/CGI/Protocol.hs +++ b/Network/CGI/Protocol.hs @@ -11,7 +11,7 @@ -- An implementation of the program side of the CGI protocol. -- ----------------------------------------------------------------------------- - +{-# LANGUAGE CPP, DeriveDataTypeable #-} module Network.CGI.Protocol ( -- * CGI request CGIRequest(..), Input(..), @@ -44,8 +44,13 @@ 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.CGI.Header import Network.CGI.Multipart @@ -72,8 +77,10 @@ } 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 { @@ -90,7 +97,11 @@ -- | 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 diff --git a/cgi.cabal b/cgi.cabal --- a/cgi.cabal +++ b/cgi.cabal @@ -1,23 +1,28 @@ Name: cgi -Version: 3001.1.8.5 -Copyright: Bjorn Bringert, Andy Gill, Anders Kaseorg, Ian Lynagh, - Erik Meijer, Sven Panne, Jeremy Shaw +Version: 3001.2.0.0 +Copyright: Bjorn Bringert, John Chee, Andy Gill, Anders Kaseorg, + Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw Category: Network -Maintainer: Anders Kaseorg +Maintainer: John Chee Author: Bjorn Bringert -Homepage: http://andersk.mit.edu/haskell/cgi/ +Homepage: https://github.com/cheecheeo/haskell-cgi +bug-reports: https://github.com/cheecheeo/stats/issues License: BSD3 License-file: LICENSE Synopsis: A library for writing CGI programs Description: - This is a Haskell library for writing CGI programs. + This is a Haskell library for writing CGI programs. Build-Type: Simple -Cabal-Version: >=1.2 +Cabal-Version: >=1.6 -Flag split-base -Flag bytestring-in-base -Flag extensible-exceptions-in-base +source-repository head + type: git + location: git://github.com/cheecheeo/stats.git +Flag network-uri + description: Get Network.URI from the network-uri package + default: True + Library Exposed-Modules: Network.CGI, @@ -35,23 +40,19 @@ ghc-options: -Wall Build-depends: - network >= 2.0, - parsec >= 2.0, - mtl >= 1.0, - MonadCatchIO-mtl, - xhtml >= 3000.0.0 - If flag(split-base) - Build-depends: base >= 3 && < 5, old-time, old-locale, containers - Else - Build-depends: base < 3 - If flag(bytestring-in-base) - Build-depends: base >= 2 && < 3 - Else - Build-depends: base < 2 || < 5, bytestring - If flag(extensible-exceptions-in-base) - Build-depends: base >= 4 + parsec >= 2.0 && < 3.2, + mtl>=2.2.1 && < 2.3, + exceptions < 0.7, + xhtml >= 3000.0.0 && < 3000.3, + bytestring < 0.11, + base >= 4.5 && < 5, + old-time < 1.2, + old-locale < 1.1, + containers < 0.6 + If flag(network-uri) + Build-depends: network-uri == 2.6.*, network == 2.6.* Else - Build-depends: base < 4, extensible-exceptions + Build-depends: network < 2.6 --Executable: printinput --Main-Is: printinput.hs