{-# 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 ()
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)]
(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
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