fastcgi 3000.0.0 → 3001.0.1
raw patch · 4 files changed
+103/−128 lines, 4 filesdep +bytestringdep ~basesetup-changed
Dependencies added: bytestring
Dependency ranges changed: base
Files
- Network/FastCGI.hsc +77/−113
- Setup.hs +0/−4
- Setup.lhs +7/−0
- fastcgi.cabal +19/−11
Network/FastCGI.hsc view
@@ -1,72 +1,79 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.FastCGI--- Copyright : (c) Bjorn Bringert 2004-2005+-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006 -- License : BSD-style (see the file libraries/network/LICENSE) -- --- Maintainer : bjorn@bringert.net+-- Maintainer : lemmih@gmail.com -- Stability : experimental -- Portability : non-portable (uses FFI) -- -- Interface for FastCGI <http://fastcgi.com/>, using the fcgiapp API. -- ------------------------------------------------------------------------------module Network.FastCGI ({-runFastCGIConcurrent,-}- runFastCGIorCGI, runOneFastCGIorCGI, - runFastCGI, runOneFastCGI,- module Network.CGI) where+module Network.FastCGI+ ( + -- * Single-threaded interface+ runFastCGIorCGI+ , runOneFastCGIorCGI+ , runFastCGI+ , runOneFastCGI+ -- * Concurrent interface+ , runFastCGIConcurrent+ , runFastCGIConcurrent'+ -- * Re-export+ , module Network.CGI+ ) where -import Control.Concurrent (forkOS)-import Control.Exception as Exception (catch, finally, throwIO)-import Control.Monad (when, liftM)+import Control.Concurrent ( forkOS )+import Control.Concurrent.MVar+import Control.Concurrent.QSem+import Control.Exception as Exception (catch, finally)+import Control.Monad ( liftM ) import Data.Word (Word8)-import Foreign ( Ptr, castPtr, nullPtr, plusPtr, peekArray0 - , alloca- , mallocBytes, free, throwIfNeg_, allocaBytes- , mallocArray, reallocArray, withForeignPtr)-import Foreign.C ( CInt, CString, CStringLen, CChar, withCStringLen- , peekCString, castCCharToChar )+import Foreign ( Ptr, castPtr, nullPtr, peekArray0 + , alloca, mallocBytes, free, throwIfNeg_)+import Foreign.C ( CInt, CString, CStringLen+ , peekCString ) import Foreign.Storable ( Storable (..) )-import System.IO.Unsafe (unsafeInterleaveIO)+import System.IO.Unsafe (unsafeInterleaveIO,unsafePerformIO) import Network.CGI import Network.CGI.Monad (runCGIT) import Network.CGI.Protocol (runCGIEnvFPS) import qualified Data.ByteString as BS-import qualified Data.ByteString.Base as BSB-import qualified Data.ByteString.Base as Lazy (LazyByteString(LPS)) import qualified Data.ByteString.Lazy.Char8 as Lazy+#if __GLASGOW_HASKELL__ >= 608+import qualified Data.ByteString.Internal as BSB+import qualified Data.ByteString.Unsafe as BSB+#else+import qualified Data.ByteString.Base as BSB+#endif -- For debugging-import Control.Concurrent (myThreadId)-import Prelude hiding (log)-import System.Mem (performGC)-import System.IO (hPutStrLn, stderr)+import Control.Concurrent ( myThreadId )+import Prelude hiding ( log, catch )+import System.IO ( hPutStrLn, stderr ) #include <fcgiapp.h> -data FCGX_Stream = FCGX_Stream+data FCGX_Stream type StreamPtr = Ptr FCGX_Stream type Environ = Ptr CString -foreign import ccall threadsafe "fcgiapp.h FCGX_IsCGI" fcgx_isCGI+foreign import ccall unsafe "fcgiapp.h FCGX_IsCGI" fcgx_isCGI :: IO CInt -foreign import ccall threadsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr+foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr :: CString -> CInt -> StreamPtr -> IO CInt -foreign import ccall threadsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr+foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr :: CString -> CInt -> StreamPtr -> IO CInt ------ This code uses the not MT safe functions of the fcgiapp API,--- to avoid getting intermittent SIGPIPEs. Dunno why that happens.-----foreign import ccall "fcgiapp.h FCGX_Accept" fcgx_accept+foreign import ccall threadsafe "fcgiapp.h FCGX_Accept" fcgx_accept :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt-foreign import ccall "fcgiapp.h FCGX_Finish" fcgx_finish+foreign import ccall unsafe "fcgiapp.h FCGX_Finish" fcgx_finish :: IO () -- | Handle a single CGI request, or FastCGI requests in an infinite loop.@@ -76,7 +83,7 @@ -- treats it as. runFastCGIorCGI :: CGI CGIResult -> IO () runFastCGIorCGI f = do fcgi <- runOneFastCGIorCGI f- if fcgi then performGC >> runFastCGIorCGI f+ if fcgi then runFastCGIorCGI f else return () -- | Handle a single FastCGI or CGI request. This lets you use the same program@@ -92,7 +99,7 @@ -- | Handle FastCGI requests in an infinite loop. runFastCGI :: CGI CGIResult -> IO ()-runFastCGI f = runOneFastCGI f >> performGC >> runFastCGI f+runFastCGI f = runOneFastCGI f >> runFastCGI f -- | Handle a single FastCGI request. runOneFastCGI :: CGI CGIResult -> IO ()@@ -125,7 +132,7 @@ -> StreamPtr -> Environ -> IO ()-handleRequest f ins outs errs env =+handleRequest f ins outs _errs env = do vars <- environToTable env input <- sRead ins@@ -134,129 +141,87 @@ ------ The following code uses the MT safe fcgiapp API,--- but causes mod_fastcgi to get SIGPIPE once in a while.-----{---data FCGX_Request = FCGX_Request+data FCGX_Request -foreign import ccall threadsafe "fcgiapp.h FCGX_Init" fcgx_init+foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init :: IO CInt -foreign import ccall threadsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest+foreign import ccall unsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest :: Ptr FCGX_Request -> CInt -> CInt -> IO CInt foreign import ccall threadsafe "fcgiapp.h FCGX_Accept_r" fcgx_accept_r :: Ptr FCGX_Request -> IO CInt -foreign import ccall threadsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r+foreign import ccall unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r :: Ptr FCGX_Request -> IO () --- | Like 'Network.NewCGI.runCGI', but uses the FastCGI interface.-runFastCGI :: CGI CGIResult -> IO ()-runFastCGI = runFastCGI' id---- | Like 'Network.NewCGI.runCGI', but uses the FastCGI interface+-- | Like 'Network.CGI.runCGI', but uses the FastCGI interface -- and forks off a new thread (using 'forkOS') for every request.-runFastCGIConcurrent :: CGI CGIResult -> IO ()-runFastCGIConcurrent = runFastCGI' fork- where fork m = do- t <- forkOS m- log $ "Created child: " ++ show t+runFastCGIConcurrent :: Int -- ^ Max number of concurrent threads.+ -> CGI CGIResult -> IO ()+runFastCGIConcurrent = runFastCGIConcurrent' forkOS -runFastCGI' :: (IO () -> IO a) -> CGI CGIResult -> IO ()-runFastCGI' fork f = do- log "Calling FCGX_Init"- testReturn "FCGX_Init" $ fcgx_init- loop- where - loop = do- reqp <- acceptRequest- log "Forking"- fork (oneRequest f reqp `finally` finishRequest reqp)- loop+runFastCGIConcurrent' :: (IO () -> IO a) -- ^ How to fork a request.+ -> Int -- ^ Max number of concurrent threads.+ -> CGI CGIResult -> IO ()+runFastCGIConcurrent' fork m f+ = do qsem <- newQSem m+ testReturn "FCGX_Init" $ fcgx_init+ let loop = do waitQSem qsem+ reqp <- acceptRequest+ fork (oneRequestMT f reqp `finally` (finishRequest reqp >> signalQSem qsem))+ loop+ loop `catch` \e -> log (show e) -oneRequest :: CGI CGIResult -> Ptr FCGX_Request -> IO ()-oneRequest f r = do+oneRequestMT :: CGI CGIResult -> Ptr FCGX_Request -> IO ()+oneRequestMT f r = do env <- peekEnvp r vars <- environToTable env ins <- peekIn r- input <- sStrictRead ins- log "Running CGI action"- output <- runCGIEnv vars input f+ input <- sRead ins+ output <- runCGIEnvFPS vars input (runCGIT f) outs <- peekOut r- log "Returning output" sPutStr outs output- -- -- * FCGX_Reqest struct -- acceptRequest :: IO (Ptr FCGX_Request) acceptRequest = do- log "Allocating FCGX_Request" reqp <- mallocBytes (#size FCGX_Request)- initAndAccept reqp `onError` free reqp+ initAndAccept reqp return reqp where initAndAccept reqp = do - log "Calling FCGX_InitRequest" testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0- log "Calling FCGX_Accept_r" testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp finishRequest :: Ptr FCGX_Request -> IO () finishRequest reqp = do- log "Calling FCGX_Finish_r" fcgx_finish_r reqp- log "Freeing FCGX_Request" free reqp -peekIn, peekOut, peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)+peekIn, peekOut, _peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream) peekIn = (#peek FCGX_Request, in) peekOut = (#peek FCGX_Request, out)-peekErr = (#peek FCGX_Request, err)+_peekErr = (#peek FCGX_Request, err) peekEnvp :: Ptr FCGX_Request -> IO Environ peekEnvp = (#peek FCGX_Request, envp) --} -- -- * Stream IO -- sPutStr :: StreamPtr -> Lazy.ByteString -> IO ()-sPutStr h (Lazy.LPS strs) = - mapM_ (flip BSB.unsafeUseAsCStringLen (fcgxPutCStringLen h)) strs+sPutStr h str = + mapM_ (flip BSB.unsafeUseAsCStringLen (fcgxPutCStringLen h)) (Lazy.toChunks str) fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO () fcgxPutCStringLen h (cs,len) = testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h -{---- Based on Data.FastPackedString.hGetContents-sRead :: StreamPtr -> IO BS.ByteString-sRead h = do - let start_size = 1024- p <- mallocArray start_size- i <- fcgx_getStr p start_size h- if i < start_size- then liftM BS.packMallocCString $ reallocArray p i- else f p start_size- where - f p s = do - let s' = 2 * s- p' <- reallocArray p s'- i <- fcgx_getStr (p' `plusPtr` s) s h- if i < s - then liftM BS.packMallocCString $ reallocArray p' (s + i)- else f p' s'--}- sRead :: StreamPtr -> IO Lazy.ByteString sRead h = buildByteString (fcgxGetBuf h) 4096 @@ -271,7 +236,7 @@ -- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary -- reading functions. buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO Lazy.ByteString-buildByteString f k = lazyRead >>= return . Lazy.LPS+buildByteString f k = lazyRead >>= return . Lazy.fromChunks where lazyRead = unsafeInterleaveIO $ do ps <- BSB.createAndTrim k $ \p -> f p k@@ -285,11 +250,6 @@ -- * Utilities -- --- | Run some action if the first action throws an exception.--- The exception is re-thrown.-onError :: IO a -> IO () -> IO a-onError f h = f `Exception.catch` (\e -> h >> throwIO e)- testReturn :: String -> IO CInt -> IO () testReturn e = throwIfNeg_ (const $ e ++ " failed") @@ -311,7 +271,11 @@ -- * Debugging -- +{-# NOINLINE logMutex #-}+logMutex :: MVar ()+logMutex = unsafePerformIO (newMVar ())+ log :: String -> IO () log msg = do t <- myThreadId- hPutStrLn stderr (show t ++ ": " ++ msg)+ withMVar logMutex (const $ hPutStrLn stderr (show t ++ ": " ++ msg))
− Setup.hs
@@ -1,4 +0,0 @@-#!/usr/bin/env runghc--import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runghc++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
fastcgi.cabal view
@@ -1,17 +1,25 @@ Name: fastcgi-Version: 3000.0.0-Copyright: Bjorn Bringert-Maintainer: bjorn@bringert.net-Author: Bjorn Bringert-Homepage: http://www.cs.chalmers.se/~bringert/darcs/haskell-fastcgi/doc/+Version: 3001.0.1+Copyright: Bjorn Bringert, Lemmih+Maintainer: lemmih@gmail.com License: BSD3-build-depends: base>=2.0, cgi >= 3000.0.0-Extensions: ForeignFunctionInterface Synopsis: A Haskell library for writing FastCGI programs Description: This library lets you write FastCGI programs. This package reuses the cgi package API, making it very easy to port CGI programs to FastCGI.-Exposed-Modules: - Network.FastCGI-ghc-options: -O2-extra-libraries: fcgi+Cabal-version: >= 1.2.0++flag small_base+ description: Choose the new smaller, split-up base package.++library+ build-depends: cgi >= 3000.0.0+ if flag(small_base)+ build-depends: base >= 3.0.0.0, bytestring >= 0.9.0.1+ else+ build-depends: base >= 2.0+ Extensions: ForeignFunctionInterface, EmptyDataDecls+ Exposed-Modules: + Network.FastCGI+ ghc-options: -O2 -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches+ extra-libraries: fcgi