diff --git a/Network/CGI.hs b/Network/CGI.hs --- a/Network/CGI.hs +++ b/Network/CGI.hs @@ -61,7 +61,7 @@ -- * Input , getInput, getInputFPS, readInput , getInputs, getInputNames - , getMultiInput + , getMultiInput, getMultiInputFPS , getInputFilename, getInputContentType -- * Environment , getVar, getVarWithDefault, getVars @@ -83,6 +83,8 @@ , setCookie, deleteCookie -- * URL encoding , formEncode, urlEncode, formDecode, urlDecode + -- * Compatibility with the old API + , module Network.CGI.Compat ) where import Control.Exception (Exception(..)) @@ -106,6 +108,7 @@ 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) @@ -479,8 +482,15 @@ 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] +getMultiInput = liftM (map BS.unpack) . getMultiInputFPS + +-- | Same as 'getMultiInput' but using 'ByteString's. +getMultiInputFPS :: MonadCGI m => + String -- ^ The name of the variable. + -> m [ByteString] -- ^ The values of the variable, + -- or the empty list if the variable was not set. +getMultiInputFPS n = do is <- cgiGet cgiInputs + return [inputValue v | (p,v) <- is, p == n] -- | Get the file name of an input. getInputFilename :: MonadCGI m => 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/cgi.cabal b/cgi.cabal --- a/cgi.cabal +++ b/cgi.cabal @@ -1,5 +1,5 @@ Name: cgi -Version: 3001.1.5.1 +Version: 3001.1.5.2 Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw Maintainer: bjorn@bringert.net @@ -20,7 +20,8 @@ Network.CGI, Network.CGI.Monad, Network.CGI.Protocol, - Network.CGI.Cookie + Network.CGI.Cookie, + Network.CGI.Compat Other-modules: Network.CGI.Multipart, Network.CGI.RFC822Headers