fastcgi (empty) → 3000.0.0

raw patch · 3 files changed

+338/−0 lines, 3 filesdep +basedep +cgibuild-type:Customsetup-changed

Dependencies added: base, cgi

Files

Network/FastCGI.hsc +317/−0
Setup.hs +4/−0
fastcgi.cabal +17/−0

+ Network/FastCGI.hsc view

@@ -0,0 +1,317 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.FastCGI+-- Copyright   :  (c) Bjorn Bringert 2004-2005+-- License     :  BSD-style (see the file libraries/network/LICENSE)+-- +-- Maintainer  :  bjorn@bringert.net+-- 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++import Control.Concurrent (forkOS)+import Control.Exception as Exception (catch, finally, throwIO)+import Control.Monad (when, 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.Storable ( Storable (..) )+import System.IO.Unsafe (unsafeInterleaveIO)++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++-- For debugging+import Control.Concurrent (myThreadId)+import Prelude hiding (log)+import System.Mem (performGC)+import System.IO (hPutStrLn, stderr)++#include <fcgiapp.h>++data FCGX_Stream = FCGX_Stream+type StreamPtr = Ptr FCGX_Stream+type Environ = Ptr CString++foreign import ccall threadsafe "fcgiapp.h FCGX_IsCGI" fcgx_isCGI+    :: IO CInt++foreign import ccall threadsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr+    :: CString -> CInt -> StreamPtr -> IO CInt++foreign import ccall threadsafe "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+    :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt+foreign import ccall "fcgiapp.h FCGX_Finish" fcgx_finish+    :: IO ()++-- | Handle a single CGI request, or FastCGI requests in an infinite loop.+--   This function only returns normally if it was a CGI request.+--   This lets you use the same program+--   as either a FastCGI or CGI program, depending on what the server +--   treats it as.+runFastCGIorCGI :: CGI CGIResult -> IO ()+runFastCGIorCGI f = do fcgi <- runOneFastCGIorCGI f+                       if fcgi then performGC >> runFastCGIorCGI f+                               else return ()++-- | Handle a single FastCGI or CGI request. This lets you use the same program+--   as either a FastCGI or CGI program, depending on what the server +--   treats it as.+runOneFastCGIorCGI :: CGI CGIResult +                   -> IO Bool -- ^ True if it was a FastCGI request, +                              --   False if CGI.+runOneFastCGIorCGI f =+    do x <- fcgx_isCGI+       if x /= 0 then runCGI f >> return False+                 else runOneFastCGI f >> return True++-- | Handle FastCGI requests in an infinite loop.+runFastCGI :: CGI CGIResult -> IO ()+runFastCGI f = runOneFastCGI f >> performGC >> runFastCGI f++-- | Handle a single FastCGI request.+runOneFastCGI :: CGI CGIResult -> IO ()+runOneFastCGI f = do+    alloca (\inp ->+            alloca (\outp ->+                    alloca (\errp ->+                            alloca (\envp ->+                                    oneRequest f inp outp errp envp))))++oneRequest :: CGI CGIResult+           -> Ptr StreamPtr+           -> Ptr StreamPtr+           -> Ptr StreamPtr+           -> Ptr Environ+           -> IO ()+oneRequest f inp outp errp envp =+    do+    testReturn "FCGX_Accept" $ fcgx_accept inp outp errp envp+    ins  <- peek inp+    outs <- peek outp+    errs <- peek errp+    env  <- peek envp+    handleRequest f ins outs errs env+    fcgx_finish++handleRequest :: CGI CGIResult+              -> StreamPtr+              -> StreamPtr+              -> StreamPtr+              -> Environ+              -> IO ()+handleRequest f ins outs errs env =+    do+    vars <- environToTable env+    input <- sRead ins+    output <- runCGIEnvFPS vars input (runCGIT f)+    sPutStr outs output++++--+-- 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++foreign import ccall threadsafe "fcgiapp.h FCGX_Init" fcgx_init+    :: IO CInt++foreign import ccall threadsafe "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+    :: 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+--   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++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++oneRequest :: CGI CGIResult -> Ptr FCGX_Request -> IO ()+oneRequest f r = do+		 env <- peekEnvp r+		 vars <- environToTable env+		 ins <- peekIn r+		 input <- sStrictRead ins+		 log "Running CGI action"+		 output <- runCGIEnv vars input 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+		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  = (#peek FCGX_Request, in)+peekOut = (#peek FCGX_Request, out)+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++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++fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int+fcgxGetBuf h p c = +    liftM fromIntegral $ fcgx_getStr (castPtr p) (fromIntegral c) h++--+-- * ByteString utilities+--++-- | 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+  where+    lazyRead = unsafeInterleaveIO $ do+        ps <- BSB.createAndTrim k $ \p -> f p k+        case BS.length ps of+            0         -> return []+            n | n < k -> return [ps]+            _         -> do pss <- lazyRead+                            return (ps : pss)++--+-- * 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")++environToTable :: Environ -> IO [(String,String)]+environToTable arr = +    do css <- peekArray0 nullPtr arr+       ss <- mapM peekCString css+       return $ map (splitBy '=') ss++-- | Split a list at the first occurence of a marker.+--   Do not include the marker in any of the resulting lists.+--   If the marker does not occur in the list, the entire+--   input with be in the first list.+splitBy :: Eq a => a -> [a] -> ([a],[a])+splitBy x xs = (y, drop 1 z)+    where (y,z) = break (==x) xs++--+-- * Debugging+--++log :: String -> IO ()+log msg = do+	  t <- myThreadId+	  hPutStrLn stderr (show t ++ ": " ++ msg)

+ Setup.hs view

@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain

+ fastcgi.cabal view

@@ -0,0 +1,17 @@+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/+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