1c4a41d · typeable/wai

Network/Wai/Handler/CGI.hs+14−8

@@ -29,6 +29,10 @@ import Blaze.ByteString.Builder.Enumerator (builderToByteString)

2929import Control.Monad.IO.Class (liftIO)

3030import Data.ByteString.Lazy.Internal (defaultChunkSize)

3131import System.IO (Handle)

32+import Network.HTTP.Types (Status (..))

33+import qualified Network.HTTP.Types as H

34+import Data.Ascii (ciToByteString)

35+import qualified Data.Ascii as A

3236

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

3438safeRead d s =

@@ -94,16 +98,18 @@ run'' vars inputH outputH xsendfile app = do

9498 a:_ -> addrAddress a

9599 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'

96100 let env = Request

97− { requestMethod = rmethod

98− , pathInfo = B.pack pinfo

99− , queryString = B.pack qstring

101+ { requestMethod = A.unsafeFromByteString rmethod

102+ , rawPathInfo = B.pack pinfo

103+ , pathInfo = H.decodePathSegments $ B.pack pinfo

104+ , rawQueryString = B.pack qstring

105+ , queryString = H.parseQuery $ B.pack qstring

100106 , serverName = B.pack servername

101107 , serverPort = serverport

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

108+ , requestHeaders = map (cleanupVarName *** A.unsafeFromString) vars

103109 , isSecure = isSecure'

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

105111 , remoteHost = addr

106− , httpVersion = "1.1" -- FIXME

112+ , httpVersion = H.http11 -- FIXME

107113 }

108114 -- FIXME worry about exception?

109115 res <- run_ $ inputH contentLength $$ app env

@@ -117,9 +123,9 @@ run'' vars inputH outputH xsendfile app = do

117123 status (Status i m) = (fromByteString "Status", mconcat

118124 [ fromString $ show i

119125 , fromChar ' '

120− , fromByteString m

126+ , fromByteString $ A.toByteString m

121127 ])

122− header' (x, y) = (fromByteString $ ciOriginal x, fromByteString y)

128+ header' (x, y) = (fromByteString $ ciToByteString x, fromByteString $ A.toByteString y)

123129 header (x, y) = mconcat

124130 [ x

125131 , fromByteString ": "

@@ -143,7 +149,7 @@ run'' vars inputH outputH xsendfile app = do

143149 Nothing -> ("Content-Type", "text/html; charset=utf-8") : h

144150 Just _ -> h

145151

146−cleanupVarName :: String -> RequestHeader

152+cleanupVarName :: String -> A.CIAscii

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

148154 String.fromString $ a : helper' as

149155 where

Network/Wai/Middleware/AcceptOverride.hs+8−8

@@ -5,22 +5,22 @@ module Network.Wai.Middleware.AcceptOverride

55 ) where

66

77import Network.Wai

8−import Network.Wai.Parse (parseQueryString)

9−import qualified Data.ByteString.Char8 as B8

8+import Control.Monad (join)

9+import qualified Data.Ascii as A

1010

1111acceptOverride :: Middleware

1212acceptOverride app req =

1313 app req'

1414 where

1515 req' =

16− case lookup "_accept" $ parseQueryString $ queryString req of

16+ case join $ lookup "_accept" $ queryString req of

1717 Nothing -> req

18− Just a -> req { requestHeaders = changeVal "Accept" (B8.unpack a) $ requestHeaders req}

18+ Just a -> req { requestHeaders = changeVal "Accept" (A.unsafeFromByteString a) $ requestHeaders req}

1919

2020changeVal :: Eq a

2121 => a

22− -> String

23− -> [(a, B8.ByteString)]

24− -> [(a, B8.ByteString)]

25−changeVal key val old = (key, B8.pack val)

22+ -> A.Ascii

23+ -> [(a, A.Ascii)]

24+ -> [(a, A.Ascii)]

25+changeVal key val old = (key, val)

2626 : filter (\(k, _) -> k /= key) old

Network/Wai/Middleware/CleanPath.hs+11−7

@@ -6,22 +6,26 @@ module Network.Wai.Middleware.CleanPath

66import Network.Wai

77import qualified Data.ByteString.Char8 as B

88import qualified Data.ByteString.Lazy as L

9+import Network.HTTP.Types (status301)

10+import Data.Text (Text)

11+import qualified Data.Ascii as A

12+import Data.Monoid (mconcat)

913

10−cleanPath :: (B.ByteString -> Either B.ByteString [String])

11− -> B.ByteString

12− -> ([String] -> Application)

14+cleanPath :: ([Text] -> Either A.Ascii [Text])

15+ -> A.Ascii

16+ -> ([Text] -> Application)

1317 -> Application

1418cleanPath splitter prefix app env =

1519 case splitter $ pathInfo env of

1620 Right pieces -> app pieces env

1721 Left p -> return

1822 $ responseLBS status301

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

23+ [("Location", mconcat [prefix, p, A.unsafeFromByteString suffix])]

2024 $ L.empty

2125 where

2226 -- include the query string if present

2327 suffix =

24− case B.uncons $ queryString env of

28+ case B.uncons $ rawQueryString env of

2529 Nothing -> B.empty

26− Just ('?', _) -> queryString env

27− _ -> B.cons '?' $ queryString env

30+ Just ('?', _) -> rawQueryString env

31+ _ -> B.cons '?' $ rawQueryString env

Network/Wai/Middleware/Debug.hs+6−6

@@ -1,22 +1,22 @@

11{-# LANGUAGE OverloadedStrings #-}

22module Network.Wai.Middleware.Debug (debug) where

33

4−import Network.Wai (Middleware, requestMethod, requestHeaders, pathInfo, queryString)

4+import Network.Wai (Middleware, requestMethod, requestHeaders, rawPathInfo, rawQueryString)

55import Data.ByteString.Char8 (unpack)

66import System.IO (hPutStrLn, stderr)

77import Control.Monad.IO.Class (liftIO)

8−import Data.Maybe

8+import qualified Data.Ascii as A

99

1010-- | Prints a message to 'stderr' for each request.

1111debug :: Middleware

1212debug app req = do

1313 liftIO $ hPutStrLn stderr $ concat

14− [ unpack $ requestMethod req

14+ [ A.toString $ requestMethod req

1515 , " "

16− , unpack $ pathInfo req

17− , unpack $ queryString req

16+ , unpack $ rawPathInfo req

17+ , unpack $ rawQueryString req

1818 , "\n"

19− , (++) "Accept: " $ unpack $ fromMaybe "" $ lookup "Accept" $ requestHeaders req

19+ , (++) "Accept: " $ maybe "" A.toString $ lookup "Accept" $ requestHeaders req

2020 , "\n"

2121 ]

2222 app req

Network/Wai/Middleware/Gzip.hs+2−2

@@ -19,8 +19,8 @@ module Network.Wai.Middleware.Gzip (gzip) where

1919import Network.Wai

2020import Network.Wai.Zlib

2121import Data.Maybe (fromMaybe)

22−import qualified Data.ByteString.Char8 as B

2322import Data.Enumerator (($$), joinI)

23+import qualified Data.Ascii as A

2424

2525-- | Use gzip to compress the body of the response.

2626--

@@ -43,7 +43,7 @@ gzip files app env = do

4343 then ResponseEnumerator $ compressE $ responseEnumerator res

4444 else res

4545 where

46− enc = fromMaybe [] $ (splitCommas . B.unpack)

46+ enc = fromMaybe [] $ (splitCommas . A.toString)

4747 `fmap` lookup "Accept-Encoding" (requestHeaders env)

4848

4949compressE :: (forall a. ResponseEnumerator a)

Network/Wai/Middleware/Jsonp.hs+11−23

@@ -17,26 +17,12 @@ module Network.Wai.Middleware.Jsonp (jsonp) where

1717

1818import Network.Wai

1919import qualified Data.ByteString.Char8 as B8

20−import Data.Maybe (fromMaybe)

2120import Data.Enumerator (($$), enumList, Step (..), Enumerator, Iteratee, Enumeratee, joinI, checkDone, continue, Stream (..), (>>==))

2221import Blaze.ByteString.Builder (copyByteString, Builder)

2322import Blaze.ByteString.Builder.Char8 (fromChar)

2423import Data.Monoid (mappend)

25−

26−takeCallback :: B8.ByteString -> Maybe B8.ByteString

27−takeCallback bs | B8.null bs = Nothing

28−takeCallback bs =

29− let (x, y) = B8.break (== '=') bs

30− (y', z) = B8.break (== '&') $ B8.drop 1 y

31− in if x == B8.pack "callback"

32− then Just y'

33− else takeCallback $ B8.drop 1 z

34−

35−dropQM :: B8.ByteString -> B8.ByteString

36−dropQM bs

37− | B8.null bs = bs

38− | B8.head bs == '?' = B8.tail bs

39− | otherwise = bs

24+import qualified Data.Ascii as A

25+import Control.Monad (join)

4026

4127-- | Wrap json responses in a jsonp callback.

4228--

@@ -47,11 +33,11 @@ dropQM bs

4733-- callback function.

4834jsonp :: Middleware

4935jsonp app env = do

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

36+ let accept = maybe B8.empty A.toByteString $ lookup "Accept" $ requestHeaders env

5137 let callback :: Maybe B8.ByteString

5238 callback =

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

54− then takeCallback $ dropQM $ queryString env

40+ then join $ lookup "callback" $ queryString env

5541 else Nothing

5642 let env' =

5743 case callback of

@@ -76,12 +62,14 @@ jsonp app env = do

7662 `mappend` b

7763 `mappend` fromChar ')'

7864 go c (ResponseEnumerator e) = addCallback c e

65+ go' :: B8.ByteString -> Response -> [(A.CIAscii, A.Ascii)] -> Iteratee B8.ByteString IO Response

7966 go' c r hs =

8067 case checkJSON hs of

8168 Just _ -> addCallback c $ responseEnumerator r

8269 Nothing -> return r

70+ checkJSON :: [(A.CIAscii, A.Ascii)] -> Maybe [(A.CIAscii, A.Ascii)]

8371 checkJSON hs =

84− case fmap B8.unpack $ lookup "Content-Type" hs of

72+ case fmap A.toString $ lookup "Content-Type" hs of

8573 Just "application/json" -> Just $ fixHeaders hs

8674 _ -> Nothing

8775 fixHeaders = changeVal "Content-Type" "text/javascript"

@@ -110,8 +98,8 @@ jsonp app env = do

11098

11199changeVal :: Eq a

112100 => a

113− -> String

114− -> [(a, B8.ByteString)]

115− -> [(a, B8.ByteString)]

116−changeVal key val old = (key, B8.pack val)

101+ -> A.Ascii

102+ -> [(a, A.Ascii)]

103+ -> [(a, A.Ascii)]

104+changeVal key val old = (key, val)

117105 : filter (\(k, _) -> k /= key) old

Network/Wai/Middleware/MethodOverride.hs+4−3

@@ -4,13 +4,14 @@ module Network.Wai.Middleware.MethodOverride

44 ) where

55

66import Network.Wai

7−import Network.Wai.Parse (parseQueryString)

7+import Control.Monad (join)

8+import Data.Ascii (unsafeFromByteString)

89

910methodOverride :: Middleware

1011methodOverride app req =

1112 app req'

1213 where

1314 req' =

14− case lookup "_method" $ parseQueryString $ queryString req of

15+ case join $ lookup "_method" $ queryString req of

1516 Nothing -> req

16− Just m -> req { requestMethod = m }

17+ Just m -> req { requestMethod = unsafeFromByteString m }

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

@@ -4,14 +4,13 @@ module Network.Wai.Middleware.Rewrite

44 ) where

55

66import Network.Wai

7−import qualified Data.ByteString.Char8 as B

87import System.Directory (doesFileExist)

98import Control.Monad.IO.Class (liftIO)

10−import Web.Routes.Base (decodePathInfo)

9+import Data.Text (Text, unpack, pack)

1110

1211-- | rewrite based on your own conversion rules

1312-- Example usage: rewrite (autoHtmlRewrite "static")

14−rewrite :: (B.ByteString -> IO B.ByteString) -> Middleware

13+rewrite :: ([Text] -> IO [Text]) -> Middleware

1514rewrite convert app req = do

1615 newPathInfo <- liftIO $ convert $ pathInfo req

1716 app req { pathInfo = newPathInfo }

@@ -21,13 +20,13 @@ rewrite convert app req = do

2120-- 1) for a directory foo/, check for foo/index.html

2221-- 2) for a non-directory bar, check for bar.html

2322-- if the file exists, do the rewrite

24−autoHtmlRewrite :: String -> B.ByteString -> IO B.ByteString

25−autoHtmlRewrite staticDir pInfo = do

23+autoHtmlRewrite :: String -> [Text] -> IO [Text]

24+autoHtmlRewrite staticDir pieces' = do

2625 fe <- doesFileExist $ staticDir ++ "/" ++ reWritePath

27− return $ if fe then B.pack reWritePath else pInfo

26+ return $ if fe then map pack reWritePieces else pieces'

2827 where

28+ pieces = map unpack pieces'

2929 reWritePath = concat $ map ((:) '/') reWritePieces

30− pieces = decodePathInfo $ B.unpack $ pInfo

3130 reWritePieces =

3231 if (null pieces) || (null $ last pieces)

3332 then pieces ++ ["index.html"]

Network/Wai/Parse.hs+8−6

@@ -33,7 +33,9 @@ import System.IO (hClose, openBinaryTempFile, Handle)

3333import Network.Wai

3434import Data.Enumerator (Iteratee, yield)

3535import qualified Data.Enumerator as E

36+import qualified Data.Enumerator.List as EL

3637import Control.Monad.IO.Class (liftIO)

38+import qualified Data.Ascii as A

3739

3840uncons :: S.ByteString -> Maybe (Word8, S.ByteString)

3941uncons s

@@ -161,7 +163,7 @@ parseRequestBody sink req = do

161163 -- NOTE: in general, url-encoded data will be in a single chunk.

162164 -- Therefore, I'm optimizing for the usual case by sticking with

163165 -- strict byte strings here.

164− bs <- E.consume

166+ bs <- EL.consume

165167 return (parseQueryString $ S.concat bs, [])

166168 Just (Just bound) -> -- multi-part

167169 let bound'' = S8.pack "--" `S.append` bound

@@ -179,7 +181,7 @@ parseRequestBody sink req = do

179181 else Nothing

180182 else Nothing

181183 ctype = do

182− ctype' <- lookup "Content-Type" $ requestHeaders req

184+ ctype' <- fmap A.toByteString $ lookup "Content-Type" $ requestHeaders req

183185 if urlenc `S.isPrefixOf` ctype'

184186 then Just Nothing

185187 else case boundary ctype' of

@@ -188,7 +190,7 @@ parseRequestBody sink req = do

188190

189191takeLine :: Iteratee S.ByteString IO (Maybe S.ByteString)

190192takeLine = do

191− mbs <- E.head

193+ mbs <- EL.head

192194 case mbs of

193195 Nothing -> return Nothing

194196 Just bs ->

@@ -297,7 +299,7 @@ sinkTillBound :: S.ByteString

297299 -> x

298300 -> Iteratee S.ByteString IO (x, Bool)

299301sinkTillBound bound iter seed = do

300− mbs <- E.head

302+ mbs <- EL.head

301303 case mbs of

302304 Nothing -> return (seed, False)

303305 Just bs -> go bs

@@ -310,7 +312,7 @@ sinkTillBound bound iter seed = do

310312 yield () $ E.Chunks [after]

311313 return (seed', True)

312314 PartialBound -> do

313− mbs <- E.head

315+ mbs <- EL.head

314316 case mbs of

315317 Nothing -> do

316318 seed' <- liftIO $ iter seed bs

@@ -320,7 +322,7 @@ sinkTillBound bound iter seed = do

320322 yield () $ E.Chunks [bs']

321323 sinkTillBound bound iter seed

322324 NoBound -> do

323− mbs <- E.head

325+ mbs <- EL.head

324326 case mbs of

325327 Nothing -> do

326328 seed' <- liftIO $ iter seed bs

wai-extra.cabal+6−4

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

11Name: wai-extra

2−Version: 0.3.3

2+Version: 0.4.0

33Synopsis: Provides some basic WAI handlers and middleware.

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

55License: BSD3

@@ -15,7 +15,7 @@ Stability: Stable

1515Library

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

1717 bytestring >= 0.9 && < 0.10,

18− wai >= 0.3.0 && < 0.4,

18+ wai >= 0.4 && < 0.5,

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

2020 time >= 1.1.4 && < 1.3,

2121 network >= 2.2.1.5 && < 2.4,

@@ -23,9 +23,11 @@ Library

2323 zlib-bindings >= 0.0 && < 0.1,

2424 blaze-builder-enumerator >= 0.2 && < 0.3,

2525 transformers >= 0.2 && < 0.3,

26− enumerator >= 0.4 && < 0.5,

26+ enumerator >= 0.4.7 && < 0.5,

2727 blaze-builder >= 0.2.1.3 && < 0.3,

28− web-routes >= 0.23

28+ ascii >= 0.0.2 && < 0.1,

29+ http-types >= 0.5 && < 0.6,

30+ text >= 0.5 && < 1.0

2931 Exposed-modules: Network.Wai.Handler.CGI

3032 Network.Wai.Middleware.AcceptOverride

3133 Network.Wai.Middleware.Autohead