module Hack.Handler.FastCGI
(
runFastCGIorCGI
, runOneFastCGIorCGI
, runFastCGI
, runOneFastCGI
, runFastCGIConcurrent
, runFastCGIConcurrent'
) where
import Control.Concurrent ( forkOS )
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.OldException 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 Hack
import qualified Hack.Handler.CGI as CGI
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as Lazy
import qualified Data.ByteString.Internal as BSB
import qualified Data.ByteString.Unsafe as BSB
import Control.Concurrent ( myThreadId )
import Prelude hiding ( log, catch )
import System.IO ( hPutStrLn, stderr )
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 ()
runFastCGIorCGI :: Hack.Application -> IO ()
runFastCGIorCGI f = do fcgi <- runOneFastCGIorCGI f
if fcgi then runFastCGIorCGI f
else return ()
runOneFastCGIorCGI :: Hack.Application
-> IO Bool
runOneFastCGIorCGI f =
do x <- fcgx_isCGI
if x /= 0 then CGI.run f >> return False
else runOneFastCGI f >> return True
runFastCGI :: Hack.Application -> IO ()
runFastCGI f = runOneFastCGI f >> runFastCGI f
runOneFastCGI :: Hack.Application -> IO ()
runOneFastCGI f = do
alloca (\inp ->
alloca (\outp ->
alloca (\errp ->
alloca (\envp ->
oneRequest f inp outp errp envp))))
oneRequest :: Hack.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 :: Hack.Application
-> StreamPtr
-> StreamPtr
-> StreamPtr
-> Environ
-> IO ()
handleRequest f ins outs _errs env =
do
vars <- environToTable env
input <- sRead ins
output <- CGI.helper vars input f
sPutStr outs output
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 ()
runFastCGIConcurrent :: Int
-> Hack.Application -> IO ()
runFastCGIConcurrent = runFastCGIConcurrent' forkOS
runFastCGIConcurrent' :: (IO () -> IO a)
-> Int
-> Hack.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 `catch` \e -> log (show e)
oneRequestMT :: Hack.Application -> Ptr FCGX_Request -> IO ()
oneRequestMT app r = do
env <- peekEnvp r
vars <- environToTable env
ins <- peekIn r
input <- sRead ins
output <- CGI.helper vars input app
outs <- peekOut r
sPutStr outs output
acceptRequest :: IO (Ptr FCGX_Request)
acceptRequest = do
reqp <- mallocBytes ((56))
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 = ((\hsc_ptr -> peekByteOff hsc_ptr 8))
peekOut = ((\hsc_ptr -> peekByteOff hsc_ptr 12))
_peekErr = ((\hsc_ptr -> peekByteOff hsc_ptr 16))
peekEnvp :: Ptr FCGX_Request -> IO Environ
peekEnvp = ((\hsc_ptr -> peekByteOff hsc_ptr 20))
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
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)
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
splitBy :: Eq a => a -> [a] -> ([a],[a])
splitBy x xs = (y, drop 1 z)
where (y,z) = break (==x) xs
logMutex :: MVar ()
logMutex = unsafePerformIO (newMVar ())
log :: String -> IO ()
log msg = do
t <- myThreadId
withMVar logMutex (const $ hPutStrLn stderr (show t ++ ": " ++ msg))