    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ForeignFunctionInterface #-}

    module Network.Wai.Handler.SCGI (
        run,
        runSendfile,
    ) where

    import Data.ByteString (ByteString)
    import qualified Data.ByteString as S
    import qualified Data.ByteString.Char8 as S8
    import Data.ByteString.Lazy.Internal (defaultChunkSize)
    import qualified Data.ByteString.Unsafe as S
    import Data.IORef (IORef, newIORef, readIORef, writeIORef)
    import Data.Maybe (fromMaybe, listToMaybe)
    import Foreign.C (CChar, CInt (..))
    import Foreign.Marshal.Alloc (free, mallocBytes)
    import Foreign.Ptr (Ptr, castPtr, nullPtr)
    import Network.Wai (Application)
    import Network.Wai.Handler.CGI (requestBodyFunc, runGeneric)

    run :: Application -> IO ()
    run :: Application -> IO ()
    run Application
    app = Maybe ByteString -> Application -> IO ()
    runOne Maybe ByteString
    forall a. Maybe a
    Nothing Application
    app IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    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 ByteString
    sf Application
    app = Maybe ByteString -> Application -> IO ()
    runOne (ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just ByteString
    sf) Application
    app IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    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 Maybe ByteString
    sf Application
    app = do
        CInt
    socket <- CInt -> Ptr Any -> Ptr Any -> IO CInt
    forall a. CInt -> Ptr a -> Ptr a -> IO CInt
    c'accept CInt
    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 = [ByteString] -> [(String, String)]
    parseHeaders ([ByteString] -> [(String, String)])
    -> [ByteString] -> [(String, String)]
    forall a b. (a -> b) -> a -> b
    $ Word8 -> ByteString -> [ByteString]
    S.split Word8
    0 ByteString
    headersBS
        let conLen :: Int
    conLen =
                Int -> Maybe Int -> Int
    forall a. a -> Maybe a -> a
    fromMaybe Int
    0 (Maybe Int -> Int) -> Maybe Int -> Int
    forall a b. (a -> b) -> a -> b
    $ do
                    (String
    _, String
    conLenS) <- [(String, String)] -> Maybe (String, String)
    forall a. [a] -> Maybe a
    listToMaybe [(String, String)]
    headers
                    (Int
    i, String
    _) <- [(Int, String)] -> Maybe (Int, String)
    forall a. [a] -> Maybe a
    listToMaybe ([(Int, String)] -> Maybe (Int, String))
    -> [(Int, String)] -> Maybe (Int, String)
    forall a b. (a -> b) -> a -> b
    $ ReadS Int
    forall a. Read a => ReadS a
    reads String
    conLenS
                    Int -> Maybe Int
    forall a. a -> Maybe a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Int
    i
        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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    write :: CInt -> S.ByteString -> IO ()
    write :: CInt -> ByteString -> IO ()
    write CInt
    socket 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
    $ \(Ptr CChar
    s, 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 a. a -> IO a
    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 CInt
    socket IORef Int
    ilen Int
    rlen = do
        Int
    len <- IORef Int -> IO Int
    forall a. IORef a -> IO a
    readIORef IORef Int
    ilen
        case Int
    len of
            Int
    0 -> Maybe ByteString -> IO (Maybe ByteString)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe ByteString
    forall a. Maybe a
    Nothing
            Int
    _ -> 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 a. Ord a => [a] -> a
    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 a. a -> IO a
    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 CInt
    socket 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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    parseHeaders :: [S.ByteString] -> [(String, String)]
    parseHeaders :: [ByteString] -> [(String, String)]
    parseHeaders (ByteString
    x : ByteString
    y : [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 [ByteString]
    _ = []

    readNetstring :: CInt -> IO S.ByteString
    readNetstring :: CInt -> IO ByteString
    readNetstring CInt
    socket = do
        Int
    len <- Int -> IO Int
    readLen Int
    0
        ByteString
    bs <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket Int
    len
        ByteString
    _ <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket Int
    1 -- the comma
        ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    bs
      where
        readLen :: Int -> IO Int
    readLen Int
    l = do
            ByteString
    bs <- CInt -> Int -> IO ByteString
    readByteString CInt
    socket Int
    1
            case ByteString -> String
    S8.unpack ByteString
    bs of
                [Char
    ':'] -> Int -> IO Int
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    l
                [Char
    c] -> 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
    * Int
    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 Char
    '0')
                String
    _ -> String -> IO Int
    forall a. HasCallStack => String -> a
    error String
    "Network.Wai.Handler.SCGI.readNetstring: should never happen"

    readByteString :: CInt -> Int -> IO S.ByteString
    readByteString :: CInt -> Int -> IO ByteString
    readByteString CInt
    socket 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