@@ -0,0 +1,96 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+module Network.Wai.Handler.SCGI
3+ ( run
4+ , runSendfile
5+ ) where
6+
7+import Network.Wai
8+import Network.Wai.Handler.CGI (runGeneric, requestBodyFunc)
9+import Foreign.Ptr
10+import Foreign.Marshal.Alloc
11+import Foreign.C
12+import Data.ByteString (ByteString)
13+import qualified Data.ByteString as S
14+import qualified Data.ByteString.Unsafe as S
15+import qualified Data.ByteString.Char8 as S8
16+import Data.IORef
17+import Data.ByteString.Lazy.Internal (defaultChunkSize)
18+
19+run :: Application -> IO ()
20+run app = runOne Nothing app >> run app
21+
22+runSendfile :: ByteString -> Application -> IO ()
23+runSendfile sf app = runOne (Just sf) app >> runSendfile sf app
24+
25+runOne :: Maybe ByteString -> Application -> IO ()
26+runOne sf app = do
27+ socket <- c'accept 0 nullPtr nullPtr
28+ headersBS <- readNetstring socket
29+ let headers@((_, conLenS):_) = parseHeaders $ S.split 0 headersBS
30+ let conLen = case reads conLenS of
31+ (i, _):_ -> i
32+ [] -> 0
33+ conLenI <- newIORef conLen
34+ runGeneric headers (requestBodyFunc $ input socket conLenI)
35+ (write socket) sf app
36+ drain socket conLenI
37+ _ <- c'close socket
38+ return ()
39+
40+write :: CInt -> S.ByteString -> IO ()
41+write socket bs = S.unsafeUseAsCStringLen bs $ \(s, l) -> do
42+ _ <- c'write socket s (fromIntegral l)
43+ return ()
44+
45+input :: CInt -> IORef Int -> Int -> IO (Maybe S.ByteString)
46+input socket ilen rlen = do
47+ len <- readIORef ilen
48+ case len of
49+ 0 -> return Nothing
50+ _ -> do
51+ bs <- readByteString socket
52+ $ minimum [defaultChunkSize, len, rlen]
53+ writeIORef ilen $ len - S.length bs
54+ return $ Just bs
55+
56+drain :: CInt -> IORef Int -> IO () -- FIXME do it in chunks
57+drain socket ilen = do
58+ len <- readIORef ilen
59+ _ <- readByteString socket len
60+ return ()
61+
62+parseHeaders :: [S.ByteString] -> [(String, String)]
63+parseHeaders (x:y:z) = (S8.unpack x, S8.unpack y) : parseHeaders z
64+parseHeaders _ = []
65+
66+readNetstring :: CInt -> IO S.ByteString
67+readNetstring socket = do
68+ len <- readLen 0
69+ bs <- readByteString socket len
70+ _ <- readByteString socket 1 -- the comma
71+ return bs
72+ where
73+ readLen l = do
74+ bs <- readByteString socket 1
75+ let [c] = S8.unpack bs
76+ if c == ':'
77+ then return l
78+ else readLen $ l * 10 + (fromEnum c - fromEnum '0')
79+
80+readByteString :: CInt -> Int -> IO S.ByteString
81+readByteString socket len = do
82+ buf <- mallocBytes len
83+ _ <- c'read socket buf $ fromIntegral len
84+ S.unsafePackCStringFinalizer (castPtr buf) len $ free buf
85+
86+foreign import ccall unsafe "accept"
87+ c'accept :: CInt -> Ptr a -> Ptr a -> IO CInt
88+
89+foreign import ccall unsafe "close"
90+ c'close :: CInt -> IO CInt
91+
92+foreign import ccall unsafe "write"
93+ c'write :: CInt -> Ptr CChar -> CInt -> IO CInt
94+
95+foreign import ccall unsafe "read"
96+ c'read :: CInt -> Ptr CChar -> CInt -> IO CInt