8285802 · typeable/wai

wai-extra/Network/Wai/EventSource.hs+3−5

compare with master

unifiedsplit

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

1−{-# LANGUAGE OverloadedStrings #-}

2{-|

1{-|

3 A WAI adapter to the HTML5 Server-Sent Events API.

2 A WAI adapter to the HTML5 Server-Sent Events API.

4-}

3-}

@@ -8,12 +7,11 @@ module Network.Wai.EventSource (

8 eventSourceAppIO

7 eventSourceAppIO

9 ) where

8 ) where

10

9

11−import Blaze.ByteString.Builder (Builder)

12import Data.Function (fix)

10import Data.Function (fix)

13import Control.Concurrent.Chan (Chan, dupChan, readChan)

11import Control.Concurrent.Chan (Chan, dupChan, readChan)

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

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

15−import Network.HTTP.Types (status200)

13+import Network.HTTP.Types (status200, hContentType)

16−import Network.Wai (Application, Response, responseStream)

14+import Network.Wai (Application, responseStream)

17

15

18import Network.Wai.EventSource.EventStream

16import Network.Wai.EventSource.EventStream

19

17

@@ -30,7 +28,7 @@ eventSourceAppIO :: IO ServerEvent -> Application

30eventSourceAppIO src _ sendResponse =

28eventSourceAppIO src _ sendResponse =

31 sendResponse $ responseStream

29 sendResponse $ responseStream

32 status200

30 status200

33− [("Content-Type", "text/event-stream")]

31+ [(hContentType, "text/event-stream")]

34 $ \sendChunk flush -> fix $ \loop -> do

32 $ \sendChunk flush -> fix $ \loop -> do

35 se <- src

33 se <- src

36 case eventToBuilder se of

34 case eventToBuilder se of

wai-extra/Network/Wai/EventSource/EventStream.hs+3−1

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

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE CPP #-}

2{- code adapted by Mathias Billman originaly from Chris Smith https://github.com/cdsmith/gloss-web -}

3

4{-|

@@ -11,7 +11,9 @@ module Network.Wai.EventSource.EventStream (

11

12import Blaze.ByteString.Builder

13import Blaze.ByteString.Builder.Char8

14+#if __GLASGOW_HASKELL__ < 710

14import Data.Monoid

15import Data.Monoid

16+#endif

15

17

16{-|

18{-|

17 Type representing a communication over an event stream. This can be an

19 Type representing a communication over an event stream. This can be an

wai-extra/Network/Wai/Handler/CGI.hs+10−11

@@ -1,6 +1,4 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RankNTypes #-}

1+{-# LANGUAGE RankNTypes, CPP #-}

3−{-# LANGUAGE CPP #-}

4-- | Backend for Common Gateway Interface. Almost all users should use the

2-- | Backend for Common Gateway Interface. Almost all users should use the

5-- 'run' function.

3-- 'run' function.

6module Network.Wai.Handler.CGI

4module Network.Wai.Handler.CGI

@@ -21,15 +19,16 @@ import Control.Arrow ((***))

21import Data.Char (toLower)

19import Data.Char (toLower)

22import qualified System.IO

20import qualified System.IO

23import qualified Data.String as String

21import qualified Data.String as String

24−import Data.Monoid (mconcat, mempty)

25import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush)

22import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush)

26import Blaze.ByteString.Builder.Char8 (fromChar, fromString)

23import Blaze.ByteString.Builder.Char8 (fromChar, fromString)

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

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

28import System.IO (Handle)

25import System.IO (Handle)

29−import Network.HTTP.Types (Status (..))

26+import Network.HTTP.Types (Status (..), hRange, hContentType, hContentLength)

30import qualified Network.HTTP.Types as H

27import qualified Network.HTTP.Types as H

31import qualified Data.CaseInsensitive as CI

28import qualified Data.CaseInsensitive as CI

29+#if __GLASGOW_HASKELL__ < 710

32−import Data.Monoid (mappend)

30+import Data.Monoid (mconcat, mempty, mappend)

31+#endif

33import qualified Data.Streaming.Blaze as Blaze

32import qualified Data.Streaming.Blaze as Blaze

34import Data.Function (fix)

33import Data.Function (fix)

35import Control.Monad (unless, void)

34import Control.Monad (unless, void)

@@ -118,7 +117,7 @@ runGeneric vars inputH outputH xsendfile app = do

118 , vault = mempty

117 , vault = mempty

119 , requestBodyLength = KnownLength $ fromIntegral contentLength

118 , requestBodyLength = KnownLength $ fromIntegral contentLength

120 , requestHeaderHost = lookup "host" reqHeaders

119 , requestHeaderHost = lookup "host" reqHeaders

121− , requestHeaderRange = lookup "range" reqHeaders

120+ , requestHeaderRange = lookup hRange reqHeaders

122 }

121 }

123 void $ app env $ \res ->

122 void $ app env $ \res ->

124 case (xsendfile, res) of

123 case (xsendfile, res) of

@@ -162,13 +161,13 @@ runGeneric vars inputH outputH xsendfile app = do

162 , fromByteString " not supported"

161 , fromByteString " not supported"

163 ]

162 ]

164 fixHeaders h =

163 fixHeaders h =

165− case lookup "content-type" h of

164+ case lookup hContentType h of

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

165+ Nothing -> (hContentType, "text/html; charset=utf-8") : h

167 Just _ -> h

166 Just _ -> h

168

167

169cleanupVarName :: String -> CI.CI B.ByteString

168cleanupVarName :: String -> CI.CI B.ByteString

170−cleanupVarName "CONTENT_TYPE" = "Content-Type"

169+cleanupVarName "CONTENT_TYPE" = hContentType

171−cleanupVarName "CONTENT_LENGTH" = "Content-Length"

170+cleanupVarName "CONTENT_LENGTH" = hContentLength

172cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"

171cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"

173cleanupVarName s =

172cleanupVarName s =

174 case s of

173 case s of

wai-extra/Network/Wai/Middleware/AcceptOverride.hs−2

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3module Network.Wai.Middleware.AcceptOverride

1module Network.Wai.Middleware.AcceptOverride

4 ( acceptOverride

2 ( acceptOverride

5 ) where

3 ) where

wai-extra/Network/Wai/Middleware/AddHeaders.hs+1−1

@@ -5,7 +5,7 @@ module Network.Wai.Middleware.AddHeaders

5 ( addHeaders

6 ) where

7

8−import Network.HTTP.Types (ResponseHeaders, Header)

8+import Network.HTTP.Types (Header)

9import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)

10import Network.Wai.Internal (Response(..))

11import Data.ByteString (ByteString)

wai-extra/Network/Wai/Middleware/Approot.hs+2−4

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

1{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE OverloadedStrings #-}

3-- | Middleware for establishing the root of the application.

2-- | Middleware for establishing the root of the application.

4--

3--

5-- Many application need the ability to create URLs referring back to the

4-- Many application need the ability to create URLs referring back to the

@@ -29,13 +28,12 @@ module Network.Wai.Middleware.Approot

29

28

30import Control.Exception (Exception, throw)

29import Control.Exception (Exception, throw)

31import Data.ByteString (ByteString)

30import Data.ByteString (ByteString)

32−import qualified Data.ByteString as S

33import qualified Data.ByteString.Char8 as S8

31import qualified Data.ByteString.Char8 as S8

34import Data.Maybe (fromMaybe)

32import Data.Maybe (fromMaybe)

35import Data.Typeable (Typeable)

33import Data.Typeable (Typeable)

36import qualified Data.Vault.Lazy as V

34import qualified Data.Vault.Lazy as V

37−import Network.Wai (Request, vault, Middleware, requestHeaderHost)

35+import Network.Wai (Request, vault, Middleware)

38−import Network.Wai.Request (appearsSecure, guessApproot)

36+import Network.Wai.Request (guessApproot)

39import System.Environment (getEnvironment)

37import System.Environment (getEnvironment)

40import System.IO.Unsafe (unsafePerformIO)

38import System.IO.Unsafe (unsafePerformIO)

41

39

wai-extra/Network/Wai/Middleware/Autohead.hs+3−1

@@ -1,10 +1,12 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE CPP #-}

2-- | Automatically produce responses to HEAD requests based on the underlying

3-- applications GET response.

4module Network.Wai.Middleware.Autohead (autohead) where

5

6import Network.Wai

7+#if __GLASGOW_HASKELL__ < 710

7import Data.Monoid (mempty)

8import Data.Monoid (mempty)

9+#endif

8

10

9autohead :: Middleware

11autohead :: Middleware

10autohead app req sendResponse

12autohead app req sendResponse

wai-extra/Network/Wai/Middleware/CleanPath.hs+5−3

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

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE CPP #-}

2module Network.Wai.Middleware.CleanPath

3 ( cleanPath

4 ) where

@@ -6,9 +6,11 @@ module Network.Wai.Middleware.CleanPath

6import Network.Wai

7import qualified Data.ByteString.Char8 as B

8import qualified Data.ByteString.Lazy as L

9−import Network.HTTP.Types (status301)

9+import Network.HTTP.Types (status301, hLocation)

10import Data.Text (Text)

11+#if __GLASGOW_HASKELL__ < 710

11import Data.Monoid (mconcat)

12import Data.Monoid (mconcat)

13+#endif

12

14

13cleanPath :: ([Text] -> Either B.ByteString [Text])

15cleanPath :: ([Text] -> Either B.ByteString [Text])

14 -> B.ByteString

16 -> B.ByteString

@@ -19,7 +21,7 @@ cleanPath splitter prefix app env sendResponse =

19 Right pieces -> app pieces env sendResponse

21 Right pieces -> app pieces env sendResponse

20 Left p -> sendResponse

22 Left p -> sendResponse

21 $ responseLBS status301

23 $ responseLBS status301

22− [("Location", mconcat [prefix, p, suffix])]

24+ [(hLocation, mconcat [prefix, p, suffix])]

23 $ L.empty

25 $ L.empty

24 where

26 where

25 -- include the query string if present

27 -- include the query string if present

wai-extra/Network/Wai/Middleware/ForceSSL.hs−1

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3-- | Redirect non-SSL requests to https

2-- | Redirect non-SSL requests to https

4--

3--

5-- Since 3.0.7

4-- Since 3.0.7

wai-extra/Network/Wai/Middleware/Gzip.hs+13−16

@@ -1,6 +1,4 @@

1−{-# LANGUAGE Rank2Types #-}

1+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE OverloadedStrings #-}

4---------------------------------------------------------

2---------------------------------------------------------

5-- |

3-- |

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

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

@@ -29,9 +27,8 @@ import Data.Maybe (fromMaybe, isJust)

29import qualified Data.ByteString.Char8 as S8

27import qualified Data.ByteString.Char8 as S8

30import qualified Data.ByteString as S

28import qualified Data.ByteString as S

31import Data.Default.Class

29import Data.Default.Class

32−import Network.HTTP.Types (Status, Header)

30+import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent

33−import Control.Monad.IO.Class (liftIO)

31+ , hContentType, hContentLength)

34−import Control.Monad.Trans.Resource (runResourceT)

35import System.Directory (doesFileExist, createDirectoryIfMissing)

32import System.Directory (doesFileExist, createDirectoryIfMissing)

36import Blaze.ByteString.Builder (fromByteString)

33import Blaze.ByteString.Builder (fromByteString)

37import Control.Exception (try, SomeException)

34import Control.Exception (try, SomeException)

@@ -85,7 +82,7 @@ gzip set app env sendResponse = app env $ \res ->

85 then

82 then

86 case (res, gzipFiles set) of

83 case (res, gzipFiles set) of

87 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->

84 (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->

88− case lookup "content-type" hs of

85+ case lookup hContentType hs of

89 Just m

86 Just m

90 | gzipCheckMime set m -> compressFile s hs file cache sendResponse

87 | gzipCheckMime set m -> compressFile s hs file cache sendResponse

91 _ -> sendResponse res

88 _ -> sendResponse res

@@ -94,9 +91,9 @@ gzip set app env sendResponse = app env $ \res ->

94 where

91 where

95 enc = fromMaybe [] $ (splitCommas . S8.unpack)

92 enc = fromMaybe [] $ (splitCommas . S8.unpack)

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

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

97− ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env

94+ ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env

98 isMSIE6 = "MSIE 6" `S.isInfixOf` ua

95 isMSIE6 = "MSIE 6" `S.isInfixOf` ua

99− isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res

96+ isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res

100

97

101compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a

98compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a

102compressFile s hs file cache sendResponse = do

99compressFile s hs file cache sendResponse = do

@@ -118,7 +115,7 @@ compressFile s hs file cache sendResponse = do

118 Z.PRNext bs -> do

115 Z.PRNext bs -> do

119 S.hPut outH bs

116 S.hPut outH bs

120 loop

117 loop

121− Z.PRError e -> throwIO e

118+ Z.PRError ex -> throwIO ex

122 fix $ \loop -> do

119 fix $ \loop -> do

123 bs <- S.hGetSome inH defaultChunkSize

120 bs <- S.hGetSome inH defaultChunkSize

124 unless (S.null bs) $ do

121 unless (S.null bs) $ do

@@ -145,11 +142,11 @@ compressE :: GzipSettings

145 -> (Response -> IO a)

142 -> (Response -> IO a)

146 -> IO a

143 -> IO a

147compressE set res sendResponse =

144compressE set res sendResponse =

148− case lookup "content-type" hs of

145+ case lookup hContentType hs of

149 Just m | gzipCheckMime set m ->

146 Just m | gzipCheckMime set m ->

150 let hs' = fixHeaders hs

147 let hs' = fixHeaders hs

151 in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do

148 in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do

152− (blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy

149+ (blazeRecv, _) <- B.newBlazeRecv B.defaultStrategy

153 deflate <- Z.initDeflate 1 (Z.WindowBits 31)

150 deflate <- Z.initDeflate 1 (Z.WindowBits 31)

154 let sendBuilder builder = do

151 let sendBuilder builder = do

155 popper <- blazeRecv builder

152 popper <- blazeRecv builder

@@ -164,8 +161,8 @@ compressE set res sendResponse =

164 deflatePopper $ Z.flushDeflate deflate

161 deflatePopper $ Z.flushDeflate deflate

165 flush

162 flush

166 deflatePopper popper = fix $ \loop -> do

163 deflatePopper popper = fix $ \loop -> do

167− res <- popper

164+ result <- popper

168− case res of

165+ case result of

169 Z.PRDone -> return ()

166 Z.PRDone -> return ()

170 Z.PRNext bs' -> do

167 Z.PRNext bs' -> do

171 sendChunk $ fromByteString bs'

168 sendChunk $ fromByteString bs'

@@ -183,9 +180,9 @@ compressE set res sendResponse =

183-- different length after gzip compression.

180-- different length after gzip compression.

184fixHeaders :: [Header] -> [Header]

181fixHeaders :: [Header] -> [Header]

185fixHeaders =

182fixHeaders =

186− (("Content-Encoding", "gzip") :) . filter notLength

183+ ((hContentEncoding, "gzip") :) . filter notLength

187 where

184 where

188− notLength (x, _) = x /= "content-length"

185+ notLength (x, _) = x /= hContentLength

189

186

190splitCommas :: String -> [String]

187splitCommas :: String -> [String]

191splitCommas [] = []

188splitCommas [] = []

wai-extra/Network/Wai/Middleware/HttpAuth.hs+6−5

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

1−{-# LANGUAGE RecordWildCards, OverloadedStrings, TupleSections #-}

1+{-# LANGUAGE RecordWildCards, TupleSections, CPP #-}

2-- | Implements HTTP Basic Authentication.

3--

4-- This module may add digest authentication in the future.

@@ -14,13 +14,14 @@ module Network.Wai.Middleware.HttpAuth

14 , extractBasicAuth

15 , extractBearerAuth

16 ) where

17−

17+#if __GLASGOW_HASKELL__ < 710

18import Control.Applicative

19+#endif

19import Data.ByteString (ByteString)

20import Data.ByteString (ByteString)

20import Data.ByteString.Base64 (decodeLenient)

21import Data.ByteString.Base64 (decodeLenient)

21import Data.String (IsString (..))

22import Data.String (IsString (..))

22import Data.Word8 (isSpace, _colon, toLower)

23import Data.Word8 (isSpace, _colon, toLower)

23−import Network.HTTP.Types (status401)

24+import Network.HTTP.Types (status401, hContentType, hAuthorization)

24import Network.Wai

25import Network.Wai

25

26

26import qualified Data.ByteString as S

27import qualified Data.ByteString as S

@@ -47,7 +48,7 @@ basicAuth checkCreds AuthSettings {..} app req sendResponse = do

47 else authOnNoAuth authRealm req sendResponse

48 else authOnNoAuth authRealm req sendResponse

48 where

49 where

49 check =

50 check =

50− case (lookup "Authorization" $ requestHeaders req)

51+ case (lookup hAuthorization $ requestHeaders req)

51 >>= extractBasicAuth of

52 >>= extractBasicAuth of

52 Nothing -> return False

53 Nothing -> return False

53 Just (username, password) -> checkCreds username password

54 Just (username, password) -> checkCreds username password

@@ -84,7 +85,7 @@ instance IsString AuthSettings where

84 { authRealm = fromString s

85 { authRealm = fromString s

85 , authOnNoAuth = \realm _req f -> f $ responseLBS

86 , authOnNoAuth = \realm _req f -> f $ responseLBS

86 status401

87 status401

87− [ ("Content-Type", "text/plain")

88+ [ (hContentType, "text/plain")

88 , ("WWW-Authenticate", S.concat

89 , ("WWW-Authenticate", S.concat

89 [ "Basic realm=\""

90 [ "Basic realm=\""

90 , realm

91 , realm

wai-extra/Network/Wai/Middleware/Jsonp.hs+10−10

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

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RankNTypes #-}

1+{-# LANGUAGE RankNTypes, CPP #-}

3---------------------------------------------------------

2---------------------------------------------------------

4-- |

3-- |

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

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

@@ -19,14 +18,15 @@ import Network.Wai

19import Network.Wai.Internal

18import Network.Wai.Internal

20import Data.ByteString (ByteString)

19import Data.ByteString (ByteString)

21import qualified Data.ByteString.Char8 as B8

20import qualified Data.ByteString.Char8 as B8

22−import Blaze.ByteString.Builder (Builder, copyByteString)

21+import Blaze.ByteString.Builder (copyByteString)

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

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

23+#if __GLASGOW_HASKELL__ < 710

24import Data.Monoid (mappend)

25+#endif

25import Control.Monad (join)

26import Control.Monad (join)

26import Data.Maybe (fromMaybe)

27import Data.Maybe (fromMaybe)

27import qualified Data.ByteString as S

28import qualified Data.ByteString as S

28−import Data.CaseInsensitive (CI)

29−import Network.HTTP.Types (Status)

29+import Network.HTTP.Types (hAccept, hContentType)

30

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

32--

@@ -37,7 +37,7 @@ import Network.HTTP.Types (Status)

37-- callback function.

38jsonp :: Middleware

39jsonp app env sendResponse = do

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

40+ let accept = fromMaybe B8.empty $ lookup hAccept $ requestHeaders env

41 let callback :: Maybe B8.ByteString

42 callback =

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

@@ -47,7 +47,7 @@ jsonp app env sendResponse = do

47 case callback of

48 Nothing -> env

49 Just _ -> env

50− { requestHeaders = changeVal "Accept"

50+ { requestHeaders = changeVal hAccept

51 "application/json"

52 $ requestHeaders env

53 }

@@ -72,17 +72,17 @@ jsonp app env sendResponse = do

72 (s, hs, wb) = responseToStream r

73

74 checkJSON hs =

75− case lookup "Content-Type" hs of

75+ case lookup hContentType hs of

76 Just x

77 | B8.pack "application/json" `S.isPrefixOf` x ->

78 Just $ fixHeaders hs

79 _ -> Nothing

80− fixHeaders = changeVal "Content-Type" "text/javascript"

80+ fixHeaders = changeVal hContentType "text/javascript"

81

82 addCallback cb s hs wb =

83 wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do

84 sendChunk $ copyByteString cb `mappend` fromChar '('

85− body sendChunk flush

85+ _ <- body sendChunk flush

86 sendChunk $ fromChar ')'

87

88changeVal :: Eq a

wai-extra/Network/Wai/Middleware/Local.hs+1−1

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

1−{-# LANGUAGE OverloadedStrings, CPP #-}

1+{-# LANGUAGE CPP #-}

2-- | Only allow local connections.

3--

4module Network.Wai.Middleware.Local

wai-extra/Network/Wai/Middleware/MethodOverride.hs−1

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

1−{-# LANGUAGE OverloadedStrings #-}

2module Network.Wai.Middleware.MethodOverride

1module Network.Wai.Middleware.MethodOverride

3 ( methodOverride

2 ( methodOverride

4 ) where

3 ) where

wai-extra/Network/Wai/Middleware/MethodOverridePost.hs+6−3

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

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE CPP #-}

2-----------------------------------------------------------------

3-- | Module : Network.Wai.Middleware.MethodOverridePost

4--

@@ -9,8 +9,11 @@ module Network.Wai.Middleware.MethodOverridePost

9 ) where

10

11import Network.Wai

12−import Network.HTTP.Types (parseQuery)

12+import Network.HTTP.Types (parseQuery, hContentType)

13+

14+#if __GLASGOW_HASKELL__ < 710

13import Data.Monoid (mconcat, mempty)

15import Data.Monoid (mconcat, mempty)

16+#endif

14import Data.IORef

17import Data.IORef

15import Data.ByteString.Lazy (toChunks)

18import Data.ByteString.Lazy (toChunks)

16

19

@@ -27,7 +30,7 @@ import Data.ByteString.Lazy (toChunks)

27--

30--

28methodOverridePost :: Middleware

31methodOverridePost :: Middleware

29methodOverridePost app req send =

32methodOverridePost app req send =

30− case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of

33+ case (requestMethod req, lookup hContentType (requestHeaders req)) of

31 ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send

34 ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send

32 _ -> app req send

35 _ -> app req send

33

36

wai-extra/Network/Wai/Middleware/RequestLogger.hs+5−10

@@ -1,6 +1,4 @@

1−{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RecordWildCards #-}

1{-# LANGUAGE RecordWildCards #-}

3−

4-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should

2-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should

5-- not use CPP.

3-- not use CPP.

6module Network.Wai.Middleware.RequestLogger

4module Network.Wai.Middleware.RequestLogger

@@ -30,17 +28,14 @@ import Network.HTTP.Types as H

30import Data.Maybe (fromMaybe)

28import Data.Maybe (fromMaybe)

31import Data.Monoid (mconcat, (<>))

29import Data.Monoid (mconcat, (<>))

32import Data.Time (getCurrentTime, diffUTCTime)

30import Data.Time (getCurrentTime, diffUTCTime)

33−

34−import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)

31+import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File

32+ , getRequestBodyType)

35import qualified Data.ByteString.Lazy as LBS

33import qualified Data.ByteString.Lazy as LBS

36import qualified Data.ByteString.Char8 as S8

34import qualified Data.ByteString.Char8 as S8

37−

38import System.Console.ANSI

35import System.Console.ANSI

39import Data.IORef.Lifted

36import Data.IORef.Lifted

40import System.IO.Unsafe

37import System.IO.Unsafe

41−import Control.Monad (unless)

42import Network.Wai.Internal (Response (ResponseRaw))

38import Network.Wai.Internal (Response (ResponseRaw))

43−

44import Data.Default.Class (Default (def))

39import Data.Default.Class (Default (def))

45import Network.Wai.Logger

40import Network.Wai.Logger

46import Network.Wai.Middleware.RequestLogger.Internal

41import Network.Wai.Middleware.RequestLogger.Internal

@@ -103,7 +98,7 @@ mkRequestLogger RequestLoggerSettings{..} = do

103

98

104apacheMiddleware :: ApacheLoggerActions -> Middleware

99apacheMiddleware :: ApacheLoggerActions -> Middleware

105apacheMiddleware ala app req sendResponse = app req $ \res -> do

100apacheMiddleware ala app req sendResponse = app req $ \res -> do

106− let msize = lookup "content-length" (responseHeaders res) >>= readInt'

101+ let msize = lookup H.hContentLength (responseHeaders res) >>= readInt'

107 readInt' bs =

102 readInt' bs =

108 case S8.readInteger bs of

103 case S8.readInteger bs of

109 Just (i, "") -> Just i

104 Just (i, "") -> Just i

@@ -193,7 +188,7 @@ detailedMiddleware' :: Callback

193 -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])

188 -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])

194 -> Middleware

189 -> Middleware

195detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do

190detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do

196− let mlen = lookup "content-length" (requestHeaders req) >>= readInt

191+ let mlen = lookup H.hContentLength (requestHeaders req) >>= readInt

197 (req', body) <-

192 (req', body) <-

198 case mlen of

193 case mlen of

199 -- log the request body if it is small

194 -- log the request body if it is small

@@ -231,7 +226,7 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse

231 return $ collectPostParams postParams

226 return $ collectPostParams postParams

232

227

233 let getParams = map emptyGetParam $ queryString req

228 let getParams = map emptyGetParam $ queryString req

234− accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req

229+ accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req

235 params = let par | not $ null postParams = [pack (show postParams)]

230 params = let par | not $ null postParams = [pack (show postParams)]

236 | not $ null getParams = [pack (show getParams)]

231 | not $ null getParams = [pack (show getParams)]

237 | otherwise = []

232 | otherwise = []

wai-extra/Network/Wai/Middleware/RequestLogger/Internal.hs+6−2

@@ -8,9 +8,10 @@ module Network.Wai.Middleware.RequestLogger.Internal

8

9import Data.ByteString (ByteString)

10import Network.Wai.Logger (clockDateCacher)

11+#if !MIN_VERSION_wai_logger(2, 2, 0)

11import Control.Concurrent (forkIO, threadDelay)

12import Control.Concurrent (forkIO, threadDelay)

12import Control.Monad (forever)

13import Control.Monad (forever)

13−

14+#endif

14import System.Log.FastLogger (LogStr, fromLogStr)

15import System.Log.FastLogger (LogStr, fromLogStr)

15

16

16logToByteString :: LogStr -> ByteString

17logToByteString :: LogStr -> ByteString

@@ -18,12 +19,15 @@ logToByteString = fromLogStr

18

19

19getDateGetter :: IO () -- ^ flusher

20getDateGetter :: IO () -- ^ flusher

20 -> IO (IO ByteString)

21 -> IO (IO ByteString)

22+#if !MIN_VERSION_wai_logger(2, 2, 0)

21getDateGetter flusher = do

23getDateGetter flusher = do

22 (getter, updater) <- clockDateCacher

24 (getter, updater) <- clockDateCacher

23−#if !MIN_VERSION_wai_logger(2, 2, 0)

24 _ <- forkIO $ forever $ do

25 _ <- forkIO $ forever $ do

25 threadDelay 1000000

26 threadDelay 1000000

26 updater

27 updater

27 flusher

28 flusher

29+#else

30+getDateGetter _ = do

31+ (getter, _) <- clockDateCacher

28#endif

32#endif

29 return getter

33 return getter

wai-extra/Network/Wai/Middleware/Rewrite.hs−1

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

1−{-# LANGUAGE OverloadedStrings #-}

2module Network.Wai.Middleware.Rewrite

1module Network.Wai.Middleware.Rewrite

3 ( rewrite, rewritePure

2 ( rewrite, rewritePure

4 ) where

3 ) where

wai-extra/Network/Wai/Middleware/StreamFile.hs+2−3

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

1−{-# LANGUAGE OverloadedStrings #-}

2−

3-- |

1-- |

4--

2--

5-- Since 3.0.4

3-- Since 3.0.4

@@ -11,6 +9,7 @@ import Network.Wai.Internal

11import Network.Wai (Middleware, responseToStream)

9import Network.Wai (Middleware, responseToStream)

12import qualified Data.ByteString.Char8 as S8

10import qualified Data.ByteString.Char8 as S8

13import System.PosixCompat (getFileStatus, fileSize, FileOffset)

11import System.PosixCompat (getFileStatus, fileSize, FileOffset)

12+import Network.HTTP.Types (hContentLength)

14

13

15-- |Convert ResponseFile type responses into ResponseStream type

14-- |Convert ResponseFile type responses into ResponseStream type

16--

15--

@@ -34,7 +33,7 @@ streamFile app env sendResponse = app env $ \res ->

34 sendBody :: StreamingBody -> IO ResponseReceived

33 sendBody :: StreamingBody -> IO ResponseReceived

35 sendBody body = do

34 sendBody body = do

36 len <- getFileSize fp

35 len <- getFileSize fp

37− let hs' = ("Content-Length", (S8.pack (show len))) : hs

36+ let hs' = (hContentLength, (S8.pack (show len))) : hs

38 sendResponse $ responseStream s hs' body

37 sendResponse $ responseStream s hs' body

39 _ -> sendResponse res

38 _ -> sendResponse res

40

39

wai-extra/Network/Wai/Middleware/Vhost.hs+5−3

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

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE CPP #-}

2−module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where

2+ module Network.Wai.Middleware.Vhost (vhost, redirectWWW, redirectTo, redirectToLogged) where

3

4import Network.Wai

5

@@ -7,7 +7,9 @@ import Network.HTTP.Types as H

7import qualified Data.Text.Encoding as TE

8import Data.Text (Text)

9import qualified Data.ByteString as BS

10+#if __GLASGOW_HASKELL__ < 710

10import Data.Monoid (mappend)

11import Data.Monoid (mappend)

12+#endif

11

13

12vhost :: [(Request -> Bool, Application)] -> Application -> Application

14vhost :: [(Request -> Bool, Application)] -> Application -> Application

13vhost vhosts def req =

15vhost vhosts def req =

@@ -27,7 +29,7 @@ redirectIf home cond app req sendResponse =

27

29

28redirectTo :: BS.ByteString -> Response

30redirectTo :: BS.ByteString -> Response

29redirectTo location = responseLBS H.status301

31redirectTo location = responseLBS H.status301

30− [ ("Content-Type", "text/plain") , ("Location", location) ] "Redirect"

32+ [ (H.hContentType, "text/plain") , (H.hLocation, location) ] "Redirect"

31

33

32redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response

34redirectToLogged :: (Text -> IO ()) -> BS.ByteString -> IO Response

33redirectToLogged logger loc = do

35redirectToLogged logger loc = do

wai-extra/Network/Wai/Parse.hs+2−2

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ExistentialQuantification #-}

2{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE PatternGuards #-}

3{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

@@ -45,6 +44,7 @@ import qualified Network.HTTP.Types as H

45import Control.Monad (when, unless)

44import Control.Monad (when, unless)

46import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

45import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

47import Data.IORef

46import Data.IORef

47+import Network.HTTP.Types (hContentType)

48

49breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

50breakDiscard w s =

@@ -140,7 +140,7 @@ data RequestBodyType = UrlEncoded | Multipart S.ByteString

140

141getRequestBodyType :: Request -> Maybe RequestBodyType

142getRequestBodyType req = do

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

143+ ctype' <- lookup hContentType $ requestHeaders req

144 let (ctype, attrs) = parseContentType ctype'

145 case ctype of

146 "application/x-www-form-urlencoded" -> return UrlEncoded

wai-extra/Network/Wai/Request.hs−1

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

1−{-# LANGUAGE OverloadedStrings #-}

2-- | Some helpers for interrogating a WAI 'Request'.

1-- | Some helpers for interrogating a WAI 'Request'.

3

2

4module Network.Wai.Request

3module Network.Wai.Request

wai-extra/Network/Wai/UrlMap.hs+2−2

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

1−{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}

1+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

2{-# LANGUAGE ExistentialQuantification #-}

3{- | This module gives you a way to mount applications under sub-URIs.

4For example:

@@ -93,7 +93,7 @@ instance ToApplication UrlMap where

93 Nothing ->

94 sendResponse $ responseLBS

95 status404

96− [("content-type", "text/plain")]

96+ [(hContentType, "text/plain")]

97 "Not found\n"

98

99 where

wai-extra/test/Network/Wai/Middleware/RoutedSpec.hs+2−2

@@ -9,7 +9,7 @@ import Test.Hspec

9import Network.Wai.Middleware.Routed

10import Network.Wai.Middleware.ForceSSL (forceSSL)

11

12−import Network.HTTP.Types (methodPost, status200, status301, status307)

12+import Network.HTTP.Types (hContentType, status200)

13import Network.Wai

14import Network.Wai.Test

15import Data.ByteString (ByteString)

@@ -39,7 +39,7 @@ spec = describe "forceSSL" $ do

39

40jsonApp :: Application

41jsonApp _req cps = cps $ responseLBS status200

42− [("Content-Type", "application/json")]

42+ [(hContentType, "application/json")]

43 "{\"foo\":\"bar\"}"

44

45testDPath :: ByteString -> Session SResponse

wai-extra/wai-extra.cabal+2

@@ -116,6 +116,8 @@ Library

116 else

117 build-depends: unix

118

119+ extensions: OverloadedStrings

120+

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

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

120 Network.Wai.Handler.SCGI

122 Network.Wai.Handler.SCGI

121 Network.Wai.Middleware.AcceptOverride

123 Network.Wai.Middleware.AcceptOverride