diff --git a/LICENSE b/LICENSE
--- 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
--- 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
--- /dev/null
+++ b/Network/Wai/Handler/FastCGI.hsc
@@ -0,0 +1,267 @@
+{-# 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 (run) where
+
+import Data.Maybe
+import Control.Monad ( liftM )
+import Data.Word (Word8)
+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 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 Prelude hiding ( log, catch )
+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_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 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 FastCGI requests in an infinite loop.
+run :: W.Application -> IO ()
+run f = runOneFastCGI f >> run 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
+
+_peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)
+_peekErr = (#peek FCGX_Request, err)
+
+--
+-- * Stream IO
+--
+
+sPutStr' :: StreamPtr -> BS.ByteString -> IO ()
+sPutStr' h str =
+ BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h
+
+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
+
+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 = 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/configure b/configure
new file mode 100644
--- /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
--- /dev/null
+++ b/fastcgi.buildinfo.in
@@ -0,0 +1,3 @@
+ghc-options: -optc@CPPFLAGS@
+cc-options: @CPPFLAGS@
+ld-options: @LDFLAGS@
diff --git a/wai-handler-fastcgi.cabal b/wai-handler-fastcgi.cabal
--- 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