ad63f02 · typeable/wai

Network/Wai/Handler/CGI.hs+19−16

@@ -1,10 +1,11 @@

1+{-# LANGUAGE OverloadedStrings #-}

12module Network.Wai.Handler.CGI

23 ( run

34 , run'

45 ) where

56

67import Network.Wai

7−import Network.Wai.Enumerator (fromEitherFile)

8+import Network.Wai.Enumerator (fromResponseBody)

89import Network.Wai.Handler.Helper

910import System.Environment (getEnvironment)

1011import Data.Maybe (fromMaybe)

@@ -12,6 +13,7 @@ import qualified Data.ByteString.Char8 as B

1213import Control.Arrow ((***))

1314import Data.Char (toLower)

1415import qualified System.IO

16+import Data.String (fromString)

1517

1618safeRead :: Read a => a -> String -> a

1719safeRead d s =

@@ -33,7 +35,7 @@ run' :: [(String, String)] -- ^ all variables

3335 -> Application

3436 -> IO ()

3537run' vars inputH outputH app = do

36− let rmethod = safeRead GET $ lookup' "REQUEST_METHOD" vars

38+ let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars

3739 pinfo = lookup' "PATH_INFO" vars

3840 qstring = lookup' "QUERY_STRING" vars

3941 servername = lookup' "SERVER_NAME" vars

@@ -46,10 +48,10 @@ run' vars inputH outputH app = do

4648 case lookup "REMOTE_ADDR" vars of

4749 Just x -> x

4850 Nothing -> ""

49− urlScheme' =

51+ isSecure' =

5052 case map toLower $ lookup' "SERVER_PROTOCOL" vars of

51− "https" -> HTTPS

52− _ -> HTTP

53+ "https" -> True

54+ _ -> False

5355 let env = Request

5456 { requestMethod = rmethod

5557 , pathInfo = B.pack pinfo

@@ -57,16 +59,16 @@ run' vars inputH outputH app = do

5759 , serverName = B.pack servername

5860 , serverPort = serverport

5961 , requestHeaders = map (cleanupVarName *** B.pack) vars

60− , urlScheme = urlScheme'

62+ , isSecure = isSecure'

6163 , requestBody = requestBodyHandle inputH contentLength

6264 , errorHandler = System.IO.hPutStr System.IO.stderr

6365 , remoteHost = B.pack remoteHost'

64− , httpVersion = HttpVersion B.empty

66+ , httpVersion = "1.1" -- FIXME

6567 }

6668 res <- app env

6769 let h = responseHeaders res

68− let h' = case lookup ContentType h of

69− Nothing -> (ContentType, B.pack "text/html; charset=utf-8")

70+ let h' = case lookup "Content-Type" h of

71+ Nothing -> ("Content-Type", "text/html; charset=utf-8")

7072 : h

7173 Just _ -> h

7274 let hPut = B.hPut outputH

@@ -75,7 +77,7 @@ run' vars inputH outputH app = do

7577 hPut $ B.singleton '\n'

7678 mapM_ (printHeader hPut) h'

7779 hPut $ B.singleton '\n'

78− _ <- runEnumerator (fromEitherFile (responseBody res)) (myPut outputH) ()

80+ _ <- runEnumerator (fromResponseBody (responseBody res)) (myPut outputH) ()

7981 return ()

8082

8183myPut :: System.IO.Handle -> () -> B.ByteString -> IO (Either () ())

@@ -85,18 +87,19 @@ printHeader :: (B.ByteString -> IO ())

8587 -> (ResponseHeader, B.ByteString)

8688 -> IO ()

8789printHeader f (x, y) = do

88− f $ responseHeaderToBS x

90+ f $ ciOriginal x

8991 f $ B.pack ": "

9092 f y

9193 f $ B.singleton '\n'

9294

9395cleanupVarName :: String -> RequestHeader

9496cleanupVarName ('H':'T':'T':'P':'_':a:as) =

95− requestHeaderFromBS $ B.pack $ a : helper' as where

97+ fromString $ a : helper' as

98+ where

9699 helper' ('_':x:rest) = '-' : x : helper' rest

97100 helper' (x:rest) = toLower x : helper' rest

98101 helper' [] = []

99−cleanupVarName "CONTENT_TYPE" = ReqContentType

100−cleanupVarName "CONTENT_LENGTH" = ReqContentLength

101−cleanupVarName "SCRIPT_NAME" = requestHeaderFromBS $ B.pack "CGI-Script-Name"

102−cleanupVarName x = requestHeaderFromBS $ B.pack x -- FIXME remove?

102+cleanupVarName "CONTENT_TYPE" = "Content-Type"

103+cleanupVarName "CONTENT_LENGTH" = "Content-Length"

104+cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"

105+cleanupVarName x = fromString x -- FIXME remove?

Network/Wai/Handler/SimpleServer.hs+13−12

@@ -1,5 +1,6 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE OverloadedStrings #-}

34---------------------------------------------------------

45-- |

56-- Module : Network.Wai.Handler.SimpleServer

@@ -23,6 +24,7 @@ import qualified System.IO

2324

2425import Data.ByteString (ByteString)

2526import qualified Data.ByteString.Char8 as B

27+import qualified Data.ByteString.Lazy as L

2628import Network

2729 ( listenOn, accept, sClose, PortID(PortNumber), Socket

2830 , withSocketsDo)

@@ -100,18 +102,16 @@ parseRequest port lines' handle remoteHost' = do

100102 case lines' of

101103 (_:_:_) -> return ()

102104 _ -> throwIO $ NotEnoughLines $ map B.unpack lines'

103− (method', rpath', gets, httpversion) <- parseFirst $ head lines'

104− let method = methodFromBS method'

105+ (method, rpath', gets, httpversion) <- parseFirst $ head lines'

105106 let rpath = '/' : case B.unpack rpath' of

106107 ('/':x) -> x

107108 _ -> B.unpack rpath'

108− let heads = map (first requestHeaderFromBS . parseHeaderNoAttr)

109− $ tail lines'

110− let host' = lookup Host heads

109+ let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'

110+ let host' = lookup "Host" heads

111111 unless (isJust host') $ throwIO HostNotIncluded

112112 let host = fromJust host'

113113 let len = fromMaybe 0 $ do

114− bs <- lookup ReqContentLength heads

114+ bs <- lookup "Content-Length" heads

115115 let str = B.unpack bs

116116 case reads str of

117117 (x, _):_ -> Just x

@@ -125,7 +125,7 @@ parseRequest port lines' handle remoteHost' = do

125125 , serverName = serverName'

126126 , serverPort = port

127127 , requestHeaders = heads

128− , urlScheme = HTTP

128+ , isSecure = False

129129 , requestBody = requestBodyHandle handle len

130130 , errorHandler = System.IO.hPutStr System.IO.stderr

131131 , remoteHost = B.pack remoteHost'

@@ -142,12 +142,12 @@ parseFirst s = do

142142 let (hfirst, hsecond) = B.splitAt 5 http'

143143 unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp

144144 let (rpath, qstring) = B.break (== '?') query

145− return (method, rpath, qstring, httpVersionFromBS hsecond)

145+ return (method, rpath, qstring, hsecond)

146146

147147sendResponse :: HttpVersion -> Handle -> Response -> IO ()

148148sendResponse httpversion h res = do

149149 B.hPut h $ B.pack "HTTP/"

150− B.hPut h $ httpVersionToBS httpversion

150+ B.hPut h $ httpversion

151151 B.hPut h $ B.pack " "

152152 B.hPut h $ B.pack $ show $ statusCode $ status res

153153 B.hPut h $ B.pack " "

@@ -156,14 +156,15 @@ sendResponse httpversion h res = do

156156 mapM_ putHeader $ responseHeaders res

157157 B.hPut h $ B.pack "\r\n"

158158 case responseBody res of

159− Left fp -> unsafeSendFile h fp

160− Right (Enumerator enum) -> enum myPut h >> return ()

159+ ResponseFile fp -> unsafeSendFile h fp

160+ ResponseEnumerator (Enumerator enum) -> enum myPut h >> return ()

161+ ResponseLBS lbs -> L.hPut h lbs

161162 where

162163 myPut _ bs = do

163164 B.hPut h bs

164165 return (Right h)

165166 putHeader (x, y) = do

166− B.hPut h $ responseHeaderToBS x

167+ B.hPut h $ ciOriginal x

167168 B.hPut h $ B.pack ": "

168169 B.hPut h y

169170 B.hPut h $ B.pack "\r\n"

Network/Wai/Middleware/CleanPath.hs+5−3

@@ -1,7 +1,9 @@

1+{-# LANGUAGE OverloadedStrings #-}

12module Network.Wai.Middleware.CleanPath (cleanPath, cleanPathRel, splitPath) where

23

34import Network.Wai

45import qualified Data.ByteString.Char8 as B

6+import qualified Data.ByteString.Lazy as L

57import Network.URI (unEscapeString)

68

79-- | Performs redirects as per 'splitPath'.

@@ -10,9 +12,9 @@ cleanPathRel prefix app env =

1012 case splitPath $ pathInfo env of

1113 Right pieces -> app pieces env

1214 Left p -> return

13− . Response Status301

14− [(Location, B.concat [prefix, p, suffix])]

15− $ Right emptyEnum

15+ . Response status301

16+ [("Location", B.concat [prefix, p, suffix])]

17+ $ ResponseLBS L.empty

1618 where

1719 -- include the query string if present

1820 suffix =

Network/Wai/Middleware/Gzip.hs+8−7

@@ -1,5 +1,6 @@

11{-# LANGUAGE Rank2Types #-}

22{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE OverloadedStrings #-}

34---------------------------------------------------------

45-- |

56-- Module : Network.Wai.Middleware.Gzip

@@ -16,6 +17,7 @@

1617module Network.Wai.Middleware.Gzip (gzip) where

1718

1819import Network.Wai

20+import Network.Wai.Enumerator (fromResponseBody)

1921import Network.Wai.Zlib

2022import Data.Maybe (fromMaybe)

2123import qualified Data.ByteString.Char8 as B

@@ -37,23 +39,22 @@ gzip :: Middleware

3739gzip app env = do

3840 res <- app env

3941 case responseBody res of

40− Left _ -> return res

41− Right _ -> do

42+ ResponseFile _ -> return res

43+ _ -> do

4244 let enc = fromMaybe []

4345 $ (splitCommas . B.unpack)

44− `fmap` lookup AcceptEncoding

46+ `fmap` lookup "Accept-Encoding"

4547 (requestHeaders env)

4648 if "gzip" `elem` enc

4749 then return res

4850 { responseBody = compressE $ responseBody res

49− , responseHeaders = (ContentEncoding, B.pack "gzip")

51+ , responseHeaders = ("Content-Encoding", "gzip")

5052 : responseHeaders res

5153 }

5254 else return res

5355

54−compressE :: Either FilePath Enumerator -> Either FilePath Enumerator

55−compressE (Left fp) = Left fp

56−compressE (Right e) = Right $ compress e

56+compressE :: ResponseBody -> ResponseBody

57+compressE = ResponseEnumerator . compress . fromResponseBody

5758

5859splitCommas :: String -> [String]

5960splitCommas [] = []

Network/Wai/Middleware/Jsonp.hs+7−6

@@ -1,3 +1,4 @@

1+{-# LANGUAGE OverloadedStrings #-}

12---------------------------------------------------------

23-- |

34-- Module : Network.Wai.Middleware.Jsonp

@@ -14,7 +15,7 @@

1415module Network.Wai.Middleware.Jsonp (jsonp) where

1516

1617import Network.Wai

17−import Network.Wai.Enumerator (fromEitherFile)

18+import Network.Wai.Enumerator (fromResponseBody)

1819import qualified Data.ByteString.Char8 as B8

1920import Data.Maybe (fromMaybe)

2021

@@ -42,7 +43,7 @@ dropQM bs

4243-- callback function.

4344jsonp :: Middleware

4445jsonp app env = do

45− let accept = fromMaybe B8.empty $ lookup Accept $ requestHeaders env

46+ let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env

4647 let callback :: Maybe B8.ByteString

4748 callback =

4849 if B8.pack "text/javascript" `B8.isInfixOf` accept

@@ -52,15 +53,15 @@ jsonp app env = do

5253 case callback of

5354 Nothing -> env

5455 Just _ -> env

55− { requestHeaders = changeVal Accept

56+ { requestHeaders = changeVal "Accept"

5657 "application/json"

5758 $ requestHeaders env

5859 }

5960 res <- app env'

60− case (fmap B8.unpack $ lookup ContentType $ responseHeaders res, callback) of

61+ case (fmap B8.unpack $ lookup "Content-Type" $ responseHeaders res, callback) of

6162 (Just "application/json", Just c) -> return $ res

62− { responseHeaders = changeVal ContentType "text/javascript" $ responseHeaders res

63− , responseBody = Right $ addCallback c $ fromEitherFile $ responseBody res

63+ { responseHeaders = changeVal "Content-Type" "text/javascript" $ responseHeaders res

64+ , responseBody = ResponseEnumerator $ addCallback c $ fromResponseBody $ responseBody res

6465 }

6566 _ -> return res

6667

Network/Wai/Parse.hs+2−1

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

23-- | Some helpers for parsing data out of a raw WAI 'Request'.

34

45module Network.Wai.Parse

@@ -164,7 +165,7 @@ parseRequestBody :: Sink x y

164165 -> IO ([Param], [File y])

165166parseRequestBody sink req = do

166167 let ctype = do

167− ctype' <- lookup ReqContentType $ requestHeaders req

168+ ctype' <- lookup "Content-Type" $ requestHeaders req

168169 if urlenc `S.isPrefixOf` ctype'

169170 then Just Nothing

170171 else if formBound `S.isPrefixOf` ctype'

wai-extra.cabal+2−2

@@ -1,5 +1,5 @@

11Name: wai-extra

2−Version: 0.1.3.1

2+Version: 0.2.0

33Synopsis: Provides some basic WAI handlers and middleware.

44Description: The goal here is to provide common features without many dependencies.

55License: BSD3

@@ -18,7 +18,7 @@ extra-source-files: cbits/crc32.h cbits/inffast.h cbits/inflate.h

1818Library

1919 Build-Depends: base >= 3 && < 5,

2020 bytestring >= 0.9 && < 0.10,

21− wai >= 0.0.0 && < 0.2,

21+ wai >= 0.2.0 && < 0.3,

2222 old-locale >= 1.0 && < 1.1,

2323 time >= 1.1.4 && < 1.2,

2424 sendfile >= 0.6.1 && < 0.7,