@@ -0,0 +1,100 @@
1+module Network.Wai.Handler.FastCGI
2+ ( run
3+ ) where
4+
5+import qualified Network.Wai as W
6+import Network.FastCGI
7+import Control.Concurrent (forkIO)
8+import Control.Monad.Trans
9+import Control.Monad.Reader
10+import qualified Data.ByteString.Char8 as B
11+import qualified System.IO
12+import Control.Arrow ((***))
13+import Data.Char (toLower)
14+import Data.Maybe (fromMaybe)
15+import Data.ByteString.Lazy.Internal (defaultChunkSize)
16+import Network.Wai.Enumerator (fromEitherFile)
17+
18+run :: W.Application -> IO ()
19+run = acceptLoop forkIO . conv
20+
21+safeRead :: Read a => a -> String -> a
22+safeRead d s =
23+ case reads s of
24+ ((x, _):_) -> x
25+ [] -> d
26+
27+lookup' :: String -> [(String, String)] -> String
28+lookup' key pairs = fromMaybe "" $ lookup key pairs
29+
30+conv :: W.Application -> FastCGI ()
31+conv app = do
32+ vars <- getAllRequestVariables
33+ let rmethod = W.methodFromBS $ B.pack $ lookup' "REQUEST_METHOD" vars
34+ pinfo = lookup' "PATH_INFO" vars
35+ qstring = lookup' "QUERY_STRING" vars
36+ servername = lookup' "SERVER_NAME" vars
37+ serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
38+ contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
39+ remoteHost' =
40+ case lookup "REMOTE_HOST" vars of
41+ Just x -> x
42+ Nothing ->
43+ case lookup "REMOTE_ADDR" vars of
44+ Just x -> x
45+ Nothing -> ""
46+ urlScheme' =
47+ case map toLower $ lookup' "SERVER_PROTOCOL" vars of -- FIXME get httpVersion too
48+ "https" -> W.HTTPS
49+ _ -> W.HTTP
50+ state <- ask
51+ let env = W.Request
52+ { W.requestMethod = rmethod
53+ , W.pathInfo = B.pack pinfo
54+ , W.queryString = B.pack qstring
55+ , W.serverName = B.pack servername
56+ , W.serverPort = serverport
57+ , W.requestHeaders = map (cleanupVarName *** B.pack) vars
58+ , W.urlScheme = urlScheme'
59+ , W.requestBody = requestBody state contentLength
60+ , W.errorHandler = System.IO.hPutStr System.IO.stderr
61+ , W.remoteHost = B.pack remoteHost'
62+ , W.httpVersion = W.HttpVersion B.empty
63+ }
64+ res <- liftIO $ app env
65+ setResponseStatus $ W.statusCode $ W.status res
66+ mapM_ setHeader $ W.responseHeaders res
67+ _ <- liftIO $ W.runEnumerator
68+ (fromEitherFile (W.responseBody res))
69+ (myPut state)
70+ ()
71+ return ()
72+
73+cleanupVarName :: String -> W.RequestHeader
74+cleanupVarName ('H':'T':'T':'P':'_':a:as) =
75+ W.requestHeaderFromBS $ B.pack $ a : helper' as where
76+ helper' ('_':x:rest) = '-' : x : helper' rest
77+ helper' (x:rest) = toLower x : helper' rest
78+ helper' [] = []
79+cleanupVarName "CONTENT_TYPE" = W.ReqContentType
80+cleanupVarName "CONTENT_LENGTH" = W.ReqContentLength
81+cleanupVarName "SCRIPT_NAME" = W.requestHeaderFromBS $ B.pack "CGI-Script-Name"
82+cleanupVarName x = W.requestHeaderFromBS $ B.pack x -- FIXME remove?
83+
84+requestBody :: FastCGIState -> Int -> W.Source
85+requestBody _ 0 = W.Source $ return Nothing
86+requestBody state len = W.Source $ do
87+ bs <- runReaderT (fGet defaultChunkSize) state
88+ let newLen = len - B.length bs
89+ return $ Just (bs, requestBody state newLen)
90+
91+setHeader :: MonadFastCGI m => (W.ResponseHeader, B.ByteString) -> m ()
92+setHeader (k, v) =
93+ setResponseHeader
94+ (HttpExtensionHeader $ B.unpack $ W.responseHeaderToBS k)
95+ (B.unpack v)
96+
97+myPut :: FastCGIState -> () -> B.ByteString -> IO (Either () ())
98+myPut state _ bs = do
99+ runReaderT (fPut bs) state
100+ return $ Right ()