    {-# LANGUAGE CPP, ForeignFunctionInterface #-}
    module Network.Wai.Handler.SCGI
        ( run
        , runSendfile
        ) where

    import Network.Wai
    import Network.Wai.Handler.CGI (runGeneric, requestBodyFunc)
    import Foreign.Ptr
    import Foreign.Marshal.Alloc
    import Foreign.C
    import Data.ByteString (ByteString)
    import qualified Data.ByteString as S
    import qualified Data.ByteString.Unsafe as S
    import qualified Data.ByteString.Char8 as S8
    import Data.IORef
    import Data.ByteString.Lazy.Internal (defaultChunkSize)

    run :: Application -> IO ()
    run app = runOne Nothing app >> run app

    runSendfile :: ByteString -> Application -> IO ()
    runSendfile sf app = runOne (Just sf) app >> runSendfile sf app

    runOne :: Maybe ByteString -> Application -> IO ()
    runOne sf app = do
        socket <- c'accept 0 nullPtr nullPtr
        headersBS <- readNetstring socket
        let headers@((_, conLenS):_) = parseHeaders $ S.split 0 headersBS
        let conLen = case reads conLenS of
                        (i, _):_ -> i
                        [] -> 0
        conLenI <- newIORef conLen
        runGeneric headers (requestBodyFunc $ input socket conLenI)
                  (write socket) sf app
        drain socket conLenI
        _ <- c'close socket
        return ()

    write :: CInt -> S.ByteString -> IO ()
    write socket bs = S.unsafeUseAsCStringLen bs $ \(s, l) -> do
        _ <- c'write socket s (fromIntegral l)
        return ()

    input :: CInt -> IORef Int -> Int -> IO (Maybe S.ByteString)
    input socket ilen rlen = do
        len <- readIORef ilen
        case len of
            0 -> return Nothing
            _ -> do
                bs <- readByteString socket
                    $ minimum [defaultChunkSize, len, rlen]
                writeIORef ilen $ len - S.length bs
                return $ Just bs

    drain :: CInt -> IORef Int -> IO () -- FIXME do it in chunks
    drain socket ilen = do
        len <- readIORef ilen
        _ <- readByteString socket len
        return ()

    parseHeaders :: [S.ByteString] -> [(String, String)]
    parseHeaders (x:y:z) = (S8.unpack x, S8.unpack y) : parseHeaders z
    parseHeaders _ = []

    readNetstring :: CInt -> IO S.ByteString
    readNetstring socket = do
        len <- readLen 0
        bs <- readByteString socket len
        _ <- readByteString socket 1 -- the comma
        return bs
      where
        readLen l = do
            bs <- readByteString socket 1
            let [c] = S8.unpack bs
            if c == ':'
                then return l
                else readLen $ l * 10 + (fromEnum c - fromEnum '0')

    readByteString :: CInt -> Int -> IO S.ByteString
    readByteString socket len = do
        buf <- mallocBytes len
        _ <- c'read socket buf $ fromIntegral len
        S.unsafePackCStringFinalizer (castPtr buf) len $ free buf

    foreign import ccall unsafe "accept"
        c'accept :: CInt -> Ptr a -> Ptr a -> IO CInt

    #if WINDOWS
    foreign import ccall unsafe "_close"
        c'close :: CInt -> IO CInt

    foreign import ccall unsafe "_write"
        c'write :: CInt -> Ptr CChar -> CInt -> IO CInt

    foreign import ccall unsafe "_read"
        c'read :: CInt -> Ptr CChar -> CInt -> IO CInt
    #else
    foreign import ccall unsafe "close"
        c'close :: CInt -> IO CInt

    foreign import ccall unsafe "write"
        c'write :: CInt -> Ptr CChar -> CInt -> IO CInt

    foreign import ccall unsafe "read"
        c'read :: CInt -> Ptr CChar -> CInt -> IO CInt
    #endif