{-# 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 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 forall a. Maybe a
Nothing Application
app 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 (forall a. a -> Maybe a
Just ByteString
sf) Application
app 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 <- forall a. CInt -> Ptr a -> Ptr a -> IO CInt
c'accept CInt
0 forall a. Ptr a
nullPtr forall a. Ptr a
nullPtr
    ByteString
headersBS <- CInt -> IO ByteString
readNetstring CInt
socket
    let headers :: [(String, String)]
headers@((String
_, String
conLenS):[(String, String)]
_) = [ByteString] -> [(String, String)]
parseHeaders forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> [ByteString]
S.split Word8
0 ByteString
headersBS
    let conLen :: Int
conLen = case forall a. Read a => ReadS a
reads String
conLenS of
                    (Int
i, String
_):[(Int, String)]
_ -> Int
i
                    [] -> Int
0
    IORef Int
conLenI <- 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 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
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

write :: CInt -> S.ByteString -> IO ()
write :: CInt -> ByteString -> IO ()
write CInt
socket ByteString
bs = forall a. ByteString -> (CStringLen -> IO a) -> IO a
S.unsafeUseAsCStringLen ByteString
bs 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)
    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 <- forall a. IORef a -> IO a
readIORef IORef Int
ilen
    case Int
len of
        Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Int
_ -> do
            ByteString
bs <- CInt -> Int -> IO ByteString
readByteString CInt
socket
                forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int
defaultChunkSize, Int
len, Int
rlen]
            forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ilen forall a b. (a -> b) -> a -> b
$ Int
len forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
bs
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- forall a. IORef a -> IO a
readIORef IORef Int
ilen
    ByteString
_ <- CInt -> Int -> IO ByteString
readByteString CInt
socket Int
len
    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) 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
    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
        let [Char
c] = ByteString -> String
S8.unpack ByteString
bs
        if Char
c forall a. Eq a => a -> a -> Bool
== Char
':'
            then forall (m :: * -> *) a. Monad m => a -> m a
return Int
l
            else Int -> IO Int
readLen forall a b. (a -> b) -> a -> b
$ Int
l forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ (forall a. Enum a => a -> Int
fromEnum Char
c forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
'0')

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