{-# 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 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 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 (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@((String
_, String
conLenS):[(String, String)]
_) = [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 = case ReadS Int
forall a. Read a => ReadS a
reads String
conLenS of
                    (Int
i, String
_):[(Int, String)]
_ -> Int
i
                    [] -> Int
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 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 (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 (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 (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 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 (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 (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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'
            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
* 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')

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