From bf6dd145b9440363552e245fe2c9b411a6de28d0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 May 2010 14:00:54 +0300 Subject: [PATCH 01/18] initial commit --- README | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 README diff --git a/README b/README new file mode 100644 index 00000000..e69de29b From 4c3d8d727d6c73e5e297839f0d3dbb47f8f3fae2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 May 2010 17:02:51 +0300 Subject: [PATCH 02/18] Initial working version --- LICENSE | 25 +++++++++ Network/Wai/Handler/FastCGI.hs | 100 +++++++++++++++++++++++++++++++++ test.hs | 8 +++ wai-handler-fastcgi.cabal | 25 +++++++++ 4 files changed, 158 insertions(+) create mode 100644 LICENSE create mode 100644 Network/Wai/Handler/FastCGI.hs create mode 100644 test.hs create mode 100644 wai-handler-fastcgi.cabal diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..81e3ec6a --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2009, Michael Snoyman. 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 COPYRIGHT HOLDERS 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/Wai/Handler/FastCGI.hs b/Network/Wai/Handler/FastCGI.hs new file mode 100644 index 00000000..3250788c --- /dev/null +++ b/Network/Wai/Handler/FastCGI.hs @@ -0,0 +1,100 @@ +module Network.Wai.Handler.FastCGI + ( run + ) where + +import qualified Network.Wai as W +import Network.FastCGI +import Control.Concurrent (forkIO) +import Control.Monad.Trans +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B +import qualified System.IO +import Control.Arrow ((***)) +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Network.Wai.Enumerator (fromEitherFile) + +run :: W.Application -> IO () +run = acceptLoop forkIO . conv + +safeRead :: Read a => a -> String -> a +safeRead d s = + case reads s of + ((x, _):_) -> x + [] -> d + +lookup' :: String -> [(String, String)] -> String +lookup' key pairs = fromMaybe "" $ lookup key pairs + +conv :: W.Application -> FastCGI () +conv app = do + vars <- getAllRequestVariables + let rmethod = W.methodFromBS $ B.pack $ lookup' "REQUEST_METHOD" vars + pinfo = lookup' "PATH_INFO" vars + qstring = lookup' "QUERY_STRING" vars + servername = lookup' "SERVER_NAME" vars + serverport = safeRead 80 $ lookup' "SERVER_PORT" vars + contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars + remoteHost' = + case lookup "REMOTE_HOST" vars of + Just x -> x + Nothing -> + case lookup "REMOTE_ADDR" vars of + Just x -> x + Nothing -> "" + urlScheme' = + case map toLower $ lookup' "SERVER_PROTOCOL" vars of -- FIXME get httpVersion too + "https" -> W.HTTPS + _ -> W.HTTP + state <- ask + let env = W.Request + { W.requestMethod = rmethod + , W.pathInfo = B.pack pinfo + , W.queryString = B.pack qstring + , W.serverName = B.pack servername + , W.serverPort = serverport + , W.requestHeaders = map (cleanupVarName *** B.pack) vars + , W.urlScheme = urlScheme' + , W.requestBody = requestBody state contentLength + , W.errorHandler = System.IO.hPutStr System.IO.stderr + , W.remoteHost = B.pack remoteHost' + , W.httpVersion = W.HttpVersion B.empty + } + res <- liftIO $ app env + setResponseStatus $ W.statusCode $ W.status res + mapM_ setHeader $ W.responseHeaders res + _ <- liftIO $ W.runEnumerator + (fromEitherFile (W.responseBody res)) + (myPut state) + () + return () + +cleanupVarName :: String -> W.RequestHeader +cleanupVarName ('H':'T':'T':'P':'_':a:as) = + W.requestHeaderFromBS $ B.pack $ a : helper' as where + helper' ('_':x:rest) = '-' : x : helper' rest + helper' (x:rest) = toLower x : helper' rest + helper' [] = [] +cleanupVarName "CONTENT_TYPE" = W.ReqContentType +cleanupVarName "CONTENT_LENGTH" = W.ReqContentLength +cleanupVarName "SCRIPT_NAME" = W.requestHeaderFromBS $ B.pack "CGI-Script-Name" +cleanupVarName x = W.requestHeaderFromBS $ B.pack x -- FIXME remove? + +requestBody :: FastCGIState -> Int -> W.Source +requestBody _ 0 = W.Source $ return Nothing +requestBody state len = W.Source $ do + bs <- runReaderT (fGet defaultChunkSize) state + let newLen = len - B.length bs + return $ Just (bs, requestBody state newLen) + +setHeader :: MonadFastCGI m => (W.ResponseHeader, B.ByteString) -> m () +setHeader (k, v) = + setResponseHeader + (HttpExtensionHeader $ B.unpack $ W.responseHeaderToBS k) + (B.unpack v) + +myPut :: FastCGIState -> () -> B.ByteString -> IO (Either () ()) +myPut state _ bs = do + runReaderT (fPut bs) state + return $ Right () diff --git a/test.hs b/test.hs new file mode 100644 index 00000000..5cac0001 --- /dev/null +++ b/test.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} +import Yesod +import Network.Wai.Handler.FastCGI +data HelloWorld = HelloWorld +mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] +instance Yesod HelloWorld where approot _ = "" +getHome = return $ RepPlain $ cs "Hello World!" +main = toWaiApp HelloWorld >>= run diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal new file mode 100644 index 00000000..e7976271 --- /dev/null +++ b/wai-handler-fastcgi.cabal @@ -0,0 +1,25 @@ +name: wai-handler-fastcgi +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: WAI wrapper around direct-fastcgi +category: Web +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://github.com/snoyberg/wai-handler-fastcgi + +library + build-depends: base >= 4 && < 5, + wai >= 0.0.1 && < 0.1, + bytestring >= 0.9.1.4 && < 0.10, + mtl >= 1.1.0.2 && < 1.2, + direct-fastcgi >= 1.0.1.1 && < 1.1 + exposed-modules: Network.Wai.Handler.FastCGI + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/snoyberg/wai-handler-fastcgi.git From 5b9c913dc286b16f1b6ef6e6da8440853c22d419 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 May 2010 17:32:46 +0300 Subject: [PATCH 03/18] Added Setup.lhs --- Setup.lhs | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100755 Setup.lhs diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain From f45760c0c40168b2c256bae3e1c2434e2e80f81e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 10 May 2010 10:29:58 +0300 Subject: [PATCH 04/18] Avoid double-sending Content-Type header --- Network/Wai/Handler/FastCGI.hs | 7 ++++++- wai-handler-fastcgi.cabal | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hs b/Network/Wai/Handler/FastCGI.hs index 3250788c..e7397f8c 100644 --- a/Network/Wai/Handler/FastCGI.hs +++ b/Network/Wai/Handler/FastCGI.hs @@ -91,8 +91,13 @@ requestBody state len = W.Source $ do setHeader :: MonadFastCGI m => (W.ResponseHeader, B.ByteString) -> m () setHeader (k, v) = setResponseHeader - (HttpExtensionHeader $ B.unpack $ W.responseHeaderToBS k) + k' (B.unpack v) + where + k' + | k == W.ContentType = HttpContentType -- avoid double-sent c-type + | otherwise = HttpExtensionHeader $ B.unpack $ W.responseHeaderToBS k + myPut :: FastCGIState -> () -> B.ByteString -> IO (Either () ()) myPut state _ bs = do diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index e7976271..e4ff2392 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.0.0 +version: 0.0.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From 9207718b8e884a27846d837d80868970fb55f184 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 20 May 2010 23:10:43 +0300 Subject: [PATCH 05/18] Bumped wai version --- wai-handler-fastcgi.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index e4ff2392..1f693725 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.0.0.1 +version: 0.0.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -13,7 +13,7 @@ homepage: http://github.com/snoyberg/wai-handler-fastcgi library build-depends: base >= 4 && < 5, - wai >= 0.0.1 && < 0.1, + wai >= 0.0.1 && < 0.2, bytestring >= 0.9.1.4 && < 0.10, mtl >= 1.1.0.2 && < 1.2, direct-fastcgi >= 1.0.1.1 && < 1.1 From 78da029099ee8b4e454f88aae207ecb723213a99 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 20 May 2010 23:11:37 +0300 Subject: [PATCH 06/18] Added .gitignore --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..f0ddcddc --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +/dist/ +*.swp +*.hi +*.o From ca64674de3934ae8dd9a612487596db0cd049781 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 25 May 2010 08:59:21 +0300 Subject: [PATCH 07/18] Port to the C library via hack-handler-fastcgi --- LICENSE | 2 +- Network/Wai/Handler/FastCGI.hs | 105 --------- Network/Wai/Handler/FastCGI.hsc | 392 ++++++++++++++++++++++++++++++++ configure | 9 + fastcgi.buildinfo.in | 3 + test.hs | 8 - wai-handler-fastcgi.cabal | 26 +-- 7 files changed, 417 insertions(+), 128 deletions(-) delete mode 100644 Network/Wai/Handler/FastCGI.hs create mode 100644 Network/Wai/Handler/FastCGI.hsc create mode 100644 configure create mode 100644 fastcgi.buildinfo.in delete mode 100644 test.hs diff --git a/LICENSE b/LICENSE index 81e3ec6a..8643e5d8 100644 --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2009, Michael Snoyman. All rights reserved. +Copyright 2010, Michael Snoyman. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/Network/Wai/Handler/FastCGI.hs b/Network/Wai/Handler/FastCGI.hs deleted file mode 100644 index e7397f8c..00000000 --- a/Network/Wai/Handler/FastCGI.hs +++ /dev/null @@ -1,105 +0,0 @@ -module Network.Wai.Handler.FastCGI - ( run - ) where - -import qualified Network.Wai as W -import Network.FastCGI -import Control.Concurrent (forkIO) -import Control.Monad.Trans -import Control.Monad.Reader -import qualified Data.ByteString.Char8 as B -import qualified System.IO -import Control.Arrow ((***)) -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Network.Wai.Enumerator (fromEitherFile) - -run :: W.Application -> IO () -run = acceptLoop forkIO . conv - -safeRead :: Read a => a -> String -> a -safeRead d s = - case reads s of - ((x, _):_) -> x - [] -> d - -lookup' :: String -> [(String, String)] -> String -lookup' key pairs = fromMaybe "" $ lookup key pairs - -conv :: W.Application -> FastCGI () -conv app = do - vars <- getAllRequestVariables - let rmethod = W.methodFromBS $ B.pack $ lookup' "REQUEST_METHOD" vars - pinfo = lookup' "PATH_INFO" vars - qstring = lookup' "QUERY_STRING" vars - servername = lookup' "SERVER_NAME" vars - serverport = safeRead 80 $ lookup' "SERVER_PORT" vars - contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars - remoteHost' = - case lookup "REMOTE_HOST" vars of - Just x -> x - Nothing -> - case lookup "REMOTE_ADDR" vars of - Just x -> x - Nothing -> "" - urlScheme' = - case map toLower $ lookup' "SERVER_PROTOCOL" vars of -- FIXME get httpVersion too - "https" -> W.HTTPS - _ -> W.HTTP - state <- ask - let env = W.Request - { W.requestMethod = rmethod - , W.pathInfo = B.pack pinfo - , W.queryString = B.pack qstring - , W.serverName = B.pack servername - , W.serverPort = serverport - , W.requestHeaders = map (cleanupVarName *** B.pack) vars - , W.urlScheme = urlScheme' - , W.requestBody = requestBody state contentLength - , W.errorHandler = System.IO.hPutStr System.IO.stderr - , W.remoteHost = B.pack remoteHost' - , W.httpVersion = W.HttpVersion B.empty - } - res <- liftIO $ app env - setResponseStatus $ W.statusCode $ W.status res - mapM_ setHeader $ W.responseHeaders res - _ <- liftIO $ W.runEnumerator - (fromEitherFile (W.responseBody res)) - (myPut state) - () - return () - -cleanupVarName :: String -> W.RequestHeader -cleanupVarName ('H':'T':'T':'P':'_':a:as) = - W.requestHeaderFromBS $ B.pack $ a : helper' as where - helper' ('_':x:rest) = '-' : x : helper' rest - helper' (x:rest) = toLower x : helper' rest - helper' [] = [] -cleanupVarName "CONTENT_TYPE" = W.ReqContentType -cleanupVarName "CONTENT_LENGTH" = W.ReqContentLength -cleanupVarName "SCRIPT_NAME" = W.requestHeaderFromBS $ B.pack "CGI-Script-Name" -cleanupVarName x = W.requestHeaderFromBS $ B.pack x -- FIXME remove? - -requestBody :: FastCGIState -> Int -> W.Source -requestBody _ 0 = W.Source $ return Nothing -requestBody state len = W.Source $ do - bs <- runReaderT (fGet defaultChunkSize) state - let newLen = len - B.length bs - return $ Just (bs, requestBody state newLen) - -setHeader :: MonadFastCGI m => (W.ResponseHeader, B.ByteString) -> m () -setHeader (k, v) = - setResponseHeader - k' - (B.unpack v) - where - k' - | k == W.ContentType = HttpContentType -- avoid double-sent c-type - | otherwise = HttpExtensionHeader $ B.unpack $ W.responseHeaderToBS k - - -myPut :: FastCGIState -> () -> B.ByteString -> IO (Either () ()) -myPut state _ bs = do - runReaderT (fPut bs) state - return $ Right () diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc new file mode 100644 index 00000000..f73fdf12 --- /dev/null +++ b/Network/Wai/Handler/FastCGI.hsc @@ -0,0 +1,392 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.Wai.Handler.FastCGI +-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006 +-- License : BSD-style (see the file libraries/network/LICENSE) +-- +-- Maintainer : michael@snoyman.com +-- Stability : experimental +-- Portability : non-portable (uses FFI) +-- +-- Interface for FastCGI , using the fcgiapp API. +-- Totally ripped off by Michael Snoyman to work with Hack, then WAI. +-- +----------------------------------------------------------------------------- +module Network.Wai.Handler.FastCGI + ( + -- * Single-threaded interface + runFastCGIorCGI + , runOneFastCGIorCGI + , runFastCGI + , runOneFastCGI + -- * Concurrent interface + , runFastCGIConcurrent + , runFastCGIConcurrent' + ) where + +import Data.Maybe +import Data.ByteString.Lazy.Internal (defaultChunkSize) +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, peekArray0 + , alloca, mallocBytes, free, throwIfNeg_) +import Foreign.C ( CInt, CString, CStringLen + , peekCString ) +import Foreign.Storable ( Storable (..) ) +import System.IO.Unsafe (unsafeInterleaveIO,unsafePerformIO) + +import qualified Network.Wai as W +import qualified Network.Wai.Enumerator as WE +import qualified Network.Wai.Source as WS +import qualified Network.Wai.Handler.CGI as CGI + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +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, catch ) +import System.IO ( hPutStrLn, stderr ) +import qualified System.IO +import Control.Arrow ((***)) +import Data.Char (toLower) + +#include + +------------------------------------------------------------------------ + +data FCGX_Stream +type StreamPtr = Ptr FCGX_Stream +type Environ = Ptr CString + +------------------------------------------------------------------------ + +foreign import ccall unsafe "fcgiapp.h FCGX_IsCGI" fcgx_isCGI + :: IO CInt + +foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr + :: CString -> CInt -> StreamPtr -> IO CInt + +foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr + :: CString -> CInt -> StreamPtr -> IO CInt + +foreign import ccall threadsafe "fcgiapp.h FCGX_Accept" fcgx_accept + :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt +foreign import ccall unsafe "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 :: W.Application -> IO () +runFastCGIorCGI f = do fcgi <- runOneFastCGIorCGI f + if fcgi then 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 :: W.Application + -> IO Bool -- ^ True if it was a FastCGI request, + -- False if CGI. +runOneFastCGIorCGI f = + do x <- fcgx_isCGI + if x /= 0 then CGI.run f >> return False + else runOneFastCGI f >> return True + +-- | Handle FastCGI requests in an infinite loop. +runFastCGI :: W.Application -> IO () +runFastCGI f = runOneFastCGI f >> runFastCGI f + +-- | Handle a single FastCGI request. +runOneFastCGI :: W.Application -> IO () +runOneFastCGI f = do + alloca (\inp -> + alloca (\outp -> + alloca (\errp -> + alloca (\envp -> + oneRequest f inp outp errp envp)))) + +oneRequest :: W.Application + -> 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 :: W.Application + -> StreamPtr + -> StreamPtr + -> StreamPtr + -> Environ + -> IO () +handleRequest f ins outs _errs env = + do + vars <- environToTable env + input <- sRead ins + let hPut = sPutStr' outs + run' vars input hPut f + + + +data FCGX_Request + +foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init + :: IO CInt + +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 unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r + :: Ptr FCGX_Request -> IO () + +-- | Like 'Network.CGI.runCGI', but uses the FastCGI interface +-- and forks off a new thread (using 'forkOS') for every request. +runFastCGIConcurrent :: Int -- ^ Max number of concurrent threads. + -> W.Application -> IO () +runFastCGIConcurrent = runFastCGIConcurrent' forkOS + +runFastCGIConcurrent' :: (IO () -> IO a) -- ^ How to fork a request. + -> Int -- ^ Max number of concurrent threads. + -> W.Application -> 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 -- FIXME `catch` \e -> log (show e) + +oneRequestMT :: W.Application -> Ptr FCGX_Request -> IO () +oneRequestMT app r = do + env <- peekEnvp r + vars <- environToTable env + ins <- peekIn r + input <- sRead ins + outs <- peekOut r + let hPut = sPutStr' outs + run' vars input hPut app +-- +-- * FCGX_Reqest struct +-- + +acceptRequest :: IO (Ptr FCGX_Request) +acceptRequest = do + reqp <- mallocBytes (#size FCGX_Request) + initAndAccept reqp + return reqp + where initAndAccept reqp = do + testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0 + testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp + +finishRequest :: Ptr FCGX_Request -> IO () +finishRequest reqp = do + fcgx_finish_r reqp + 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 -> BS.ByteString -> IO () +sPutStr' h str = + BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h + +sPutStr :: StreamPtr -> Lazy.ByteString -> IO () +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 + +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.fromChunks + 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 +-- + +testReturn :: String -> IO CInt -> IO () +testReturn e = throwIfNeg_ (\n -> e ++ " failed with error code: "++ show n) + +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 +-- + +{-# NOINLINE logMutex #-} +logMutex :: MVar () +logMutex = unsafePerformIO (newMVar ()) + +log :: String -> IO () +log msg = do + t <- myThreadId + withMVar logMutex (const $ hPutStrLn stderr (show t ++ ": " ++ msg)) + +run' :: [(String, String)] -- ^ all variables + -> Lazy.ByteString -- ^ responseBody of input + -> (BS.ByteString -> IO ()) -- ^ destination for output + -> W.Application + -> IO () +run' vars inputH hPut app = do + let rmethod = safeRead W.GET $ lookup' "REQUEST_METHOD" vars + pinfo = lookup' "PATH_INFO" vars + qstring = lookup' "QUERY_STRING" vars + servername = lookup' "SERVER_NAME" vars + serverport = safeRead 80 $ lookup' "SERVER_PORT" vars + contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars + remoteHost' = + case lookup "REMOTE_HOST" vars of + Just x -> x + Nothing -> + case lookup "REMOTE_ADDR" vars of + Just x -> x + Nothing -> "" + urlScheme' = + case map toLower $ lookup' "SERVER_PROTOCOL" vars of + "https" -> W.HTTPS + _ -> W.HTTP + let env = W.Request + { W.requestMethod = rmethod + , W.pathInfo = B8.pack pinfo + , W.queryString = B8.pack qstring + , W.serverName = B8.pack servername + , W.serverPort = serverport + , W.requestHeaders = map (cleanupVarName *** B8.pack) vars + , W.urlScheme = urlScheme' + , W.requestBody = requestBodyLBS inputH contentLength + , W.errorHandler = System.IO.hPutStr System.IO.stderr + , W.remoteHost = B8.pack remoteHost' + , W.httpVersion = W.HttpVersion BS.empty + } + res <- app env + let h = W.responseHeaders res + let h' = case lookup W.ContentType h of + Nothing -> (W.ContentType, B8.pack "text/html; charset=utf-8") + : h + Just _ -> h + hPut $ B8.pack $ "Status: " ++ (show $ W.statusCode $ W.status res) ++ " " + hPut $ W.statusMessage $ W.status res + hPut $ B8.singleton '\n' + mapM_ (printHeader hPut) h' + hPut $ B8.singleton '\n' + _ <- W.runEnumerator (WE.fromEitherFile (W.responseBody res)) (myPut hPut) () + return () + +myPut :: (BS.ByteString -> IO ()) -> () -> BS.ByteString -> IO (Either () ()) +myPut output () bs = output bs >> return (Right ()) + +printHeader :: (BS.ByteString -> IO ()) + -> (W.ResponseHeader, BS.ByteString) + -> IO () +printHeader f (x, y) = do + f $ W.responseHeaderToBS x + f $ B8.pack ": " + f y + f $ B8.singleton '\n' + +cleanupVarName :: String -> W.RequestHeader +cleanupVarName ('H':'T':'T':'P':'_':a:as) = + W.requestHeaderFromBS $ B8.pack $ a : helper' as where + helper' ('_':x:rest) = '-' : x : helper' rest + helper' (x:rest) = toLower x : helper' rest + helper' [] = [] +cleanupVarName "CONTENT_TYPE" = W.ReqContentType +cleanupVarName "CONTENT_LENGTH" = W.ReqContentLength +cleanupVarName "SCRIPT_NAME" = W.requestHeaderFromBS $ B8.pack "CGI-Script-Name" +cleanupVarName x = W.requestHeaderFromBS $ B8.pack x -- FIXME remove? + +requestBodyLBS :: Lazy.ByteString -> Int -> W.Source +requestBodyLBS l len = go (Lazy.toChunks l) len + where + go _ 0 = W.Source $ return Nothing + go (l:ls) len = + let len' = len - BS.length l + len'' = if len' < 0 then 0 else len' + in W.Source $ return $ Just (l, go ls len'') + +lookup' :: String -> [(String, String)] -> String +lookup' key pairs = fromMaybe "" $ lookup key pairs + +safeRead :: Read a => a -> String -> a +safeRead d s = + case reads s of + ((x, _):_) -> x + [] -> d diff --git a/configure b/configure new file mode 100644 index 00000000..33c42228 --- /dev/null +++ b/configure @@ -0,0 +1,9 @@ +#!/bin/sh +# + +# subst standard header path variables +if test -n "$CPPFLAGS" ; then + echo "Found CPPFLAGS in environment: '$CPPFLAGS'" + sed 's,@CPPFLAGS@,'"$CPPFLAGS"',g;s,@LDFLAGS@,'"$LDFLAGS"',g' \ + < fastcgi.buildinfo.in > fastcgi.buildinfo +fi diff --git a/fastcgi.buildinfo.in b/fastcgi.buildinfo.in new file mode 100644 index 00000000..37cc208a --- /dev/null +++ b/fastcgi.buildinfo.in @@ -0,0 +1,3 @@ +ghc-options: -optc@CPPFLAGS@ +cc-options: @CPPFLAGS@ +ld-options: @LDFLAGS@ diff --git a/test.hs b/test.hs deleted file mode 100644 index 5cac0001..00000000 --- a/test.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} -import Yesod -import Network.Wai.Handler.FastCGI -data HelloWorld = HelloWorld -mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] -instance Yesod HelloWorld where approot _ = "" -getHome = return $ RepPlain $ cs "Hello World!" -main = toWaiApp HelloWorld >>= run diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index 1f693725..2965ec92 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,25 +1,23 @@ name: wai-handler-fastcgi -version: 0.0.0.2 +version: 0.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman -synopsis: WAI wrapper around direct-fastcgi +synopsis: Wai handler to fastcgi category: Web -stability: Stable -cabal-version: >= 1.6 -build-type: Simple -homepage: http://github.com/snoyberg/wai-handler-fastcgi +stability: stable +cabal-version: >= 1.2 +build-type: Configure +extra-source-files: configure fastcgi.buildinfo.in +homepage: http://github.com/snoyberg/hack-handler-fastcgi/tree/master library build-depends: base >= 4 && < 5, - wai >= 0.0.1 && < 0.2, - bytestring >= 0.9.1.4 && < 0.10, - mtl >= 1.1.0.2 && < 1.2, - direct-fastcgi >= 1.0.1.1 && < 1.1 + wai >= 0.0.0 && < 0.2.0, + wai-extra >= 0.1.0 && < 0.2.0, + bytestring >= 0.9.1.4 && < 0.10 exposed-modules: Network.Wai.Handler.FastCGI ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/snoyberg/wai-handler-fastcgi.git + includes: fcgiapp.h + extra-libraries: fcgi From 11bf4b72bfa5f8d9e66ffdf16c49b4439f858752 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 25 May 2010 09:12:29 +0300 Subject: [PATCH 08/18] Minimal interface, no warnings --- Network/Wai/Handler/FastCGI.hsc | 143 ++------------------------------ 1 file changed, 9 insertions(+), 134 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index f73fdf12..d89930f7 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -14,37 +14,20 @@ -- Totally ripped off by Michael Snoyman to work with Hack, then WAI. -- ----------------------------------------------------------------------------- -module Network.Wai.Handler.FastCGI - ( - -- * Single-threaded interface - runFastCGIorCGI - , runOneFastCGIorCGI - , runFastCGI - , runOneFastCGI - -- * Concurrent interface - , runFastCGIConcurrent - , runFastCGIConcurrent' - ) where +module Network.Wai.Handler.FastCGI (run) where import Data.Maybe -import Data.ByteString.Lazy.Internal (defaultChunkSize) -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, peekArray0 - , alloca, mallocBytes, free, throwIfNeg_) + , alloca, throwIfNeg_) import Foreign.C ( CInt, CString, CStringLen , peekCString ) import Foreign.Storable ( Storable (..) ) -import System.IO.Unsafe (unsafeInterleaveIO,unsafePerformIO) +import System.IO.Unsafe (unsafeInterleaveIO) import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE -import qualified Network.Wai.Source as WS -import qualified Network.Wai.Handler.CGI as CGI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 @@ -57,9 +40,7 @@ import qualified Data.ByteString.Base as BSB #endif -- For debugging -import Control.Concurrent ( myThreadId ) import Prelude hiding ( log, catch ) -import System.IO ( hPutStrLn, stderr ) import qualified System.IO import Control.Arrow ((***)) import Data.Char (toLower) @@ -74,46 +55,22 @@ type Environ = Ptr CString ------------------------------------------------------------------------ -foreign import ccall unsafe "fcgiapp.h FCGX_IsCGI" fcgx_isCGI - :: IO CInt - foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr :: CString -> CInt -> StreamPtr -> IO CInt foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr :: CString -> CInt -> StreamPtr -> IO CInt -foreign import ccall threadsafe "fcgiapp.h FCGX_Accept" fcgx_accept +foreign import ccall safe "fcgiapp.h FCGX_Accept" fcgx_accept :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt foreign import ccall unsafe "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 :: W.Application -> IO () -runFastCGIorCGI f = do fcgi <- runOneFastCGIorCGI f - if fcgi then 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 :: W.Application - -> IO Bool -- ^ True if it was a FastCGI request, - -- False if CGI. -runOneFastCGIorCGI f = - do x <- fcgx_isCGI - if x /= 0 then CGI.run f >> return False - else runOneFastCGI f >> return True - -- | Handle FastCGI requests in an infinite loop. -runFastCGI :: W.Application -> IO () -runFastCGI f = runOneFastCGI f >> runFastCGI f +run :: W.Application -> IO () +run f = runOneFastCGI f >> run f -- | Handle a single FastCGI request. runOneFastCGI :: W.Application -> IO () @@ -157,75 +114,9 @@ handleRequest f ins outs _errs env = data FCGX_Request -foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init - :: IO CInt - -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 unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r - :: Ptr FCGX_Request -> IO () - --- | Like 'Network.CGI.runCGI', but uses the FastCGI interface --- and forks off a new thread (using 'forkOS') for every request. -runFastCGIConcurrent :: Int -- ^ Max number of concurrent threads. - -> W.Application -> IO () -runFastCGIConcurrent = runFastCGIConcurrent' forkOS - -runFastCGIConcurrent' :: (IO () -> IO a) -- ^ How to fork a request. - -> Int -- ^ Max number of concurrent threads. - -> W.Application -> 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 -- FIXME `catch` \e -> log (show e) - -oneRequestMT :: W.Application -> Ptr FCGX_Request -> IO () -oneRequestMT app r = do - env <- peekEnvp r - vars <- environToTable env - ins <- peekIn r - input <- sRead ins - outs <- peekOut r - let hPut = sPutStr' outs - run' vars input hPut app --- --- * FCGX_Reqest struct --- - -acceptRequest :: IO (Ptr FCGX_Request) -acceptRequest = do - reqp <- mallocBytes (#size FCGX_Request) - initAndAccept reqp - return reqp - where initAndAccept reqp = do - testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0 - testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp - -finishRequest :: Ptr FCGX_Request -> IO () -finishRequest reqp = do - fcgx_finish_r reqp - free reqp - -peekIn, peekOut, _peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream) -peekIn = (#peek FCGX_Request, in) -peekOut = (#peek FCGX_Request, out) +_peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream) _peekErr = (#peek FCGX_Request, err) -peekEnvp :: Ptr FCGX_Request -> IO Environ -peekEnvp = (#peek FCGX_Request, envp) - - -- -- * Stream IO -- @@ -234,10 +125,6 @@ sPutStr' :: StreamPtr -> BS.ByteString -> IO () sPutStr' h str = BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h -sPutStr :: StreamPtr -> Lazy.ByteString -> IO () -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 @@ -287,19 +174,6 @@ splitBy :: Eq a => a -> [a] -> ([a],[a]) splitBy x xs = (y, drop 1 z) where (y,z) = break (==x) xs --- --- * Debugging --- - -{-# NOINLINE logMutex #-} -logMutex :: MVar () -logMutex = unsafePerformIO (newMVar ()) - -log :: String -> IO () -log msg = do - t <- myThreadId - withMVar logMutex (const $ hPutStrLn stderr (show t ++ ": " ++ msg)) - run' :: [(String, String)] -- ^ all variables -> Lazy.ByteString -- ^ responseBody of input -> (BS.ByteString -> IO ()) -- ^ destination for output @@ -374,9 +248,10 @@ cleanupVarName "SCRIPT_NAME" = W.requestHeaderFromBS $ B8.pack "CGI-Script-Name" cleanupVarName x = W.requestHeaderFromBS $ B8.pack x -- FIXME remove? requestBodyLBS :: Lazy.ByteString -> Int -> W.Source -requestBodyLBS l len = go (Lazy.toChunks l) len +requestBodyLBS = go . Lazy.toChunks where go _ 0 = W.Source $ return Nothing + go [] _ = W.Source $ return Nothing go (l:ls) len = let len' = len - BS.length l len'' = if len' < 0 then 0 else len' From f6bec21495eb6af43020c0734942b00f594a7e7d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 13 Jul 2010 00:08:49 +0300 Subject: [PATCH 09/18] Migrated to WAI 0.2.0 --- Network/Wai/Handler/FastCGI.hsc | 32 +++++++++++++++++--------------- wai-handler-fastcgi.cabal | 6 +++--- 2 files changed, 20 insertions(+), 18 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index d89930f7..f4a60e1c 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -1,5 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Network.Wai.Handler.FastCGI @@ -180,7 +181,7 @@ run' :: [(String, String)] -- ^ all variables -> W.Application -> IO () run' vars inputH hPut app = do - let rmethod = safeRead W.GET $ lookup' "REQUEST_METHOD" vars + let rmethod = safeRead "GET" $ lookup' "REQUEST_METHOD" vars pinfo = lookup' "PATH_INFO" vars qstring = lookup' "QUERY_STRING" vars servername = lookup' "SERVER_NAME" vars @@ -193,10 +194,10 @@ run' vars inputH hPut app = do case lookup "REMOTE_ADDR" vars of Just x -> x Nothing -> "" - urlScheme' = + isSecure' = case map toLower $ lookup' "SERVER_PROTOCOL" vars of - "https" -> W.HTTPS - _ -> W.HTTP + "https" -> True + _ -> False let env = W.Request { W.requestMethod = rmethod , W.pathInfo = B8.pack pinfo @@ -204,16 +205,16 @@ run' vars inputH hPut app = do , W.serverName = B8.pack servername , W.serverPort = serverport , W.requestHeaders = map (cleanupVarName *** B8.pack) vars - , W.urlScheme = urlScheme' + , W.isSecure = isSecure' , W.requestBody = requestBodyLBS inputH contentLength , W.errorHandler = System.IO.hPutStr System.IO.stderr , W.remoteHost = B8.pack remoteHost' - , W.httpVersion = W.HttpVersion BS.empty + , W.httpVersion = "" -- FIXME } res <- app env let h = W.responseHeaders res - let h' = case lookup W.ContentType h of - Nothing -> (W.ContentType, B8.pack "text/html; charset=utf-8") + let h' = case lookup "Content-Type" h of + Nothing -> ("Content-Type", "text/html; charset=utf-8") : h Just _ -> h hPut $ B8.pack $ "Status: " ++ (show $ W.statusCode $ W.status res) ++ " " @@ -221,7 +222,8 @@ run' vars inputH hPut app = do hPut $ B8.singleton '\n' mapM_ (printHeader hPut) h' hPut $ B8.singleton '\n' - _ <- W.runEnumerator (WE.fromEitherFile (W.responseBody res)) (myPut hPut) () + _ <- W.runEnumerator (WE.fromResponseBody (W.responseBody res)) + (myPut hPut) () return () myPut :: (BS.ByteString -> IO ()) -> () -> BS.ByteString -> IO (Either () ()) @@ -231,21 +233,21 @@ printHeader :: (BS.ByteString -> IO ()) -> (W.ResponseHeader, BS.ByteString) -> IO () printHeader f (x, y) = do - f $ W.responseHeaderToBS x + f $ W.ciOriginal x f $ B8.pack ": " f y f $ B8.singleton '\n' cleanupVarName :: String -> W.RequestHeader cleanupVarName ('H':'T':'T':'P':'_':a:as) = - W.requestHeaderFromBS $ B8.pack $ a : helper' as where + W.mkCIByteString $ B8.pack $ a : helper' as where helper' ('_':x:rest) = '-' : x : helper' rest helper' (x:rest) = toLower x : helper' rest helper' [] = [] -cleanupVarName "CONTENT_TYPE" = W.ReqContentType -cleanupVarName "CONTENT_LENGTH" = W.ReqContentLength -cleanupVarName "SCRIPT_NAME" = W.requestHeaderFromBS $ B8.pack "CGI-Script-Name" -cleanupVarName x = W.requestHeaderFromBS $ B8.pack x -- FIXME remove? +cleanupVarName "CONTENT_TYPE" = "Content-Type" +cleanupVarName "CONTENT_LENGTH" = "Content-Length" +cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name" +cleanupVarName x = W.mkCIByteString $ B8.pack x -- FIXME remove? requestBodyLBS :: Lazy.ByteString -> Int -> W.Source requestBodyLBS = go . Lazy.toChunks diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index 2965ec92..8f8aa57b 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.1.0 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -14,8 +14,8 @@ homepage: http://github.com/snoyberg/hack-handler-fastcgi/tree/master library build-depends: base >= 4 && < 5, - wai >= 0.0.0 && < 0.2.0, - wai-extra >= 0.1.0 && < 0.2.0, + wai >= 0.2.0 && < 0.3.0, + wai-extra >= 0.2.0 && < 0.3.0, bytestring >= 0.9.1.4 && < 0.10 exposed-modules: Network.Wai.Handler.FastCGI ghc-options: -Wall From 8a5d5d92c1a976d40a0d67aed48e3f9a3c6c5eb0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 18 Jul 2010 18:32:51 +0300 Subject: [PATCH 10/18] Don't map all request methods to GET --- Network/Wai/Handler/FastCGI.hsc | 2 +- wai-handler-fastcgi.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index f4a60e1c..8feb16d4 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -181,7 +181,7 @@ run' :: [(String, String)] -- ^ all variables -> W.Application -> IO () run' vars inputH hPut app = do - let rmethod = safeRead "GET" $ lookup' "REQUEST_METHOD" vars + let rmethod = B8.pack $ lookup' "REQUEST_METHOD" vars pinfo = lookup' "PATH_INFO" vars qstring = lookup' "QUERY_STRING" vars servername = lookup' "SERVER_NAME" vars diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index 8f8aa57b..ad5857cc 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.2.0 +version: 0.2.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From 244af9c2b9404b05ccb8b4dccaf1edf35130a663 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 27 Jul 2010 17:55:37 +0300 Subject: [PATCH 11/18] Using run'' from wai-extra --- Network/Wai/Handler/FastCGI.hsc | 128 +++----------------------------- wai-handler-fastcgi.cabal | 4 +- 2 files changed, 14 insertions(+), 118 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index 8feb16d4..7182ca09 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -20,19 +20,17 @@ module Network.Wai.Handler.FastCGI (run) where import Data.Maybe import Control.Monad ( liftM ) import Data.Word (Word8) -import Foreign ( Ptr, castPtr, nullPtr, peekArray0 +import Foreign ( Ptr, castPtr, nullPtr, peekArray0 , alloca, throwIfNeg_) import Foreign.C ( CInt, CString, CStringLen , peekCString ) import Foreign.Storable ( Storable (..) ) -import System.IO.Unsafe (unsafeInterleaveIO) import qualified Network.Wai as W -import qualified Network.Wai.Enumerator as WE +import qualified Network.Wai.Handler.CGI as CGI +import qualified Network.Wai.Handler.Helper as CGI import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as B8 -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 @@ -42,9 +40,6 @@ import qualified Data.ByteString.Base as BSB -- For debugging import Prelude hiding ( log, catch ) -import qualified System.IO -import Control.Arrow ((***)) -import Data.Char (toLower) #include @@ -107,11 +102,9 @@ handleRequest :: W.Application handleRequest f ins outs _errs env = do vars <- environToTable env - input <- sRead ins + let input = sRead ins let hPut = sPutStr' outs - run' vars input hPut f - - + CGI.run'' vars (CGI.requestBodyFunc input) hPut f data FCGX_Request @@ -130,7 +123,7 @@ fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO () fcgxPutCStringLen h (cs,len) = testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h -sRead :: StreamPtr -> IO Lazy.ByteString +sRead :: StreamPtr -> IO (Maybe BS.ByteString) sRead h = buildByteString (fcgxGetBuf h) 4096 fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int @@ -143,16 +136,12 @@ fcgxGetBuf h p c = -- | 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.fromChunks - 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) +buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO (Maybe BS.ByteString) +buildByteString f k = do + ps <- BSB.createAndTrim k $ \p -> f p k + case BS.length ps of + 0 -> return Nothing + _ -> return $ Just ps -- -- * Utilities @@ -174,96 +163,3 @@ environToTable arr = splitBy :: Eq a => a -> [a] -> ([a],[a]) splitBy x xs = (y, drop 1 z) where (y,z) = break (==x) xs - -run' :: [(String, String)] -- ^ all variables - -> Lazy.ByteString -- ^ responseBody of input - -> (BS.ByteString -> IO ()) -- ^ destination for output - -> W.Application - -> IO () -run' vars inputH hPut app = do - let rmethod = B8.pack $ lookup' "REQUEST_METHOD" vars - pinfo = lookup' "PATH_INFO" vars - qstring = lookup' "QUERY_STRING" vars - servername = lookup' "SERVER_NAME" vars - serverport = safeRead 80 $ lookup' "SERVER_PORT" vars - contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars - remoteHost' = - case lookup "REMOTE_HOST" vars of - Just x -> x - Nothing -> - case lookup "REMOTE_ADDR" vars of - Just x -> x - Nothing -> "" - isSecure' = - case map toLower $ lookup' "SERVER_PROTOCOL" vars of - "https" -> True - _ -> False - let env = W.Request - { W.requestMethod = rmethod - , W.pathInfo = B8.pack pinfo - , W.queryString = B8.pack qstring - , W.serverName = B8.pack servername - , W.serverPort = serverport - , W.requestHeaders = map (cleanupVarName *** B8.pack) vars - , W.isSecure = isSecure' - , W.requestBody = requestBodyLBS inputH contentLength - , W.errorHandler = System.IO.hPutStr System.IO.stderr - , W.remoteHost = B8.pack remoteHost' - , W.httpVersion = "" -- FIXME - } - res <- app env - let h = W.responseHeaders res - let h' = case lookup "Content-Type" h of - Nothing -> ("Content-Type", "text/html; charset=utf-8") - : h - Just _ -> h - hPut $ B8.pack $ "Status: " ++ (show $ W.statusCode $ W.status res) ++ " " - hPut $ W.statusMessage $ W.status res - hPut $ B8.singleton '\n' - mapM_ (printHeader hPut) h' - hPut $ B8.singleton '\n' - _ <- W.runEnumerator (WE.fromResponseBody (W.responseBody res)) - (myPut hPut) () - return () - -myPut :: (BS.ByteString -> IO ()) -> () -> BS.ByteString -> IO (Either () ()) -myPut output () bs = output bs >> return (Right ()) - -printHeader :: (BS.ByteString -> IO ()) - -> (W.ResponseHeader, BS.ByteString) - -> IO () -printHeader f (x, y) = do - f $ W.ciOriginal x - f $ B8.pack ": " - f y - f $ B8.singleton '\n' - -cleanupVarName :: String -> W.RequestHeader -cleanupVarName ('H':'T':'T':'P':'_':a:as) = - W.mkCIByteString $ B8.pack $ a : helper' as where - helper' ('_':x:rest) = '-' : x : helper' rest - helper' (x:rest) = toLower x : helper' rest - helper' [] = [] -cleanupVarName "CONTENT_TYPE" = "Content-Type" -cleanupVarName "CONTENT_LENGTH" = "Content-Length" -cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name" -cleanupVarName x = W.mkCIByteString $ B8.pack x -- FIXME remove? - -requestBodyLBS :: Lazy.ByteString -> Int -> W.Source -requestBodyLBS = go . Lazy.toChunks - where - go _ 0 = W.Source $ return Nothing - go [] _ = W.Source $ return Nothing - go (l:ls) len = - let len' = len - BS.length l - len'' = if len' < 0 then 0 else len' - in W.Source $ return $ Just (l, go ls len'') - -lookup' :: String -> [(String, String)] -> String -lookup' key pairs = fromMaybe "" $ lookup key pairs - -safeRead :: Read a => a -> String -> a -safeRead d s = - case reads s of - ((x, _):_) -> x - [] -> d diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index ad5857cc..7fd5f12b 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.2.0.1 +version: 0.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -15,7 +15,7 @@ homepage: http://github.com/snoyberg/hack-handler-fastcgi/tree/master library build-depends: base >= 4 && < 5, wai >= 0.2.0 && < 0.3.0, - wai-extra >= 0.2.0 && < 0.3.0, + wai-extra >= 0.2.1 && < 0.3.0, bytestring >= 0.9.1.4 && < 0.10 exposed-modules: Network.Wai.Handler.FastCGI ghc-options: -Wall From d6110dd6a1e28fe885e06241201e2917edb5f3ec Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 27 Jul 2010 20:36:16 +0300 Subject: [PATCH 12/18] X-Sendfile header support --- Network/Wai/Handler/FastCGI.hsc | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index 7182ca09..48165507 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -15,7 +15,10 @@ -- Totally ripped off by Michael Snoyman to work with Hack, then WAI. -- ----------------------------------------------------------------------------- -module Network.Wai.Handler.FastCGI (run) where +module Network.Wai.Handler.FastCGI + ( run + , runSendfile + ) where import Data.Maybe import Control.Monad ( liftM ) @@ -66,31 +69,39 @@ foreign import ccall unsafe "fcgiapp.h FCGX_Finish" fcgx_finish -- | Handle FastCGI requests in an infinite loop. run :: W.Application -> IO () -run f = runOneFastCGI f >> run f +run f = runOneFastCGI Nothing f >> run f + +-- | Handle FastCGI requests in an infinite loop. For a server which supports +-- the X-Sendfile header. +runSendfile :: String -> W.Application -> IO () +runSendfile sf f = runOneFastCGI (Just sf) f >> runSendfile sf f -- | Handle a single FastCGI request. -runOneFastCGI :: W.Application -> IO () -runOneFastCGI f = do +runOneFastCGI :: Maybe String -- X-Sendfile + -> W.Application -> IO () +runOneFastCGI xsendfile f = do alloca (\inp -> alloca (\outp -> alloca (\errp -> alloca (\envp -> - oneRequest f inp outp errp envp)))) + oneRequest f inp outp errp envp + xsendfile)))) oneRequest :: W.Application -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ + -> Maybe String -- X-Sendfile -> IO () -oneRequest f inp outp errp envp = +oneRequest f inp outp errp envp xsendfile = 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 + handleRequest f ins outs errs env xsendfile fcgx_finish handleRequest :: W.Application @@ -98,13 +109,14 @@ handleRequest :: W.Application -> StreamPtr -> StreamPtr -> Environ + -> Maybe String -- sendfile -> IO () -handleRequest f ins outs _errs env = +handleRequest f ins outs _errs env xsendfile = do vars <- environToTable env let input = sRead ins let hPut = sPutStr' outs - CGI.run'' vars (CGI.requestBodyFunc input) hPut f + CGI.run'' vars (CGI.requestBodyFunc input) hPut xsendfile f data FCGX_Request From 3308bfe8b03abde4b5713efd3c3489048d4f7aff Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 28 Jul 2010 09:07:06 +0300 Subject: [PATCH 13/18] API change in wai-extra --- Network/Wai/Handler/FastCGI.hsc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index 48165507..0fbf002e 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -114,7 +114,7 @@ handleRequest :: W.Application handleRequest f ins outs _errs env xsendfile = do vars <- environToTable env - let input = sRead ins + let input = const $ sRead ins let hPut = sPutStr' outs CGI.run'' vars (CGI.requestBodyFunc input) hPut xsendfile f From dbeaf9c6322f7946f2c4453563cc65288a3f48f7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 11 Aug 2010 10:42:58 +0300 Subject: [PATCH 14/18] runFork --- Network/Wai/Handler/FastCGI.hsc | 109 ++++++++++++++++++-------------- wai-handler-fastcgi.cabal | 2 +- 2 files changed, 61 insertions(+), 50 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index 0fbf002e..cf29e68c 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -1,12 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Network.Wai.Handler.FastCGI --- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006 +-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006, (c) Michael Snoyman 2010 -- License : BSD-style (see the file libraries/network/LICENSE) --- +-- -- Maintainer : michael@snoyman.com -- Stability : experimental -- Portability : non-portable (uses FFI) @@ -18,15 +17,16 @@ module Network.Wai.Handler.FastCGI ( run , runSendfile + , runFork ) where -import Data.Maybe -import Control.Monad ( liftM ) +import Control.Monad ( liftM, forever ) import Data.Word (Word8) import Foreign ( Ptr, castPtr, nullPtr, peekArray0 - , alloca, throwIfNeg_) + , throwIfNeg_, mallocBytes, free ) import Foreign.C ( CInt, CString, CStringLen , peekCString ) +import Control.Exception (finally) import Foreign.Storable ( Storable (..) ) import qualified Network.Wai as W @@ -34,15 +34,8 @@ import qualified Network.Wai.Handler.CGI as CGI import qualified Network.Wai.Handler.Helper as CGI import qualified Data.ByteString as BS -#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 Prelude hiding ( log, catch ) #include @@ -60,59 +53,80 @@ foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr :: CString -> CInt -> StreamPtr -> IO CInt -foreign import ccall safe "fcgiapp.h FCGX_Accept" fcgx_accept - :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt -foreign import ccall unsafe "fcgiapp.h FCGX_Finish" fcgx_finish - :: IO () ------------------------------------------------------------------------ +foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init + :: IO CInt + +runFork :: Maybe String -> (IO () -> IO a) -> Int -> W.Application -> IO () +runFork sf fork threads app = do + testReturn "FCGX_Init" $ fcgx_init + let oneThread = forever $ oneRequest app sf + mapM_ fork $ replicate (threads - 1) oneThread + oneThread + -- | Handle FastCGI requests in an infinite loop. run :: W.Application -> IO () -run f = runOneFastCGI Nothing f >> run f +run = runFork Nothing id 1 -- | Handle FastCGI requests in an infinite loop. For a server which supports -- the X-Sendfile header. runSendfile :: String -> W.Application -> IO () -runSendfile sf f = runOneFastCGI (Just sf) f >> runSendfile sf f - --- | Handle a single FastCGI request. -runOneFastCGI :: Maybe String -- X-Sendfile - -> W.Application -> IO () -runOneFastCGI xsendfile f = do - alloca (\inp -> - alloca (\outp -> - alloca (\errp -> - alloca (\envp -> - oneRequest f inp outp errp envp - xsendfile)))) +runSendfile sf = runFork (Just sf) id 1 oneRequest :: W.Application - -> Ptr StreamPtr - -> Ptr StreamPtr - -> Ptr StreamPtr - -> Ptr Environ -> Maybe String -- X-Sendfile -> IO () -oneRequest f inp outp errp envp xsendfile = - 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 xsendfile - fcgx_finish +oneRequest app xsendfile = withRequest $ \r -> do + putStrLn "Received 1 request" + env <- peekEnvp r + ins <- peekIn r + outs <- peekOut r + handleRequest app ins outs env xsendfile + +peekIn, peekOut :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream) +peekIn = (#peek FCGX_Request, in) +peekOut = (#peek FCGX_Request, out) + +peekEnvp :: Ptr FCGX_Request -> IO Environ +peekEnvp = (#peek FCGX_Request, envp) + +foreign import ccall unsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest + :: Ptr FCGX_Request -> CInt -> CInt -> IO CInt + +foreign import ccall safe "fcgiapp.h FCGX_Accept_r" fcgx_accept_r + :: Ptr FCGX_Request -> IO CInt + +acceptRequest :: IO (Ptr FCGX_Request) +acceptRequest = do + reqp <- mallocBytes (#size FCGX_Request) + initAndAccept reqp + return reqp + where initAndAccept reqp = do + testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0 + testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp + +withRequest :: (Ptr FCGX_Request -> IO ()) -> IO () +withRequest f = do + req <- acceptRequest + f req `finally` finishRequest req + +foreign import ccall unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r + :: Ptr FCGX_Request -> IO () + +finishRequest :: Ptr FCGX_Request -> IO () +finishRequest reqp = do + fcgx_finish_r reqp + free reqp handleRequest :: W.Application - -> StreamPtr -> StreamPtr -> StreamPtr -> Environ -> Maybe String -- sendfile -> IO () -handleRequest f ins outs _errs env xsendfile = - do +handleRequest f ins outs env xsendfile = do vars <- environToTable env let input = const $ sRead ins let hPut = sPutStr' outs @@ -120,9 +134,6 @@ handleRequest f ins outs _errs env xsendfile = data FCGX_Request -_peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream) -_peekErr = (#peek FCGX_Request, err) - -- -- * Stream IO -- diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index 7fd5f12b..09275c8f 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.2.1 +version: 0.2.2 license: BSD3 license-file: LICENSE author: Michael Snoyman From 531634735a005808750656c73785d0a8e6c89a24 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 11 Jan 2011 19:58:29 +0200 Subject: [PATCH 15/18] wai 0.3 --- Network/Wai/Handler/FastCGI.hsc | 41 ++++++++++++++++----------------- wai-handler-fastcgi.cabal | 12 +++++----- 2 files changed, 26 insertions(+), 27 deletions(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index cf29e68c..74c60875 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -24,19 +24,21 @@ import Control.Monad ( liftM, forever ) import Data.Word (Word8) import Foreign ( Ptr, castPtr, nullPtr, peekArray0 , throwIfNeg_, mallocBytes, free ) -import Foreign.C ( CInt, CString, CStringLen - , peekCString ) +import Foreign.C (CInt, CString, CStringLen) import Control.Exception (finally) import Foreign.Storable ( Storable (..) ) import qualified Network.Wai as W import qualified Network.Wai.Handler.CGI as CGI -import qualified Network.Wai.Handler.Helper as CGI +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSB import qualified Data.ByteString.Unsafe as BSB +import Control.Arrow ((***)) + #include ------------------------------------------------------------------------ @@ -59,7 +61,7 @@ foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init :: IO CInt -runFork :: Maybe String -> (IO () -> IO a) -> Int -> W.Application -> IO () +runFork :: Maybe S.ByteString -> (IO () -> IO a) -> Int -> W.Application -> IO () runFork sf fork threads app = do testReturn "FCGX_Init" $ fcgx_init let oneThread = forever $ oneRequest app sf @@ -72,11 +74,11 @@ run = runFork Nothing id 1 -- | Handle FastCGI requests in an infinite loop. For a server which supports -- the X-Sendfile header. -runSendfile :: String -> W.Application -> IO () +runSendfile :: S.ByteString -> W.Application -> IO () runSendfile sf = runFork (Just sf) id 1 oneRequest :: W.Application - -> Maybe String -- X-Sendfile + -> Maybe S.ByteString -- X-Sendfile -> IO () oneRequest app xsendfile = withRequest $ \r -> do putStrLn "Received 1 request" @@ -124,13 +126,14 @@ handleRequest :: W.Application -> StreamPtr -> StreamPtr -> Environ - -> Maybe String -- sendfile + -> Maybe S.ByteString -- sendfile -> IO () handleRequest f ins outs env xsendfile = do vars <- environToTable env + let vars' = map (S8.unpack *** S8.unpack) vars let input = const $ sRead ins let hPut = sPutStr' outs - CGI.run'' vars (CGI.requestBodyFunc input) hPut xsendfile f + CGI.run'' vars' (CGI.requestBodyFunc input) hPut xsendfile f data FCGX_Request @@ -173,16 +176,12 @@ buildByteString f k = do testReturn :: String -> IO CInt -> IO () testReturn e = throwIfNeg_ (\n -> e ++ " failed with error code: "++ show n) -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 +environToTable :: Environ -> IO [(S.ByteString, S.ByteString)] +environToTable arr = do + css <- peekArray0 nullPtr arr + ss <- mapM S.packCString css + return $ map splitEq ss + where + splitEq s = + let (a, b) = S.breakByte 61 s + in (a, S.drop 1 b) diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index 09275c8f..e4baa5d4 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.2.2 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -10,13 +10,13 @@ stability: stable cabal-version: >= 1.2 build-type: Configure extra-source-files: configure fastcgi.buildinfo.in -homepage: http://github.com/snoyberg/hack-handler-fastcgi/tree/master +homepage: http://github.com/snoyberg/wai-handler-fastcgi library - build-depends: base >= 4 && < 5, - wai >= 0.2.0 && < 0.3.0, - wai-extra >= 0.2.1 && < 0.3.0, - bytestring >= 0.9.1.4 && < 0.10 + build-depends: base >= 4 && < 5 + , wai >= 0.3 && < 0.4 + , wai-extra >= 0.3 && < 0.4 + , bytestring >= 0.9 && < 0.10 exposed-modules: Network.Wai.Handler.FastCGI ghc-options: -Wall includes: fcgiapp.h From 3d37750e95bdf7c4731c66b856a49c05d1e835dc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 11 Jan 2011 19:58:47 +0200 Subject: [PATCH 16/18] Including test program + lighttpd config file --- lighttpd.conf | 19 +++++++++++++++++++ test.hs | 19 +++++++++++++++++++ 2 files changed, 38 insertions(+) create mode 100644 lighttpd.conf create mode 100644 test.hs diff --git a/lighttpd.conf b/lighttpd.conf new file mode 100644 index 00000000..37e982db --- /dev/null +++ b/lighttpd.conf @@ -0,0 +1,19 @@ +# Run with lighttpd -D -f lighttpd.conf +server.port = 3000 +server.document-root = "." +server.modules = ("mod_fastcgi", "mod_rewrite") + +url.rewrite-once = ( + "(.*)" => "/app/$1" +) + +fastcgi.server = ( + "/app" => (( + "socket" => "/tmp/test.fastcgi.socket", + "check-local" => "disable", + "bin-path" => "./test", + "min-procs" => 1, + "max-procs" => 12, + "idle-timeout" => 30 + )) +) diff --git a/test.hs b/test.hs new file mode 100644 index 00000000..21cc766d --- /dev/null +++ b/test.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +import Network.Wai +import Network.Wai.Handler.FastCGI +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Enumerator as E + +main = run app + +app req + | pathInfo req == "/" = return $ responseLBS status200 [("Content-Type", "text/html")] "
" +app req = do + bss <- E.consume + return $ responseLBS status200 [("Content-Type", "text/plain")] $ L.concat + [ L8.pack $ show $ requestHeaders req + , "\n" + , L.fromChunks bss + ] From 2f26930e827b5a72ccde13baa19145688b40793e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 1 Apr 2011 10:38:23 +0300 Subject: [PATCH 17/18] WAI 0.4 --- wai-handler-fastcgi.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal index e4baa5d4..b2c7240d 100644 --- a/wai-handler-fastcgi.cabal +++ b/wai-handler-fastcgi.cabal @@ -1,5 +1,5 @@ name: wai-handler-fastcgi -version: 0.3.0 +version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -14,8 +14,8 @@ homepage: http://github.com/snoyberg/wai-handler-fastcgi library build-depends: base >= 4 && < 5 - , wai >= 0.3 && < 0.4 - , wai-extra >= 0.3 && < 0.4 + , wai >= 0.4 && < 0.5 + , wai-extra >= 0.4 && < 0.5 , bytestring >= 0.9 && < 0.10 exposed-modules: Network.Wai.Handler.FastCGI ghc-options: -Wall From d8afaeaae54b5420a19f0213e71451516fe3e6f7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Apr 2011 21:06:42 +0300 Subject: [PATCH 18/18] runGeneric --- Network/Wai/Handler/FastCGI.hsc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc index 74c60875..6bc679bf 100644 --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -133,7 +133,7 @@ handleRequest f ins outs env xsendfile = do let vars' = map (S8.unpack *** S8.unpack) vars let input = const $ sRead ins let hPut = sPutStr' outs - CGI.run'' vars' (CGI.requestBodyFunc input) hPut xsendfile f + CGI.runGeneric vars' (CGI.requestBodyFunc input) hPut xsendfile f data FCGX_Request