-----------------------------------------------------------------------------
-- |
-- Module      :  Network.FastCGI
-- Copyright   :  (c) Bjorn Bringert 2004-2005
-- License     :  BSD-style (see the file libraries/network/LICENSE)
-- 
-- Maintainer  :  bjorn@bringert.net
-- Stability   :  experimental
-- Portability :  non-portable (uses FFI)
--
-- Interface for FastCGI <http://fastcgi.com/>, using the fcgiapp API.
--
-----------------------------------------------------------------------------
module Network.FastCGI ({-runFastCGIConcurrent,-}
                        runFastCGIorCGI, runOneFastCGIorCGI, 
                        runFastCGI, runOneFastCGI,
                        module Network.CGI) where

import Control.Concurrent (forkOS)
import Control.Exception as Exception (catch, finally, throwIO)
import Control.Monad (when, liftM)
import Data.Word (Word8)
import Foreign          ( Ptr, castPtr, nullPtr, plusPtr, peekArray0 
                        , alloca
		        , mallocBytes, free, throwIfNeg_, allocaBytes
                        , mallocArray, reallocArray, withForeignPtr)
import Foreign.C        ( CInt, CString, CStringLen, CChar, withCStringLen
                        , peekCString, castCCharToChar )
import Foreign.Storable ( Storable (..) )
import System.IO.Unsafe (unsafeInterleaveIO)

import Network.CGI
import Network.CGI.Monad (runCGIT)
import Network.CGI.Protocol (runCGIEnvFPS)

import qualified Data.ByteString as BS
import qualified Data.ByteString.Base as BSB
import qualified Data.ByteString.Base as Lazy (LazyByteString(LPS))
import qualified Data.ByteString.Lazy.Char8 as Lazy

-- For debugging
import Control.Concurrent (myThreadId)
import Prelude hiding (log)
import System.Mem (performGC)
import System.IO (hPutStrLn, stderr)

#include <fcgiapp.h>

data FCGX_Stream = FCGX_Stream
type StreamPtr = Ptr FCGX_Stream
type Environ = Ptr CString

foreign import ccall threadsafe "fcgiapp.h FCGX_IsCGI" fcgx_isCGI
    :: IO CInt

foreign import ccall threadsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr
    :: CString -> CInt -> StreamPtr -> IO CInt

foreign import ccall threadsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr
    :: CString -> CInt -> StreamPtr -> IO CInt

--
-- This code uses the not MT safe functions of the fcgiapp API,
-- to avoid getting intermittent SIGPIPEs. Dunno why that happens.
--

foreign import ccall "fcgiapp.h FCGX_Accept" fcgx_accept
    :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt
foreign import ccall "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 :: CGI CGIResult -> IO ()
runFastCGIorCGI f = do fcgi <- runOneFastCGIorCGI f
                       if fcgi then performGC >> 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 :: CGI CGIResult 
                   -> IO Bool -- ^ True if it was a FastCGI request, 
                              --   False if CGI.
runOneFastCGIorCGI f =
    do x <- fcgx_isCGI
       if x /= 0 then runCGI f >> return False
                 else runOneFastCGI f >> return True

-- | Handle FastCGI requests in an infinite loop.
runFastCGI :: CGI CGIResult -> IO ()
runFastCGI f = runOneFastCGI f >> performGC >> runFastCGI f

-- | Handle a single FastCGI request.
runOneFastCGI :: CGI CGIResult -> IO ()
runOneFastCGI f = do
    alloca (\inp ->
            alloca (\outp ->
                    alloca (\errp ->
                            alloca (\envp ->
                                    oneRequest f inp outp errp envp))))

oneRequest :: CGI CGIResult
           -> 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 :: CGI CGIResult
              -> StreamPtr
              -> StreamPtr
              -> StreamPtr
              -> Environ
              -> IO ()
handleRequest f ins outs errs env =
    do
    vars <- environToTable env
    input <- sRead ins
    output <- runCGIEnvFPS vars input (runCGIT f)
    sPutStr outs output



--
-- The following code uses the MT safe fcgiapp API,
-- but causes mod_fastcgi to get SIGPIPE once in a while.
--

{-

data FCGX_Request = FCGX_Request

foreign import ccall threadsafe "fcgiapp.h FCGX_Init" fcgx_init
    :: IO CInt

foreign import ccall threadsafe "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 threadsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r
    :: Ptr FCGX_Request -> IO ()

-- | Like 'Network.NewCGI.runCGI', but uses the FastCGI interface.
runFastCGI :: CGI CGIResult -> IO ()
runFastCGI = runFastCGI' id

-- | Like 'Network.NewCGI.runCGI', but uses the FastCGI interface
--   and forks off a new thread (using 'forkOS') for every request.
runFastCGIConcurrent :: CGI CGIResult -> IO ()
runFastCGIConcurrent = runFastCGI' fork
    where fork m = do
		   t <- forkOS m
		   log $ "Created child: " ++ show t

runFastCGI' :: (IO () -> IO a) -> CGI CGIResult -> IO ()
runFastCGI' fork f = do
		     log "Calling FCGX_Init"
		     testReturn "FCGX_Init" $ fcgx_init
		     loop
    where 
    loop = do
	   reqp <- acceptRequest
	   log "Forking"
	   fork (oneRequest f reqp `finally` finishRequest reqp)
	   loop

oneRequest :: CGI CGIResult -> Ptr FCGX_Request -> IO ()
oneRequest f r = do
		 env <- peekEnvp r
		 vars <- environToTable env
		 ins <- peekIn r
		 input <- sStrictRead ins
		 log "Running CGI action"
		 output <- runCGIEnv vars input f
		 outs <- peekOut r
		 log "Returning output"
		 sPutStr outs output

--
-- * FCGX_Reqest struct
--

acceptRequest :: IO (Ptr FCGX_Request)
acceptRequest = do
		log "Allocating FCGX_Request"
 		reqp <- mallocBytes (#size FCGX_Request)
		initAndAccept reqp `onError` free reqp
		return reqp
    where initAndAccept reqp = 
	      do 
	      log "Calling FCGX_InitRequest"
	      testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0
	      log "Calling FCGX_Accept_r"
	      testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp

finishRequest :: Ptr FCGX_Request -> IO ()
finishRequest reqp = do
		     log "Calling FCGX_Finish_r"
		     fcgx_finish_r reqp
		     log "Freeing FCGX_Request"
		     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 -> Lazy.ByteString -> IO ()
sPutStr h (Lazy.LPS strs) = 
    mapM_ (flip BSB.unsafeUseAsCStringLen (fcgxPutCStringLen h)) strs

fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO ()
fcgxPutCStringLen h (cs,len) = 
    testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h

{-
-- Based on Data.FastPackedString.hGetContents
sRead :: StreamPtr -> IO BS.ByteString
sRead h = do 
    let start_size = 1024
    p <- mallocArray start_size
    i <- fcgx_getStr p start_size h
    if i < start_size
        then liftM BS.packMallocCString $ reallocArray p i
        else f p start_size
    where 
        f p s = do 
        let s' = 2 * s
        p' <- reallocArray p s'
        i  <- fcgx_getStr (p' `plusPtr` s) s h
        if i < s 
            then liftM BS.packMallocCString $ reallocArray p' (s + i)
            else f p' s'
-}

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.LPS
  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
--

-- | Run some action if the first action throws an exception.
--   The exception is re-thrown.
onError :: IO a -> IO () -> IO a
onError f h = f `Exception.catch` (\e -> h >> throwIO e)

testReturn :: String -> IO CInt -> IO ()
testReturn e = throwIfNeg_ (const $ e ++ " failed")

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
--

log :: String -> IO ()
log msg = do
	  t <- myThreadId
	  hPutStrLn stderr (show t ++ ": " ++ msg)