wai-handler-fastcgi 0.2.0.1 → 0.2.1
raw patch · 2 files changed
+34/−126 lines, 2 filesdep ~wai-extra
Dependency ranges changed: wai-extra
Files
- Network/Wai/Handler/FastCGI.hsc +32/−124
- wai-handler-fastcgi.cabal +2/−2
Network/Wai/Handler/FastCGI.hsc view
@@ -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 <fcgiapp.h> @@ -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
wai-handler-fastcgi.cabal view
@@ -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 <michael@snoyman.com>@@ -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