{-# 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
socket <- CInt -> Ptr (ZonkAny 0) -> Ptr (ZonkAny 0) -> IO CInt
forall a. CInt -> Ptr a -> Ptr a -> IO CInt
c'accept CInt
0 Ptr (ZonkAny 0)
forall a. Ptr a
nullPtr Ptr (ZonkAny 0)
forall a. Ptr a
nullPtr
headersBS <- readNetstring socket
let 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 -> 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
(_, conLenS) <- [(String, String)] -> Maybe (String, String)
forall a. [a] -> Maybe a
listToMaybe [(String, String)]
headers
(i, _) <- listToMaybe $ reads conLenS
pure i
conLenI <- newIORef conLen
runGeneric
headers
(requestBodyFunc $ input socket conLenI)
(write socket)
sf
app
drain socket conLenI
_ <- c'close socket
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 -> 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)
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
len <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ilen
case 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
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]
writeIORef ilen $ len - S.length bs
return $ Just bs
drain :: CInt -> IORef Int -> IO ()
drain :: CInt -> IORef Int -> IO ()
drain CInt
socket IORef Int
ilen = do
len <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ilen
_ <- readByteString socket len
return ()
parseHeaders :: [S.ByteString] -> [(String, String)]
(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
len <- Int -> IO Int
readLen Int
0
bs <- readByteString socket len
_ <- readByteString socket 1
return bs
where
readLen :: Int -> IO Int
readLen Int
l = do
bs <- CInt -> Int -> IO ByteString
readByteString CInt
socket Int
1
case S8.unpack 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
buf <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes Int
len
_ <- c'read socket buf $ fromIntegral len
S.unsafePackCStringFinalizer (castPtr buf) len $ free 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