diff --git a/Network/Wai/Handler/FastCGI.hsc b/Network/Wai/Handler/FastCGI.hsc --- a/Network/Wai/Handler/FastCGI.hsc +++ b/Network/Wai/Handler/FastCGI.hsc @@ -15,24 +15,25 @@ -- 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 ) 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 +43,6 @@ -- For debugging import Prelude hiding ( log, catch ) -import qualified System.IO -import Control.Arrow ((***)) -import Data.Char (toLower) #include @@ -71,31 +69,39 @@ -- | 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 @@ -103,15 +109,14 @@ -> StreamPtr -> StreamPtr -> Environ + -> Maybe String -- sendfile -> IO () -handleRequest f ins outs _errs env = +handleRequest f ins outs _errs env xsendfile = do vars <- environToTable env - input <- sRead ins + let input = const $ sRead ins let hPut = sPutStr' outs - run' vars input hPut f - - + CGI.run'' vars (CGI.requestBodyFunc input) hPut xsendfile f data FCGX_Request @@ -130,7 +135,7 @@ 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 +148,12 @@ -- | 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 +175,3 @@ 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 --- 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 @@ 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