diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright 2001-2005, The University Court of the University of +Glasgow, Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne + +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. diff --git a/Network/CGI.hs b/Network/CGI.hs new file mode 100644 --- /dev/null +++ b/Network/CGI.hs @@ -0,0 +1,534 @@ +{-# OPTIONS_GHC -fallow-overlapping-instances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI +-- Copyright : (c) The University of Glasgow 2001 +-- (c) Bjorn Bringert 2004-2006 +-- (c) Ian Lynagh 2005 +-- (c) Jeremy Shaw 2005 +-- License : BSD-style +-- +-- Maintainer : bjorn@bringert.net +-- 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 + , getInputs, getInputNames + , getMultiInput + , getInputFilename, getInputContentType + -- * Environment + , getVar, getVarWithDefault, getVars + , serverName, serverPort + , requestMethod, pathInfo + , pathTranslated, scriptName + , queryString + , remoteHost, remoteAddr + , authType, remoteUser + , requestContentType, requestContentLength + , requestHeader + -- * Program and request URI + , progURI, queryURI, requestURI + -- * Content type + , ContentType(..), showContentType, parseContentType + -- * Cookies + , Cookie(..), newCookie + , getCookie, readCookie + , setCookie, deleteCookie + -- * URL encoding + , formEncode, urlEncode, formDecode, urlDecode + -- * Compatibility with the old API + , module Network.CGI.Compat + ) where + +import Control.Exception (Exception(..)) +import Control.Monad (liftM) +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 System.IO (stdin, stdout) +import System.IO.Error (isUserError, ioeGetErrorString) + +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.RFC822Headers (ContentType(..), + parseContentType, showContentType) +import Network.CGI.Monad +import Network.CGI.Protocol +import Network.CGI.Compat + +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 :: CGI CGIResult -> CGI CGIResult +handleErrors = flip catchCGI outputException + +-- +-- * Error output +-- + +-- | Output a 500 Internal Server Error with information from +-- an 'Exception'. +outputException :: (MonadCGI m,MonadIO m) => Exception -> m CGIResult +outputException e = outputInternalServerError es + where es = case e of + ErrorCall msg -> [msg] + IOException ie -> ioe ie + _ -> [show e] + ioe ie = if isUserError ie then [ioeGetErrorString ie] else [show ie] + +-- | 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 + setHeader "Content-type" "text/html; charset=ISO-8859-1" + 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) + +-- +-- * Specific HTTP errors +-- + +-- | Use 'outputError' to output and log a 404 Not Found error. +outputNotFound :: (MonadIO m, MonadCGI m) => + String -- ^ The name of the requested resource. + -> m CGIResult +outputNotFound r = + outputError 404 "Not Found" ["The requested resource was not found: " ++ r] + +-- | Use 'outputError' to output and log a 405 Method Not Allowed error. +outputMethodNotAllowed :: (MonadIO m, MonadCGI m) => + [String] -- ^ The allowed methods. + -> m CGIResult +outputMethodNotAllowed ms = + do let allow = concat $ intersperse ", " ms + setHeader "Allow" allow + outputError 405 "Method Not Allowed" ["Allowed methods : " ++ allow] + +-- | Use 'outputError' to output and log a 500 Internal Server Error. +outputInternalServerError :: (MonadIO m, MonadCGI m) => + [String] -- ^ Error information. + -> m CGIResult +outputInternalServerError es = outputError 500 "Internal Server Error" es + + +-- +-- * Environment variables +-- + +-- | Get the value of a CGI environment variable. Example: +-- +-- > remoteAddr <- getVar "REMOTE_ADDR" +getVar :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) +getVar name = liftM (Map.lookup name) $ cgiGet cgiVars + +getVarWithDefault :: MonadCGI m => + String -- ^ The name of the variable. + -> String -- ^ Default value + -> m String +getVarWithDefault name def = liftM (fromMaybe def) $ getVar name + +-- | Get all CGI environment variables and their values. +getVars :: MonadCGI m => + m [(String,String)] +getVars = liftM Map.toList $ cgiGet cgiVars + + +-- | The server\'s hostname, DNS alias, or IP address as it would +-- appear in self-referencing URLs. +serverName :: MonadCGI m => m String +serverName = getVarWithDefault "SERVER_NAME" "" + +-- | The port number to which the request was sent. +serverPort :: MonadCGI m => m Int +serverPort = liftM (fromMaybe 80 . (>>= maybeRead)) (getVar "SERVER_PORT") + +-- | The method with which the request was made. +-- For HTTP, this is \"GET\", \"HEAD\", \"POST\", etc. +requestMethod :: MonadCGI m => m String +requestMethod = getVarWithDefault "REQUEST_METHOD" "GET" + +-- | The extra path information, as given by the client. +-- This is any part of the request path that follows the +-- CGI program path. +-- If the string returned by this function is not empty, +-- it is guaranteed to start with a @\'\/\'@. +pathInfo :: MonadCGI m => m String +pathInfo = liftM slash $ getVarWithDefault "PATH_INFO" "" + where slash s = if not (null s) && head s /= '/' then '/':s else s + +-- | The path returned by 'pathInfo', but with any 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 URLs. +scriptName :: MonadCGI m => m String +scriptName = getVarWithDefault "SCRIPT_NAME" "" + +-- | The information which follows the ? in the URL which referenced +-- this program. This is the encoded query information. +-- For most normal uses, 'getInput' and friends are probably +-- more convenient. +queryString :: MonadCGI m => m String +queryString = getVarWithDefault "QUERY_STRING" "" + +-- | The hostname making the request. If the server does not have +-- this information, Nothing is returned. See also 'remoteAddr'. +remoteHost :: MonadCGI m => m (Maybe String) +remoteHost = getVar "REMOTE_HOST" + +-- | The IP address of the remote host making the request. +remoteAddr :: MonadCGI m => m String +remoteAddr = getVarWithDefault "REMOTE_ADDR" "" + +-- | If the server supports user authentication, and the script is +-- protected, this is the protocol-specific authentication method +-- used to validate the user. +authType :: MonadCGI m => m (Maybe String) +authType = getVar "AUTH_TYPE" + +-- | If the server supports user authentication, and the script is +-- protected, this is the username they have authenticated as. +remoteUser :: MonadCGI m => m (Maybe String) +remoteUser = getVar "REMOTE_USER" + +-- | For queries which have attached information, such as +-- HTTP POST and PUT, this is the content type of the data. +-- You can use 'parseContentType' to get a structured +-- representation of the the content-type value. +requestContentType :: MonadCGI m => m (Maybe String) +requestContentType = getVar "CONTENT_TYPE" + +-- | For queries which have attached information, such as +-- HTTP POST and PUT, this is the length of the content +-- given by the client. +requestContentLength :: MonadCGI m => m (Maybe Int) +requestContentLength = liftM (>>= maybeRead) $ getVar "CONTENT_LENGTH" + +-- | Gets the value of the request header with the given name. +-- The header name is case-insensitive. +-- Example: +-- +-- > requestHeader "User-Agent" +requestHeader :: MonadCGI m => String -> m (Maybe String) +requestHeader name = getVar var + where var = "HTTP_" ++ map toUpper (replace '-' '_' name) + + +-- +-- * 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'. +progURI :: MonadCGI m => m URI +progURI = + do host <- serverName + port <- serverPort + name <- scriptName + let scheme = if port == 443 then "https:" else "http:" + auth = URIAuth { uriUserInfo = "", + uriRegName = host, + uriPort = if port == 80 || port == 443 + then "" else ":"++show port } + return $ nullURI { uriScheme = scheme, + uriAuthority = Just auth, + uriPath = 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'. +queryURI :: MonadCGI m => m URI +queryURI = + do uri <- progURI + path <- pathInfo + qs <- liftM (\q -> if null q then q else '?':q) $ queryString + return $ uri { uriPath = uriPath uri ++ path, uriQuery = qs } + +-- | 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'. +requestURI :: MonadCGI m => m URI +requestURI = + do uri <- queryURI + -- Apache sets REQUEST_URI to the original request URI + mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI" + return $ case mreq of + Nothing -> uri + Just req -> uri { + uriPath = uriPath req, + uriQuery = uriQuery req + } + + +-- +-- * Inputs +-- + +-- | Get the value of an input variable, for example from a form. +-- If the variable has multiple values, the first one is returned. +-- Example: +-- +-- > query <- getInput "query" +getInput :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) -- ^ The value of the variable, + -- or Nothing, if it was not set. +getInput = liftM (fmap BS.unpack) . getInputFPS + +-- | Like 'getInput', but returns a 'ByteString'. +getInputFPS :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe ByteString) -- ^ The value of the variable, + -- or Nothing, if it was not set. +getInputFPS = liftM (fmap inputValue) . getInput_ + +-- | Get all the values of an input variable, for example from a form. +-- This can be used to get all the values from form controls +-- which allow multiple values to be selected. +-- Example: +-- +-- > vals <- getMultiInput "my_checkboxes" +getMultiInput :: MonadCGI m => + String -- ^ The name of the variable. + -> m [String] -- ^ The values of the variable, + -- or the empty list if the variable was not set. +getMultiInput n = do is <- cgiGet cgiInputs + return [BS.unpack (inputValue v) | (p,v) <- is, p == n] + +-- | Get the file name of an input. +getInputFilename :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) -- ^ The file name corresponding to the + -- input, if there is one. +getInputFilename = liftM (>>= inputFilename) . getInput_ + +-- | Get the content-type of an input, if the input exists, e.g. "image\/jpeg". +-- For non-file inputs, this function returns "text\/plain". +-- You can use 'parseContentType' to get a structured +-- representation of the the content-type value. +getInputContentType :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) -- ^ The content type, formatted as a string. +getInputContentType = + liftM (fmap (showContentType . inputContentType)) . getInput_ + +-- | Same as 'getInput', but tries to read the value to the desired type. +readInput :: (Read a, MonadCGI m) => + String -- ^ The name of the variable. + -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist + -- or if the value could not be interpreted + -- at the desired type. +readInput = liftM (>>= maybeRead) . getInput + +-- | Get the names and values of all inputs. +-- Note: the same name may occur more than once in the output, +-- if there are several values for the name. +getInputs :: MonadCGI m => m [(String,String)] +getInputs = do is <- cgiGet cgiInputs + return [ (n, BS.unpack (inputValue i)) | (n,i) <- is ] + +-- | Get the names of all input variables. +getInputNames :: MonadCGI m => m [String] +getInputNames = (sortNub . map fst) `liftM` cgiGet cgiInputs + where sortNub = map head . group . sort + +-- Internal stuff + +getInput_ :: MonadCGI m => String -> m (Maybe Input) +getInput_ n = lookup n `liftM` cgiGet cgiInputs + + +-- +-- * Cookies +-- + +-- | Get the value of a cookie. +getCookie :: MonadCGI m => + String -- ^ The name of the cookie. + -> m (Maybe String) -- ^ 'Nothing' if the cookie does not exist. +getCookie name = liftM (>>= findCookie name) (getVar "HTTP_COOKIE") + +-- | Same as 'getCookie', but tries to read the value to the desired type. +readCookie :: (Read a, MonadCGI m) => + String -- ^ The name of the cookie. + -> m (Maybe a) -- ^ 'Nothing' if the cookie does not exist + -- or if the value could not be interpreted + -- at the desired type. +readCookie = liftM (>>= maybeRead) . getCookie + +-- | Set a cookie. +setCookie :: MonadCGI m => Cookie -> m () +setCookie = setHeader "Set-cookie" . showCookie + +-- | Delete a cookie from the client +deleteCookie :: MonadCGI m => Cookie -> m () +deleteCookie = setCookie . Cookie.deleteCookie + + +-- +-- * Headers +-- + +-- | Add a response header. +-- Example: +-- +-- > setHeader "Content-type" "text/plain" +setHeader :: MonadCGI m => + String -- ^ Header name. + -> String -- ^ Header value. + -> m () +setHeader n v = cgiAddHeader (HeaderName n) v + +-- | Set the HTTP response status. +setStatus :: MonadCGI m => + Int -- ^ HTTP status code, e.g. @404@ + -> String -- ^ HTTP status message, e.g. @"Not Found"@ + -> m () +setStatus c m = setHeader "Status" (show c ++ " " ++ m) + diff --git a/Network/CGI/Compat.hs b/Network/CGI/Compat.hs new file mode 100644 --- /dev/null +++ b/Network/CGI/Compat.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Compat +-- Copyright : (c) The University of Glasgow 2001 +-- (c) Bjorn Bringert 2004-2006 +-- (c) Ian Lynagh 2005 +-- (c) Jeremy Shaw 2005 +-- License : BSD-style +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable (uses Control.Monad.State) +-- +-- Compatibility functions for the old Network.CGI API. +-- +----------------------------------------------------------------------------- + +module Network.CGI.Compat ( + Html, wrapper, pwrapper, connectToCGIScript + ) where + +import Control.Concurrent (forkIO) +import Control.Exception as Exception (Exception,throw,catch,finally) +import Control.Monad (unless) +import Control.Monad.Trans (MonadIO, liftIO) +import qualified Data.Map as Map +import Network (PortID, Socket, listenOn, connectTo) +import Network.Socket as Socket (SockAddr(SockAddrInet), accept, socketToHandle) +import System.IO (Handle, hPutStrLn, stdin, stdout, + hGetLine, hClose, IOMode(ReadWriteMode)) +import System.IO.Error (isEOFError) + +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy.Char8 (ByteString) + +import Text.XHtml (Html, renderHtml) + +import Network.CGI.Protocol + + +{-# DEPRECATED wrapper, pwrapper, connectToCGIScript "Use the new interface." #-} + +-- | Compatibility wrapper for the old CGI interface. +-- Output the output from a function from CGI environment and +-- input variables to an HTML document. +wrapper :: ([(String,String)] -> IO Html) -> IO () +wrapper = run stdin stdout + +-- | Compatibility wrapper for the old CGI interface. +-- Runs a simple CGI server. +-- Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. +pwrapper :: PortID -- ^ The port to run the server on. + -> ([(String,String)] -> IO Html) + -> IO () +pwrapper pid f = do sock <- listenOn pid + acceptConnections fn sock + where fn h = run h h f + +acceptConnections :: (Handle -> IO ()) -> Socket -> IO () +acceptConnections fn sock = do + (h, SockAddrInet _ _) <- accept' sock + forkIO (fn h `finally` (hClose h)) + acceptConnections fn sock + +accept' :: Socket -- Listening Socket + -> IO (Handle,SockAddr) -- StdIO Handle for read/write +accept' sock = do + (sock', addr) <- Socket.accept sock + handle <- socketToHandle sock' ReadWriteMode + return (handle,addr) + +run :: MonadIO m => Handle -> Handle -> ([(String,String)] -> IO Html) -> m () +run inh outh f = + do env <- getCGIVars + hRunCGI env inh outh f' + where f' req = do let vs = Map.toList (cgiVars req) + is = [ (n,BS.unpack (inputValue i)) | (n,i) <- cgiInputs req ] + html <- liftIO (f (vs++is)) + return ([], CGIOutput $ BS.pack $ renderHtml html) + +-- | Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. +connectToCGIScript :: String -> PortID -> IO () +connectToCGIScript host portId + = do env <- getCGIVars + input <- BS.hGetContents stdin + let str = getRequestInput env input + h <- connectTo host portId + `Exception.catch` + (\ e -> abort "Cannot connect to CGI daemon." e) + BS.hPut h str >> hPutStrLn h "" + (sendBack h `finally` hClose h) + `Prelude.catch` (\e -> unless (isEOFError e) (ioError e)) + +-- | Returns the query string, or the request body if it is +-- a POST request, or the empty string if there is an error. +getRequestInput :: [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> ByteString -- ^ Query string. +getRequestInput env req = + case lookup "REQUEST_METHOD" env of + Just "POST" -> takeInput env req + _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env) + +abort :: String -> Exception -> IO a +abort msg e = + do putStrLn ("Content-type: text/html\n\n" ++ + "" ++ msg ++ "") + throw e + +sendBack :: Handle -> IO () +sendBack h = do s <- hGetLine h + putStrLn s + sendBack h diff --git a/Network/CGI/Cookie.hs b/Network/CGI/Cookie.hs new file mode 100644 --- /dev/null +++ b/Network/CGI/Cookie.hs @@ -0,0 +1,155 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Cookie +-- Copyright : (c) Bjorn Bringert 2004-2005 +-- (c) Ian Lynagh 2005 +-- License : BSD-style +-- +-- Maintainer : Bjorn Bringert +-- Stability : experimental +-- Portability : portable +-- +-- General server side HTTP cookie library. +-- Based on +-- +-- TODO +-- +-- * Add client side stuff (basically parsing Set-Cookie: value) +-- +-- * Update for RFC2109 +-- +----------------------------------------------------------------------------- +module Network.CGI.Cookie ( + Cookie(..) + , newCookie + , findCookie, deleteCookie + , showCookie, readCookies + ) where + +import Data.Char (isSpace) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import System.Locale (defaultTimeLocale, rfc822DateFormat) +import System.Time (CalendarTime(..), Month(..), Day(..), + formatCalendarTime) + +-- +-- * Types +-- + +-- | Contains all information about a cookie set by the server. +data Cookie = Cookie { + -- | Name of the cookie. + cookieName :: String, + -- | Value of the cookie. + cookieValue :: String, + -- | Expiry date of the cookie. If 'Nothing', the + -- cookie expires when the browser sessions ends. + -- If the date is in the past, the client should + -- delete the cookie immediately. + cookieExpires :: Maybe CalendarTime, + -- | The domain suffix to which this cookie will be sent. + cookieDomain :: Maybe String, + -- | The path to which this cookie will be sent. + cookiePath :: Maybe String, + -- | 'True' if this cookie should only be sent using + -- secure means. + cookieSecure :: Bool + } + deriving (Show, Read, Eq, Ord) + +-- +-- * Constructing cookies +-- + +-- | Construct a cookie with only name and value set. +-- This client will expire when the browser sessions ends, +-- will only be sent to the server and path which set it +-- and may be sent using any means. +newCookie :: String -- ^ Name + -> String -- ^ Value + -> Cookie -- ^ Cookie +newCookie name value = Cookie { cookieName = name, + cookieValue = value, + cookieExpires = Nothing, + cookieDomain = Nothing, + cookiePath = Nothing, + cookieSecure = False + } + +-- +-- * Getting and setting cookies +-- + +-- | Get the value of a cookie from a string on the form +-- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@. +-- This is the format of the @Cookie@ HTTP header. +findCookie :: String -- ^ Cookie name + -> String -- ^ Semicolon separated list of name-value pairs + -> Maybe String -- ^ Cookie value, if found +findCookie name s = maybeLast [ cv | (cn,cv) <- readCookies s, cn == name ] + +-- | Delete a cookie from the client by setting the cookie expiry date +-- to a date in the past. +deleteCookie :: Cookie -- ^ Cookie to delete. The only fields that matter + -- are 'cookieName', 'cookieDomain' and 'cookiePath' + -> Cookie +deleteCookie c = c { cookieExpires = Just epoch } + where + epoch = CalendarTime { + ctYear = 1970, + ctMonth = January, + ctDay = 1, + ctHour = 0, + ctMin = 0, + ctSec = 0, + ctPicosec = 0, + ctWDay = Thursday, + ctYDay = 1, + ctTZName = "GMT", + ctTZ = 0, + ctIsDST = False + } + +-- +-- * Reading and showing cookies +-- + +-- | Show a cookie on the format used as the value of the Set-Cookie header. +showCookie :: Cookie -> String +showCookie c = concat $ intersperse "; " $ + showPair (cookieName c) (cookieValue c) + : catMaybes [expires, path, domain, secure] + where expires = fmap (showPair "expires" . dateFmt) (cookieExpires c) + domain = fmap (showPair "domain") (cookieDomain c) + path = fmap (showPair "path") (cookiePath c) + secure = if cookieSecure c then Just "secure" else Nothing + dateFmt = formatCalendarTime defaultTimeLocale rfc822DateFormat + +-- | Show a name-value pair. FIXME: if the name or value +-- contains semicolons, this breaks. The problem +-- is that the original cookie spec does not mention +-- how to do escaping or quoting. +showPair :: String -- ^ name + -> String -- ^ value + -> String +showPair name value = name ++ "=" ++ value + + +-- | Gets all the cookies from a Cookie: header value +readCookies :: String -- ^ String to parse + -> [(String,String)] -- ^ Cookie name - cookie value pairs +readCookies s = + let (xs,ys) = break (=='=') (dropWhile isSpace s) + (zs,ws) = break (==';') (dropWhile isSpace (drop 1 ys)) + in if null xs then [] else (xs,zs):readCookies (drop 1 ws) + +-- +-- Utilities +-- + +-- | Return 'Nothing' is the list is empty, otherwise return +-- the last element of the list. +maybeLast :: [a] -> Maybe a +maybeLast [] = Nothing +maybeLast xs = Just (last xs) diff --git a/Network/CGI/Monad.hs b/Network/CGI/Monad.hs new file mode 100644 --- /dev/null +++ b/Network/CGI/Monad.hs @@ -0,0 +1,119 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Monad +-- Copyright : (c) Bjorn Bringert 2006 +-- License : BSD-style +-- +-- Maintainer : bjorn@bringert.net +-- 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 Control.Exception as Exception (Exception, try, throwIO) +import Control.Monad (liftM) +import Control.Monad.Error (MonadError(..)) +import Control.Monad.Reader (ReaderT(..), asks) +import Control.Monad.Writer (WriterT(..), tell) +import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift) +import Data.Monoid (mempty) +import Data.Typeable (Typeable(..), Typeable1(..), + mkTyConApp, mkTyCon) + +import Network.CGI.Protocol + + +-- +-- * CGIT monad transformer +-- + +-- | A simple CGI monad with just IO. +type CGI a = CGIT IO a + +-- | The CGIT monad transformer. +newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a } + +instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where + typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT") + [typeOf1 (undefined :: m a), typeOf (undefined :: a)] + +instance Monad m => Functor (CGIT m) where + fmap f c = CGIT (fmap f (unCGIT c)) + +instance Monad m => Monad (CGIT m) where + c >>= f = CGIT (unCGIT c >>= unCGIT . f) + return = CGIT . return + -- FIXME: should we have an error monad instead? + fail = CGIT . fail + +instance MonadIO m => MonadIO (CGIT m) where + liftIO = lift . liftIO + +-- | The class of CGI monads. Most CGI actions can be run in +-- any monad which is an instance of this class, which means that +-- you can use your own monad transformers to add extra functionality. +class Monad m => MonadCGI m where + -- | Add a response header. + cgiAddHeader :: HeaderName -> String -> m () + -- | Get something from the CGI request. + cgiGet :: (CGIRequest -> a) -> m a + +instance Monad m => MonadCGI (CGIT m) where + cgiAddHeader n v = CGIT $ lift $ tell [(n,v)] + cgiGet = CGIT . asks + +instance MonadTrans CGIT where + lift = CGIT . lift . lift + +-- | Run a CGI action. +runCGIT :: Monad m => CGIT m a -> CGIRequest -> m (Headers, a) +runCGIT (CGIT c) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c + + + +-- +-- * Error handling +-- + +instance MonadError Exception (CGIT IO) where + throwError = throwCGI + catchError = catchCGI + +-- | Throw an exception in a CGI monad. The monad is required to be +-- a 'MonadIO', so that we can use 'throwIO' to guarantee ordering. +throwCGI :: (MonadCGI m, MonadIO m) => Exception -> m a +throwCGI = liftIO . throwIO + +-- | Catches any expection thrown by a CGI action, and uses the given +-- exception handler if an exception is thrown. +catchCGI :: CGI a -> (Exception -> CGI a) -> CGI a +catchCGI c h = tryCGI c >>= either h return + +-- | 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 :: CGI a -> CGI (Either Exception a) +tryCGI (CGIT c) = CGIT (ReaderT (\r -> WriterT (f (runWriterT (runReaderT c r))))) + where + f = liftM (either (\ex -> (Left ex,mempty)) (\(a,w) -> (Right a,w))) . try + +{-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-} +-- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead. +handleExceptionCGI :: CGI a -> (Exception -> CGI a) -> CGI a +handleExceptionCGI = catchCGI diff --git a/Network/CGI/Multipart.hs b/Network/CGI/Multipart.hs new file mode 100644 --- /dev/null +++ b/Network/CGI/Multipart.hs @@ -0,0 +1,211 @@ +-- #hide + +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Multipart +-- Copyright : (c) Peter Thiemann 2001,2002 +-- (c) Bjorn Bringert 2005-2006 +-- License : BSD-style +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Parsing of the multipart format from RFC2046. +-- Partly based on code from WASHMail. +-- +----------------------------------------------------------------------------- +module Network.CGI.Multipart + ( + -- * Multi-part messages + MultiPart(..), BodyPart(..), Header + , parseMultipartBody, hGetMultipartBody + -- * Headers + , ContentType(..), ContentTransferEncoding(..) + , ContentDisposition(..) + , parseContentType + , parseContentTransferEncoding + , parseContentDisposition + , getContentType + , getContentTransferEncoding + , getContentDisposition + ) where + +import Control.Monad +import Data.Int (Int64) +import Data.Maybe +import System.IO (Handle) + +import Network.CGI.RFC822Headers + +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy.Char8 (ByteString) + +-- +-- * Multi-part stuff. +-- + +data MultiPart = MultiPart [BodyPart] + deriving (Show, Read, Eq, Ord) + +data BodyPart = BodyPart [Header] ByteString + deriving (Show, Read, Eq, Ord) + +-- | Read a multi-part message from a 'ByteString'. +parseMultipartBody :: String -- ^ Boundary + -> ByteString -> Maybe MultiPart +parseMultipartBody b s = + do + ps <- splitParts (BS.pack b) s + liftM MultiPart $ mapM parseBodyPart ps + +-- | Read a multi-part message from a 'Handle'. +-- Fails on parse errors. +hGetMultipartBody :: String -- ^ Boundary + -> Handle + -> IO MultiPart +hGetMultipartBody b h = + do + s <- BS.hGetContents h + case parseMultipartBody b s of + Nothing -> fail "Error parsing multi-part message" + Just m -> return m + + + +parseBodyPart :: ByteString -> Maybe BodyPart +parseBodyPart s = + do + (hdr,bdy) <- splitAtEmptyLine s + hs <- parseM pHeaders "" (BS.unpack hdr) + return $ BodyPart hs bdy + +-- +-- * Splitting into multipart parts. +-- + +-- | Split a multipart message into the multipart parts. +splitParts :: ByteString -- ^ The boundary, without the initial dashes + -> ByteString + -> Maybe [ByteString] +splitParts b s = dropPreamble b s >>= spl + where + spl x = case splitAtBoundary b x of + Nothing -> Nothing + Just (s1,d,s2) | isClose b d -> Just [s1] + | otherwise -> spl s2 >>= Just . (s1:) + +-- | Drop everything up to and including the first line starting +-- with the boundary. Returns 'Nothing' if there is no +-- line starting with a boundary. +dropPreamble :: ByteString -- ^ The boundary, without the initial dashes + -> ByteString + -> Maybe ByteString +dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s) + | otherwise = dropLine s >>= dropPreamble b + +-- | Split a string at the first boundary line. +splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes + -> ByteString -- ^ String to split. + -> Maybe (ByteString,ByteString,ByteString) + -- ^ The part before the boundary, the boundary line, + -- and the part after the boundary line. The CRLF + -- before and the CRLF (if any) after the boundary line + -- are not included in any of the strings returned. + -- Returns 'Nothing' if there is no boundary. +splitAtBoundary b s = spl 0 + where + spl i = case findCRLF (BS.drop i s) of + Nothing -> Nothing + Just (j,l) | isBoundary b s2 -> Just (s1,d,s3) + | otherwise -> spl (i+j+l) + where + s1 = BS.take (i+j) s + s2 = BS.drop (i+j+l) s + (d,s3) = splitAtCRLF_ s2 + +-- | Check whether a string starts with two dashes followed by +-- the given boundary string. +isBoundary :: ByteString -- ^ The boundary, without the initial dashes + -> ByteString + -> Bool +isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s + +-- | Check whether a string for which 'isBoundary' returns true +-- has two dashes after the boudary string. +isClose :: ByteString -- ^ The boundary, without the initial dashes + -> ByteString + -> Bool +isClose b s = startsWithDashes (BS.drop (2+BS.length b) s) + +-- | Checks whether a string starts with two dashes. +startsWithDashes :: ByteString -> Bool +startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s + + +-- +-- * RFC 2046 CRLF +-- + +-- | Drop everything up to and including the first CRLF. +dropLine :: ByteString -> Maybe ByteString +dropLine s = fmap snd (splitAtCRLF s) + +-- | Split a string at the first empty line. The CRLF (if any) before the +-- empty line is included in the first result. The CRLF after the +-- empty line is not included in the result. +-- 'Nothing' is returned if there is no empty line. +splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString) +splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s) + | otherwise = spl 0 + where + spl i = case findCRLF (BS.drop i s) of + Nothing -> Nothing + Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2) + | otherwise -> spl (i+j+l) + where (s1,s2) = BS.splitAt (i+j+l) s + +-- | Split a string at the first CRLF. The CRLF is not included +-- in any of the returned strings. +splitAtCRLF :: ByteString -- ^ String to split. + -> Maybe (ByteString,ByteString) + -- ^ Returns 'Nothing' if there is no CRLF. +splitAtCRLF s = case findCRLF s of + Nothing -> Nothing + Just (i,l) -> Just (s1, BS.drop l s2) + where (s1,s2) = BS.splitAt i s + +-- | Like 'splitAtCRLF', but if no CRLF is found, the first +-- result is the argument string, and the second result is empty. +splitAtCRLF_ :: ByteString -> (ByteString,ByteString) +splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s) + +-- | Get the index and length of the first CRLF, if any. +findCRLF :: ByteString -- ^ String to split. + -> Maybe (Int64,Int64) +findCRLF s = + case findCRorLF s of + Nothing -> Nothing + Just j | j == BS.length s - 1 -> Just (j,1) + Just j -> case (BS.index s j, BS.index s (j+1)) of + ('\n','\r') -> Just (j,2) + ('\r','\n') -> Just (j,2) + _ -> Just (j,1) + +findCRorLF :: ByteString -> Maybe Int64 +findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s + +startsWithCRLF :: ByteString -> Bool +startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r') + where c = BS.index s 0 + +-- | Drop an initial CRLF, if any. If the string is empty, +-- nothing is done. If the string does not start with CRLF, +-- the first character is dropped. +dropCRLF :: ByteString -> ByteString +dropCRLF s | BS.length s <= 1 = BS.drop 1 s + | c0 == '\n' && c1 == '\r' = BS.drop 2 s + | c0 == '\r' && c1 == '\n' = BS.drop 2 s + | otherwise = BS.drop 1 s + where c0 = BS.index s 0 + c1 = BS.index s 1 diff --git a/Network/CGI/Protocol.hs b/Network/CGI/Protocol.hs new file mode 100644 --- /dev/null +++ b/Network/CGI/Protocol.hs @@ -0,0 +1,316 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Protocol +-- Copyright : (c) Bjorn Bringert 2006 +-- License : BSD-style +-- +-- Maintainer : bjorn@bringert.net +-- 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 (toLower) +import Data.List (intersperse) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromMaybe, listToMaybe, isJust) +import Network.URI (unEscapeString,escapeURIString,isUnescapedInURI) +import System.Environment (getEnvironment) +import System.IO (Handle, hPutStrLn, stderr, hFlush) + +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy.Char8 (ByteString) + +import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon) + +import Network.CGI.Multipart + + + +-- +-- * CGI request +-- + +-- | The input to a CGI action. +data CGIRequest = + CGIRequest { + -- | Environment variables. + cgiVars :: Map String String, + -- | Input parameters. For better laziness in reading inputs, + -- this is not a Map. + cgiInputs :: [(String, Input)], + -- | Raw request body. + cgiRequestBody :: ByteString + } + deriving (Show) + +instance Typeable CGIResult where + typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") [] + +-- | The value of an input parameter, and some metadata. +data Input = Input { + inputValue :: ByteString, + inputFilename :: Maybe String, + inputContentType :: ContentType + } + deriving Show + +-- +-- * CGI response +-- + +-- | The result of a CGI program. +data CGIResult = CGIOutput ByteString + | CGINothing + deriving (Show, Read, Eq, Ord) + +type Headers = [(HeaderName, String)] + +-- | A string with case insensitive equality and comparisons. +newtype HeaderName = HeaderName String deriving (Show) + +instance Eq HeaderName where + HeaderName x == HeaderName y = map toLower x == map toLower y + +instance Ord HeaderName where + HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y + + + +-- +-- * 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. 'stdin'. + -> Handle -- ^ Handle that output will be written to, e.g. 'stdout'. + -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action + -> m () +hRunCGI env hin hout f = + do 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 (hs,outp) <- f $ CGIRequest { + cgiVars = Map.fromList vars, + cgiInputs = decodeInput vars inp, + cgiRequestBody = inp + } + 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 = + BS.unlines ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs] + ++ [BS.empty,c]) + +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)] -- ^ Input variables and values. +decodeInput env inp = queryInput env ++ bodyInput env inp + +-- | Builds an 'Input' object for a simple value. +simpleInput :: String -> Input +simpleInput v = Input { inputValue = BS.pack v, + inputFilename = Nothing, + inputContentType = defaultInputType } + +-- | The default content-type for variables. +defaultInputType :: ContentType +defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding? + +-- +-- * Environment variables +-- + +-- | Gets the values of all CGI variables from the program environment. +getCGIVars :: MonadIO m => m [(String,String)] +getCGIVars = liftIO getEnvironment + +-- +-- * Logging +-- + +-- | Logs some message using the server\'s logging facility. +-- FIXME: does this have to be more general to support +-- FastCGI etc? Maybe we should store log messages in the +-- CGIState? +logCGI :: MonadIO m => String -> m () +logCGI s = liftIO (hPutStrLn stderr s) + +-- +-- * Query string +-- + +-- | Gets inputs from the query string. +queryInput :: [(String,String)] -- ^ CGI environment variables. + -> [(String,Input)] -- ^ Input variables and values. +queryInput env = formInput $ lookupOrNil "QUERY_STRING" env + +-- | Decodes application\/x-www-form-urlencoded inputs. +formInput :: String + -> [(String,Input)] -- ^ Input variables and values. +formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs] + +-- +-- * URL encoding +-- + +-- | Formats name-value pairs as application\/x-www-form-urlencoded. +formEncode :: [(String,String)] -> String +formEncode xs = + concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs] + +-- | Converts a single value to the application\/x-www-form-urlencoded encoding. +urlEncode :: String -> String +urlEncode = replace ' ' '+' . escapeURIString okChar + where okChar c = c == ' ' || + (isUnescapedInURI c && c `notElem` "&=+") + +-- | Gets the name-value pairs from application\/x-www-form-urlencoded data. +formDecode :: String -> [(String,String)] +formDecode "" = [] +formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs) + where (nv,rs) = break (=='&') s + (n,v) = break (=='=') nv + +-- | Converts a single value from the +-- application\/x-www-form-urlencoded encoding. +urlDecode :: String -> String +urlDecode = unEscapeString . replace '+' ' ' + +-- +-- * Request content and form-data stuff +-- + +-- | Gets input variables from the body, if any. +bodyInput :: [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> [(String,Input)] -- ^ Input variables and values. +bodyInput env inp = + case lookup "REQUEST_METHOD" env of + Just "POST" -> + let ctype = lookup "CONTENT_TYPE" env >>= parseContentType + in decodeBody ctype $ takeInput env inp + _ -> [] + +-- | Decodes a POST body. +decodeBody :: Maybe ContentType -- ^ Content-type, if any + -> ByteString -- ^ Request body + -> [(String,Input)] -- ^ Input variables and values. +decodeBody ctype inp = + case ctype of + Just (ContentType "application" "x-www-form-urlencoded" _) + -> formInput (BS.unpack inp) + Just (ContentType "multipart" "form-data" ps) + -> multipartDecode ps inp + Just _ -> [] -- 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) + +-- | 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 -> case parseMultipartBody b inp of + Just (MultiPart bs) -> map bodyPartToInput bs + Nothing -> [] -- FIXME: report parse error + Nothing -> [] -- FIXME: report that there was no boundary + +bodyPartToInput :: BodyPart -> (String,Input) +bodyPartToInput (BodyPart hs b) = + case getContentDisposition hs of + Just (ContentDisposition "form-data" ps) -> + (lookupOrNil "name" ps, + Input { inputValue = b, + inputFilename = lookup "filename" ps, + inputContentType = ctype }) + _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error + where ctype = fromMaybe defaultInputType (getContentType hs) + + +-- +-- * Utilities +-- + +-- | Replaces all instances of a value in a list by another value. +replace :: Eq a => + a -- ^ Value to look for + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replace x y = map (\z -> if z == x then y else z) + +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads + +-- | Same as 'lookup' specialized to strings, but +-- returns the empty string if lookup fails. +lookupOrNil :: String -> [(String,String)] -> String +lookupOrNil n = fromMaybe "" . lookup n + diff --git a/Network/CGI/RFC822Headers.hs b/Network/CGI/RFC822Headers.hs new file mode 100644 --- /dev/null +++ b/Network/CGI/RFC822Headers.hs @@ -0,0 +1,264 @@ +-- #hide + +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.RFC822Headers +-- Copyright : (c) Peter Thiemann 2001,2002 +-- (c) Bjorn Bringert 2005-2006 +-- License : BSD-style +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable +-- +-- Parsing of RFC822-style headers (name, value pairs) +-- Partly based on code from WASHMail. +-- +----------------------------------------------------------------------------- +module Network.CGI.RFC822Headers ( + -- * Headers + Header, + pHeader, + pHeaders, + parseHeaders, + + -- * Content-type + ContentType(..), + getContentType, + parseContentType, + showContentType, + + -- * Content-transfer-encoding + ContentTransferEncoding(..), + getContentTransferEncoding, + parseContentTransferEncoding, + + -- * Content-disposition + ContentDisposition(..), + getContentDisposition, + parseContentDisposition, + + -- * Utilities + parseM) where + +import Data.Char +import Data.List +import Text.ParserCombinators.Parsec + +type Header = (String, String) + +pHeaders :: Parser [Header] +pHeaders = many pHeader + +parseHeaders :: Monad m => SourceName -> String -> m [Header] +parseHeaders s inp = parseM pHeaders s inp + +pHeader :: Parser Header +pHeader = + do name <- many1 headerNameChar + char ':' + many ws1 + line <- lineString + crLf + extraLines <- many extraFieldLine + return (map toLower name, concat (line:extraLines)) + +extraFieldLine :: Parser String +extraFieldLine = + do sp <- ws1 + line <- lineString + crLf + return (sp:line) + +-- +-- * Parameters (for Content-type etc.) +-- + +showParameters :: [(String,String)] -> String +showParameters = concatMap f + where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\"" + esc '\\' = "\\\\" + esc '"' = "\\\"" + esc c | c `elem` ['\\','"'] = '\\':[c] + | otherwise = [c] + +p_parameter :: Parser (String,String) +p_parameter = + do lexeme $ char ';' + p_name <- lexeme $ p_token + lexeme $ char '=' + -- Workaround for seemingly standardized web browser bug + -- where nothing is escaped in the filename parameter + -- of the content-disposition header in multipart/form-data + let litStr = if p_name == "filename" + then buggyLiteralString + else literalString + p_value <- litStr <|> p_token + return (map toLower p_name, p_value) + + +-- +-- * Content type +-- + +-- | A MIME media type value. +-- The 'Show' instance is derived automatically. +-- Use 'showContentType' to obtain the standard +-- string representation. +-- See for more +-- information about MIME media types. +data ContentType = + ContentType { + -- | The top-level media type, the general type + -- of the data. Common examples are + -- \"text\", \"image\", \"audio\", \"video\", + -- \"multipart\", and \"application\". + ctType :: String, + -- | The media subtype, the specific data format. + -- Examples include \"plain\", \"html\", + -- \"jpeg\", \"form-data\", etc. + ctSubtype :: String, + -- | Media type parameters. On common example is + -- the charset parameter for the \"text\" + -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@. + ctParamaters :: [(String, String)] + } + deriving (Show, Read, Eq, Ord) + +-- | Produce the standard string representation of a content-type, +-- e.g. \"text\/html; charset=ISO-8859-1\". +showContentType :: ContentType -> String +showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps + +pContentType :: Parser ContentType +pContentType = + do many ws1 + c_type <- p_token + lexeme $ char '/' + c_subtype <- lexeme $ p_token + c_parameters <- many p_parameter + return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters + +-- | Parse the standard representation of a content-type. +-- If the input cannot be parsed, this function calls +-- 'fail' with a (hopefully) informative error message. +parseContentType :: Monad m => String -> m ContentType +parseContentType = parseM pContentType "Content-type" + +getContentType :: Monad m => [Header] -> m ContentType +getContentType hs = lookupM "content-type" hs >>= parseContentType + +-- +-- * Content transfer encoding +-- + +data ContentTransferEncoding = + ContentTransferEncoding String + deriving (Show, Read, Eq, Ord) + +pContentTransferEncoding :: Parser ContentTransferEncoding +pContentTransferEncoding = + do many ws1 + c_cte <- p_token + return $ ContentTransferEncoding (map toLower c_cte) + +parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding +parseContentTransferEncoding = + parseM pContentTransferEncoding "Content-transfer-encoding" + +getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding +getContentTransferEncoding hs = + lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding + +-- +-- * Content disposition +-- + +data ContentDisposition = + ContentDisposition String [(String, String)] + deriving (Show, Read, Eq, Ord) + +pContentDisposition :: Parser ContentDisposition +pContentDisposition = + do many ws1 + c_cd <- p_token + c_parameters <- many p_parameter + return $ ContentDisposition (map toLower c_cd) c_parameters + +parseContentDisposition :: Monad m => String -> m ContentDisposition +parseContentDisposition = parseM pContentDisposition "Content-disposition" + +getContentDisposition :: Monad m => [Header] -> m ContentDisposition +getContentDisposition hs = + lookupM "content-disposition" hs >>= parseContentDisposition + +-- +-- * Utilities +-- + +parseM :: Monad m => Parser a -> SourceName -> String -> m a +parseM p n inp = + case parse p n inp of + Left e -> fail (show e) + Right x -> return x + +lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b +lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n + +-- +-- * Parsing utilities +-- + +-- | RFC 822 LWSP-char +ws1 :: Parser Char +ws1 = oneOf " \t" + +lexeme :: Parser a -> Parser a +lexeme p = do x <- p; many ws1; return x + +-- | RFC 822 CRLF (but more permissive) +crLf :: Parser String +crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r" + +-- | One line +lineString :: Parser String +lineString = many (noneOf "\n\r") + +literalString :: Parser String +literalString = do char '\"' + str <- many (noneOf "\"\\" <|> quoted_pair) + char '\"' + return str + +-- No web browsers seem to implement RFC 2046 correctly, +-- since they do not escape double quotes and backslashes +-- in the filename parameter in multipart/form-data. +-- +-- Note that this eats everything until the last double quote on the line. +buggyLiteralString :: Parser String +buggyLiteralString = + do char '\"' + str <- manyTill anyChar (try lastQuote) + return str + where lastQuote = do char '\"' + notFollowedBy (try (many (noneOf "\"") >> char '\"')) + +headerNameChar :: Parser Char +headerNameChar = noneOf "\n\r:" + +especials, tokenchar :: [Char] +especials = "()<>@,;:\\\"/[]?.=" +tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials + +p_token :: Parser String +p_token = many1 (oneOf tokenchar) + +text_chars :: [Char] +text_chars = map chr ([1..9] ++ [11,12] ++ [14..127]) + +p_text :: Parser Char +p_text = oneOf text_chars + +quoted_pair :: Parser Char +quoted_pair = do char '\\' + p_text diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple (defaultMainWithHooks, defaultUserHooks) + +main :: IO () +main = defaultMainWithHooks defaultUserHooks diff --git a/cgi.cabal b/cgi.cabal new file mode 100644 --- /dev/null +++ b/cgi.cabal @@ -0,0 +1,36 @@ +Name: cgi +Version: 3000.0.0 +Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, + Sven Panne, Jeremy Shaw +Maintainer: bjorn@bringert.net +Author: Bjorn Bringert +License: BSD3 +License-file: LICENSE +Build-depends: base >= 2.0, network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0 +Extensions: MultiParamTypeClasses +Synopsis: A library for writing CGI programs +Description: + This is a Haskell library for writing CGI programs. +Exposed-Modules: + Network.CGI, + Network.CGI.Monad, + Network.CGI.Protocol, + Network.CGI.Compat, + Network.CGI.Cookie +Other-modules: + Network.CGI.Multipart, + Network.CGI.RFC822Headers +ghc-options: -O2 -Wall + +--Executable: printinput +--Main-Is: printinput.hs +--Hs-Source-Dir: examples + +--Executable: redirect +--Main-Is: redirect.hs +--Hs-Source-Dir: examples + +--Executable: upload +--Main-Is: upload.hs +--Hs-Source-Dir: examples +