cgi 3001.1.8.5 → 3001.2.0.0
raw patch · 5 files changed
+124/−102 lines, 5 filesdep +exceptionsdep +network-uridep −MonadCatchIO-mtldep −extensible-exceptionsdep ~basedep ~bytestringdep ~containersnew-uploader
Dependencies added: exceptions, network-uri
Dependencies removed: MonadCatchIO-mtl, extensible-exceptions
Dependency ranges changed: base, bytestring, containers, mtl, network, old-locale, old-time, parsec, xhtml
Files
- LICENSE +6/−6
- Network/CGI.hs +51/−51
- Network/CGI/Monad.hs +28/−18
- Network/CGI/Protocol.hs +12/−1
- cgi.cabal +27/−26
LICENSE view
@@ -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,
Network/CGI.hs view
@@ -28,7 +28,7 @@ -- A new, hopefully more flexible, interface -- and support for file uploads by Bjorn Bringert <mailto:bjorn@bringert.net>. ----- 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"
Network/CGI/Monad.hs view
@@ -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
Network/CGI/Protocol.hs view
@@ -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
cgi.cabal view
@@ -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 <andersk@mit.edu>+Maintainer: John Chee <cheecheeo@gmail.com> 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