@@ -0,0 +1,95 @@
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 (run'')
9+import Network.Wai.Handler.Helper (requestBodyFunc)
10+import Foreign.Ptr
11+import Foreign.Marshal.Alloc
12+import Foreign.C
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 :: String -> Application -> IO ()
23+runSendfile sf app = runOne (Just sf) app >> runSendfile sf app
24+
25+runOne :: Maybe String -> 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+ run'' 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 -> IO (Maybe S.ByteString)
46+input socket ilen = do
47+ len <- readIORef ilen
48+ case len of
49+ 0 -> return Nothing
50+ _ -> do
51+ bs <- readByteString socket $ min defaultChunkSize len
52+ writeIORef ilen $ len - S.length bs
53+ return $ Just bs
54+
55+drain :: CInt -> IORef Int -> IO () -- FIXME do it in chunks
56+drain socket ilen = do
57+ len <- readIORef ilen
58+ _ <- readByteString socket len
59+ return ()
60+
61+parseHeaders :: [S.ByteString] -> [(String, String)]
62+parseHeaders (x:y:z) = (S8.unpack x, S8.unpack y) : parseHeaders z
63+parseHeaders _ = []
64+
65+readNetstring :: CInt -> IO S.ByteString
66+readNetstring socket = do
67+ len <- readLen 0
68+ bs <- readByteString socket len
69+ _ <- readByteString socket 1 -- the comma
70+ return bs
71+ where
72+ readLen l = do
73+ bs <- readByteString socket 1
74+ let [c] = S8.unpack bs
75+ if c == ':'
76+ then return l
77+ else readLen $ l * 10 + (fromEnum c - fromEnum '0')
78+
79+readByteString :: CInt -> Int -> IO S.ByteString
80+readByteString socket len = do
81+ buf <- mallocBytes len
82+ _ <- c'read socket buf $ fromIntegral len
83+ S.unsafePackCStringFinalizer (castPtr buf) len $ free buf
84+
85+foreign import ccall unsafe "accept"
86+ c'accept :: CInt -> Ptr a -> Ptr a -> IO CInt
87+
88+foreign import ccall unsafe "close"
89+ c'close :: CInt -> IO CInt
90+
91+foreign import ccall unsafe "write"
92+ c'write :: CInt -> Ptr CChar -> CInt -> IO CInt
93+
94+foreign import ccall unsafe "read"
95+ c'read :: CInt -> Ptr CChar -> CInt -> IO CInt