@@ -0,0 +1,79 @@
1+module Network.Wai.Frontend.MonadCGI
2+ ( cgiToApp
3+ , cgiToAppGeneric
4+ ) where
5+
6+import Network.Wai
7+import Network.CGI.Monad
8+import Network.CGI.Protocol
9+import Network.HTTP.Types (Status (..))
10+import Control.Monad.IO.Class (liftIO)
11+import Data.CaseInsensitive (original)
12+
13+import Data.Conduit
14+import Data.Conduit.Lazy (lazyConsume)
15+
16+import qualified Data.Map as Map
17+import qualified Data.ByteString.Lazy as BS
18+import qualified Data.ByteString.Char8 as S8
19+
20+import Control.Arrow (first)
21+import Data.Char (toUpper)
22+import Data.String (fromString)
23+
24+safeRead :: Read a => a -> String -> a
25+safeRead d s = case reads s of
26+ ((x, _):_) -> x
27+ _ -> d
28+
29+cgiToApp :: CGI CGIResult -> Application
30+cgiToApp = cgiToAppGeneric id
31+
32+unbufferSource :: Monad m => BufferedSource m a -> Source m a
33+unbufferSource bsrc = Source $ return $ PreparedSource
34+ { sourcePull = bsourcePull bsrc
35+ , sourceClose = bsourceClose bsrc
36+ }
37+
38+cgiToAppGeneric :: Monad m
39+ => (m (Headers, CGIResult) -> IO (Headers, CGIResult))
40+ -> CGIT m CGIResult
41+ -> Application
42+cgiToAppGeneric toIO cgi env = do
43+ input <- fmap BS.fromChunks $ lazyConsume $ unbufferSource $ requestBody env
44+ let vars = map (first fixVarName . go) (requestHeaders env)
45+ ++ getCgiVars env
46+ (inputs, body') = decodeInput vars input
47+ req = CGIRequest
48+ { cgiVars = Map.fromList $ vars
49+ , cgiInputs = inputs
50+ , cgiRequestBody = body'
51+ }
52+ (headers'', output') <- liftIO $ toIO $ runCGIT cgi req
53+ let output = case output' of
54+ CGIOutput bs -> bs
55+ CGINothing -> BS.empty
56+ let headers' = map (\(HeaderName x, y) ->
57+ (fromString x, S8.pack y)) headers''
58+ let status' = case lookup (fromString "Status") headers' of
59+ Nothing -> 200
60+ Just s -> safeRead 200 $ S8.unpack s
61+ return $ responseLBS (Status status' S8.empty) headers' output
62+ where
63+ go (x, y) = (S8.unpack $ original x, S8.unpack y)
64+
65+fixVarName :: String -> String
66+fixVarName = ((++) $ "HTTP_") . map fixVarNameChar
67+
68+fixVarNameChar :: Char -> Char
69+fixVarNameChar '-' = '_'
70+fixVarNameChar c = toUpper c
71+
72+getCgiVars :: Request -> [(String, String)]
73+getCgiVars e =
74+ [ ("PATH_INFO", S8.unpack $ rawPathInfo e)
75+ , ("REQUEST_METHOD", show $ requestMethod e)
76+ , ("QUERY_STRING", S8.unpack $ rawQueryString e)
77+ , ("SERVER_NAME", S8.unpack $ serverName e)
78+ , ("SERVER_PORT", show $ serverPort e)
79+ ]