@@ -1,17 +1,20 @@
1−module Hack.Frontend.MonadCGI
1+module Network.Wai.Frontend.MonadCGI
22 ( cgiToApp
33 , cgiToAppGeneric
44 ) where
55
6−import Hack
6+import Network.Wai
7+import Network.Wai.Source
78import Network.CGI.Monad
89import Network.CGI.Protocol
910
1011import qualified Data.Map as Map
1112import qualified Data.ByteString.Lazy as BS
13+import qualified Data.ByteString.Char8 as S8
1214
1315import Control.Arrow (first)
1416import Data.Char (toUpper)
17+import Data.String (fromString)
1518
1619safeRead :: Read a => a -> String -> a
1720safeRead d s = case reads s of
@@ -26,8 +29,9 @@ cgiToAppGeneric :: Monad m
2629 -> CGIT m CGIResult
2730 -> Application
2831cgiToAppGeneric toIO cgi env = do
29− let vars = map (first fixVarName) (http env)++ getCgiVars env
30− input = hackInput env
32+ input <- toLBS $ requestBody env
33+ let vars = map (first fixVarName . go) (requestHeaders env)
34+ ++ getCgiVars env
3135 (inputs, body') = decodeInput vars input
3236 req = CGIRequest
3337 { cgiVars = Map.fromList $ vars
@@ -38,11 +42,14 @@ cgiToAppGeneric toIO cgi env = do
3842 let output = case output' of
3943 CGIOutput bs -> bs
4044 CGINothing -> BS.empty
41− let headers' = map (\(HeaderName x, y) -> (x, y)) headers''
42− let status' = case lookup "Status" headers' of
45+ let headers' = map (\(HeaderName x, y) ->
46+ (fromString x, S8.pack y)) headers''
47+ let status' = case lookup (fromString "Status") headers' of
4348 Nothing -> 200
44− Just s -> safeRead 200 s
45− return $ Response status' headers' output
49+ Just s -> safeRead 200 $ S8.unpack s
50+ return $ Response (Status status' S8.empty) headers' $ ResponseLBS output
51+ where
52+ go (x, y) = (S8.unpack $ ciOriginal x, S8.unpack y)
4653
4754fixVarName :: String -> String
4855fixVarName = ((++) $ "HTTP_") . map fixVarNameChar
@@ -51,12 +58,11 @@ fixVarNameChar :: Char -> Char
5158fixVarNameChar '-' = '_'
5259fixVarNameChar c = toUpper c
5360
54−getCgiVars :: Env -> [(String, String)]
61+getCgiVars :: Request -> [(String, String)]
5562getCgiVars e =
56− [ ("PATH_INFO", pathInfo e)
63+ [ ("PATH_INFO", S8.unpack $ pathInfo e)
5764 , ("REQUEST_METHOD", show $ requestMethod e)
58− , ("SCRIPT_NAME", scriptName e)
59− , ("QUERY_STRING", queryString e)
60− , ("SERVER_NAME", serverName e)
65+ , ("QUERY_STRING", S8.unpack $ queryString e)
66+ , ("SERVER_NAME", S8.unpack $ serverName e)
6167 , ("SERVER_PORT", show $ serverPort e)
6268 ]