    {-# 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 :: Application -> IO ()
    run app :: Application
    app = Maybe ByteString -> Application -> IO ()
    runOne Maybe ByteString
    forall a. Maybe a
    Nothing Application
    app IO () -> IO () -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Application -> IO ()
    run Application
    app

    runSendfile :: ByteString -> Application -> IO ()
    runSendfile :: ByteString -> Application -> IO ()
    runSendfile sf :: ByteString
    sf app :: Application
    app = Maybe ByteString -> Application -> IO ()
    runOne (ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just ByteString
    sf) Application
    app IO () -> IO () -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ByteString -> Application -> IO ()
    runSendfile ByteString
    sf Application
    app

    runOne :: Maybe ByteString -> Application -> IO ()
    runOne :: Maybe ByteString -> Application -> IO ()
    runOne sf :: Maybe ByteString
    sf app :: Application
    app = do
        CInt
    socket <- CInt -> Ptr Any -> Ptr Any -> IO CInt
    forall a. CInt -> Ptr a -> Ptr a -> IO CInt
    c'accept 0 Ptr Any
    forall a. Ptr a
    nullPtr Ptr Any
    forall a. Ptr a
    nullPtr
        ByteString
    headersBS <- CInt -> IO ByteString
    readNetstring CInt
    socket
        let headers :: [(String, String)]
    headers@((_, conLenS :: String
    conLenS):_) = [ByteString] -> [(String, String)]
    parseHeaders ([ByteString] -> [(String, String)])
    -> [ByteString] -> [(String, String)]
    forall a b. (a -> b) -> a -> b
    $ Word8 -> ByteString -> [ByteString]
    S.split 0 ByteString
    headersBS
        let conLen :: Int
    conLen = case ReadS Int
    forall a. Read a => ReadS a
    reads String
    conLenS of
                        (i :: Int
    i, _):_ -> Int
    i
                        [] -> 0
        IORef Int
    conLenI <- Int -> IO (IORef Int)
    forall a. a -> IO (IORef a)
    newIORef Int
    conLen
        [(String, String)]
    -> (Int -> IO (IO ByteString))
    -> (ByteString -> IO ())
    -> Maybe ByteString
    -> Application
    -> IO ()
    runGeneric [(String, String)]
    headers ((Int -> IO (Maybe ByteString)) -> Int -> IO (IO ByteString)
    requestBodyFunc ((Int -> IO (Maybe ByteString)) -> Int -> IO (IO ByteString))
    -> (Int -> IO (Maybe ByteString)) -> Int -> IO (IO ByteString)
    forall a b. (a -> b) -> a -> b
    $ CInt -> IORef Int -> Int -> IO (Maybe ByteString)
    input CInt
    socket IORef Int
    conLenI)
                  (CInt -> ByteString -> IO ()
    write CInt
    socket) Maybe ByteString
    sf Application
    app
        CInt -> IORef Int -> IO ()
    drain CInt
    socket IORef Int
    conLenI
        CInt
    _ <- CInt -> IO CInt
    c'close CInt
    socket
        () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    write :: CInt -> S.ByteString -> IO ()
    write :: CInt -> ByteString -> IO ()
    write socket :: CInt
    socket bs :: ByteString
    bs = ByteString -> (CStringLen -> IO ()) -> IO ()
    forall a. ByteString -> (CStringLen -> IO a) -> IO a
    S.unsafeUseAsCStringLen ByteString
    bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \(s :: Ptr CChar
    s, l :: Int
    l) -> do
        CInt
    _ <- CInt -> Ptr CChar -> CInt -> IO CInt
    c'write CInt
    socket Ptr CChar
    s (Int -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    l)
        () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    input :: CInt -> IORef Int -> Int -> IO (Maybe S.ByteString)
    input :: CInt -> IORef Int -> Int -> IO (Maybe ByteString)
    input socket :: CInt
    socket ilen :: IORef Int
    ilen rlen :: Int
    rlen = do
        Int
    len <- IORef Int -> IO Int
    forall a. IORef a -> IO a
    readIORef IORef Int
    ilen
        case Int
    len of
            0 -> Maybe ByteString -> IO (Maybe ByteString)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe ByteString
    forall a. Maybe a
    Nothing
            _ -> do
                ByteString
    bs <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket
                    (Int -> IO ByteString) -> Int -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ [Int] -> Int
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    minimum [Int
    defaultChunkSize, Int
    len, Int
    rlen]
                IORef Int -> Int -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Int
    ilen (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int
    len Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - ByteString -> Int
    S.length ByteString
    bs
                Maybe ByteString -> IO (Maybe ByteString)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe ByteString -> IO (Maybe ByteString))
    -> Maybe ByteString -> IO (Maybe ByteString)
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just ByteString
    bs

    drain :: CInt -> IORef Int -> IO () -- FIXME do it in chunks
    drain :: CInt -> IORef Int -> IO ()
    drain socket :: CInt
    socket ilen :: IORef Int
    ilen = do
        Int
    len <- IORef Int -> IO Int
    forall a. IORef a -> IO a
    readIORef IORef Int
    ilen
        ByteString
    _ <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket Int
    len
        () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

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

    readNetstring :: CInt -> IO S.ByteString
    readNetstring :: CInt -> IO ByteString
    readNetstring socket :: CInt
    socket = do
        Int
    len <- Int -> IO Int
    readLen 0
        ByteString
    bs <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket Int
    len
        ByteString
    _ <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket 1 -- the comma
        ByteString -> IO ByteString
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    bs
      where
        readLen :: Int -> IO Int
    readLen l :: Int
    l = do
            ByteString
    bs <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket 1
            let [c :: Char
    c] = ByteString -> String
    S8.unpack ByteString
    bs
            if Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == ':'
                then Int -> IO Int
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    l
                else Int -> IO Int
    readLen (Int -> IO Int) -> Int -> IO Int
    forall a b. (a -> b) -> a -> b
    $ Int
    l Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * 10 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + (Char -> Int
    forall a. Enum a => a -> Int
    fromEnum Char
    c Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Char -> Int
    forall a. Enum a => a -> Int
    fromEnum '0')

    readByteString :: CInt -> Int -> IO S.ByteString
    readByteString :: CInt -> Int -> IO ByteString
    readByteString socket :: CInt
    socket len :: Int
    len = do
        Ptr CChar
    buf <- Int -> IO (Ptr CChar)
    forall a. Int -> IO (Ptr a)
    mallocBytes Int
    len
        CInt
    _ <- CInt -> Ptr CChar -> CInt -> IO CInt
    c'read CInt
    socket Ptr CChar
    buf (CInt -> IO CInt) -> CInt -> IO CInt
    forall a b. (a -> b) -> a -> b
    $ Int -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    len
        Ptr Word8 -> Int -> IO () -> IO ByteString
    S.unsafePackCStringFinalizer (Ptr CChar -> Ptr Word8
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    buf) Int
    len (IO () -> IO ByteString) -> IO () -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ Ptr CChar -> IO ()
    forall a. Ptr a -> IO ()
    free Ptr CChar
    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