8af2f94 · typeable/wai

wai-app-static/WaiAppStatic/Storage/Embedded.hs+3−2

compare with master

unifiedsplit

@@ -15,7 +15,8 @@ import Data.Function (on)

15import qualified Data.Text as T

16import Data.Ord

17import qualified Data.ByteString as S

18−import qualified Crypto.Hash.MD5 as MD5

18+import qualified Crypto.Classes as CR

19+import Crypto.Hash.CryptoAPI (hash', MD5)

19import qualified Data.ByteString.Base64 as B64

20import qualified Data.ByteString.Base64 as B64

20import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)

21import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)

21

22

@@ -89,4 +90,4 @@ bsToFile name bs = File

89 }

90 }

90

91

91runHash :: ByteString -> ByteString

92runHash :: ByteString -> ByteString

92−runHash = B64.encode . MD5.hash

93+runHash = B64.encode . CR.encode . (hash' :: S.ByteString -> MD5)

wai-app-static/WaiAppStatic/Storage/Filesystem.hs+1−1

@@ -27,7 +27,7 @@ import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime, isRe

27import Data.Maybe (catMaybes)

28import qualified Crypto.Conduit

29import Data.Serialize (encode)

30−import Crypto.Hash.MD5 (MD5)

30+import Crypto.Hash.CryptoAPI (MD5)

31import qualified Data.ByteString.Base64 as B64

32

33-- | Construct a new path from a root and some @Pieces@.

wai-app-static/wai-app-static.cabal+2−1

@@ -37,7 +37,8 @@ library

37 , text >= 0.7

38 , blaze-builder >= 0.2.1.4

39 , base64-bytestring >= 0.1

40+ , crypto-api >= 0.12.2

40− , cryptohash >= 0.7

41+ , cryptohash-cryptoapi >= 0.1.0

41 , system-filepath >= 0.4

42 , system-filepath >= 0.4

42 , system-fileio >= 0.3

43 , system-fileio >= 0.3

43 , http-date

44 , http-date

wai-extra/Network/Wai/Middleware/Gzip.hs+7−2

@@ -25,7 +25,7 @@ module Network.Wai.Middleware.Gzip

25 ) where

26

27import Network.Wai

28−import Data.Maybe (fromMaybe)

28+import Data.Maybe (fromMaybe, isJust)

29import qualified Data.ByteString.Char8 as S8

30import qualified Data.ByteString as S

31import Data.Default

@@ -77,7 +77,7 @@ gzip set app env = do

77 res <- app env

78 case res of

79 ResponseFile{} | gzipFiles set == GzipIgnore -> return res

80− _ -> if "gzip" `elem` enc && not isMSIE6

80+ _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)

81 then

82 case (res, gzipFiles set) of

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

@@ -92,6 +92,11 @@ gzip set app env = do

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

93 ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env

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

95+ responseHeaders res = case res of

96+ ResponseFile _ h _ _ -> h

97+ ResponseBuilder _ h _ -> h

98+ ResponseSource _ h _ -> h

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

95

100

96compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response

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

97compressFile s hs file cache = do

102compressFile s hs file cache = do

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

@@ -32,7 +32,7 @@ import qualified Data.Conduit.List as CL

32--

33-- Basically, if the user requested a \"text\/javascript\" and supplied a

34-- \"callback\" GET parameter, ask the application for an

35−-- \"application/json\" response, then convern that into a JSONP response,

35+-- \"application/json\" response, then convert that into a JSONP response,

36-- having a content type of \"text\/javascript\" and calling the specified

37-- callback function.

38jsonp :: Middleware

wai-extra/test/WaiExtraTest.hs+17

@@ -64,6 +64,7 @@ specs = do

64 it "jsonp" caseJsonp

65 it "gzip" caseGzip

66 it "gzip not for MSIE" caseGzipMSIE

67+ it "gzip bypass when precompressed" caseGzipBypassPre

67 it "defaultCheckMime" caseDefaultCheckMime

68 it "defaultCheckMime" caseDefaultCheckMime

68 it "vhost" caseVhost

69 it "vhost" caseVhost

69 it "autohead" caseAutohead

70 it "autohead" caseAutohead

@@ -319,6 +320,14 @@ gzipApp = gzip def $ const $ return $ responseLBS status200

319 [("Content-Type", "text/plain")]

320 [("Content-Type", "text/plain")]

320 "test"

321 "test"

321

322

323+-- Lie a little and don't compress the body. This way we test

324+-- that the compression is skipped based on the presence of

325+-- the Content-Encoding header.

326+gzipPrecompressedApp :: Application

327+gzipPrecompressedApp = gzip def $ const $ return $ responseLBS status200

328+ [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]

329+ "test"

330+

322caseGzip :: Assertion

331caseGzip :: Assertion

323caseGzip = flip runSession gzipApp $ do

332caseGzip = flip runSession gzipApp $ do

324 sres1 <- request defaultRequest

333 sres1 <- request defaultRequest

@@ -354,6 +363,14 @@ caseGzipMSIE = flip runSession gzipApp $ do

354 assertNoHeader "Content-Encoding" sres1

363 assertNoHeader "Content-Encoding" sres1

355 liftIO $ simpleBody sres1 @?= "test"

364 liftIO $ simpleBody sres1 @?= "test"

356

365

366+caseGzipBypassPre :: Assertion

367+caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do

368+ sres1 <- request defaultRequest

369+ { requestHeaders = [("Accept-Encoding", "gzip")]

370+ }

371+ assertHeader "Content-Encoding" "gzip" sres1

372+ assertBody "test" sres1 -- the body is not actually compressed

373+

357vhostApp1, vhostApp2, vhostApp :: Application

374vhostApp1, vhostApp2, vhostApp :: Application

358vhostApp1 = const $ return $ responseLBS status200 [] "app1"

375vhostApp1 = const $ return $ responseLBS status200 [] "app1"

359vhostApp2 = const $ return $ responseLBS status200 [] "app2"

376vhostApp2 = const $ return $ responseLBS status200 [] "app2"

wai-extra/test/sample.hs+16−15

@@ -1,25 +1,26 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+

1−import Data.ByteString.Char8 (unpack, pack)

3+import Data.ByteString.Char8 (pack)

2import Data.ByteString.Lazy (fromChunks)

4import Data.ByteString.Lazy (fromChunks)

5+import Data.Text ()

6+import Network.HTTP.Types

3import Network.Wai

7import Network.Wai

4−import Network.Wai.Enumerator

5import Network.Wai.Middleware.Gzip

8import Network.Wai.Middleware.Gzip

6import Network.Wai.Middleware.Jsonp

9import Network.Wai.Middleware.Jsonp

7−import Network.Wai.Middleware.CleanPath

10+import Network.Wai.Handler.Warp

8−import Network.Wai.Handler.SimpleServer

9

11

10−app :: [String] -> Application

12+app :: Application

11−app [] _ = return $ Response Status200 [] $ Right $ fromLBS

13+app request = return $ case pathInfo request of

14+ [] -> responseLBS status200 []

12− $ fromChunks $ flip map [1..10000] $ \i -> pack $

15+ $ fromChunks $ flip map [1..10000] $ \i -> pack $ concat

13− concat

14 [ "<p>Just this same paragraph again. "

16 [ "<p>Just this same paragraph again. "

15− , show i

17+ , show (i :: Int)

16 , "</p>"

18 , "</p>"

17 ]

19 ]

18−app ["test.html"] _ = return $ Response Status200 [] $ Left "test.html"

20+ ["test.html"] -> ResponseFile status200 [] "test.html" Nothing

19−app ["json"] _ =return $ Response Status200

21+ ["json"] -> ResponseFile status200 [(hContentType, "application/json")]

20− [(ContentType, pack "application/json")]

21− $ Left "json"

22+ "json" Nothing

22−app _ _ = return $ Response Status404 [] $ Left "../LICENSE"

23+ _ -> ResponseFile status404 [] "../LICENSE" Nothing

23

24

24main :: IO ()

25main :: IO ()

25−main = run 3000 $ jsonp $ gzip $ cleanPath app

26+main = run 3000 $ gzip def $ jsonp app

wai/Network/Wai.hs+1

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

1{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE CPP #-}

2{-|

3{-|

3

4

4This module defines a generic web application interface. It is a common

5This module defines a generic web application interface. It is a common

wai/Network/Wai/Internal.hs+6−1

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

1{-# OPTIONS_HADDOCK not-home #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE CPP #-}

3-- | Internal constructors and helper functions. Note that no guarantees are

4-- | Internal constructors and helper functions. Note that no guarantees are

4-- given for stability of these interfaces.

5-- given for stability of these interfaces.

5module Network.Wai.Internal where

6module Network.Wai.Internal where

@@ -10,7 +11,11 @@ import qualified Data.ByteString as B

10import qualified Data.Conduit as C

11import qualified Data.Conduit as C

11import Data.Text (Text)

12import Data.Text (Text)

12import Data.Typeable (Typeable)

13import Data.Typeable (Typeable)

14+#if MIN_VERSION_vault(0,3,0)

15+import Data.Vault.Lazy (Vault)

16+#else

13−import Data.Vault (Vault)

17+import Data.Vault (Vault)

18+#endif

14import Data.Word (Word64)

19import Data.Word (Word64)

15import qualified Network.HTTP.Types as H

20import qualified Network.HTTP.Types as H

16import Network.Socket (SockAddr)

21import Network.Socket (SockAddr)

wai/wai.cabal+1−1

@@ -25,7 +25,7 @@ Library

25 , http-types >= 0.7

26 , text >= 0.7

27 , transformers >= 0.2.2

28− , vault >= 0.1 && < 0.3

28+ , vault >= 0.1 && < 0.4

29 , resourcet >= 0.4.7

30 Exposed-modules: Network.Wai

31 Network.Wai.Internal

warp-tls/Network/Wai/Handler/WarpTLS.hs+8

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE RecordWildCards #-}

@@ -46,6 +47,9 @@ import Crypto.Random.AESCtr (makeSystem)

46import Control.Exception (Exception, throwIO)

47import Control.Exception (Exception, throwIO)

47import Data.Typeable (Typeable)

48import Data.Typeable (Typeable)

48import qualified Data.Conduit.Binary as CB

49import qualified Data.Conduit.Binary as CB

50+#if MIN_VERSION_tls(1, 1, 3)

51+import qualified Crypto.Random.AESCtr

52+#endif

49

53

50data TLSSettings = TLSSettings

54data TLSSettings = TLSSettings

51 { certFile :: FilePath

55 { certFile :: FilePath

@@ -117,7 +121,11 @@ runTLSSocket TLSSettings {..} set sock app = do

117 return bs

121 return bs

118 if maybe False ((== 0x16) . fst) (firstBS >>= B.uncons)

122 if maybe False ((== 0x16) . fst) (firstBS >>= B.uncons)

119 then do

123 then do

124+#if MIN_VERSION_tls(1, 1, 3)

125+ gen <- Crypto.Random.AESCtr.makeSystem

126+#else

120 gen <- makeSystem

127 gen <- makeSystem

128+#endif

121 ctx <- TLS.contextNew

129 ctx <- TLS.contextNew

122 TLS.Backend

130 TLS.Backend

123 { TLS.backendFlush = return ()

131 { TLS.backendFlush = return ()

warp-tls/warp-tls.cabal+9

@@ -12,6 +12,9 @@ Cabal-Version: >=1.6

12Stability: Stable

13Description: HTTP over SSL/TLS support for Warp via the TLS package.

14

15+flag tls_1_1_3

16+ default: True

17+

15Library

18Library

16 Build-Depends: base >= 4 && < 5

19 Build-Depends: base >= 4 && < 5

17 , bytestring >= 0.9

20 , bytestring >= 0.9

@@ -28,6 +31,12 @@ Library

28 , crypto-random-api >= 0.2

31 , crypto-random-api >= 0.2

29 , network >= 2.2.1

32 , network >= 2.2.1

30 , cprng-aes >= 0.3.4

33 , cprng-aes >= 0.3.4

34+ if flag(tls_1_1_3)

35+ build-depends: tls >= 1.1.3

36+ , cprng-aes >= 0.5.0

37+ else

38+ build-depends: tls < 1.1.3

39+ , cprng-aes < 0.5.0

31 Exposed-modules: Network.Wai.Handler.WarpTLS

40 Exposed-modules: Network.Wai.Handler.WarpTLS

32 ghc-options: -Wall

41 ghc-options: -Wall

33

42

warp/Network/Wai/Handler/Warp/FdCache.hs+15−5

@@ -8,6 +8,7 @@ module Network.Wai.Handler.Warp.FdCache (

8

9import Control.Applicative ((<$>), (<*>))

10import Control.Concurrent

11+import Control.Exception (mask_)

11import Control.Monad

12import Control.Monad

12import Data.Hashable

13import Data.Hashable

13import Data.IORef

14import Data.IORef

@@ -48,7 +49,7 @@ newFdEntry path = FdEntry path

48

49

49type Hash = Int

50type Hash = Int

50type FdCache = MMap Hash FdEntry

51type FdCache = MMap Hash FdEntry

51−newtype MutableFdCache = MutableFdCache (IORef FdCache)

52+newtype MutableFdCache = MutableFdCache { unMutableFdCache :: IORef FdCache }

52

53

53newMutableFdCache :: IO MutableFdCache

54newMutableFdCache :: IO MutableFdCache

54newMutableFdCache = MutableFdCache <$> newIORef empty

55newMutableFdCache = MutableFdCache <$> newIORef empty

@@ -79,16 +80,25 @@ look mfc path key = searchWith key check <$> fdCache mfc

79initialize :: Int -> IO MutableFdCache

80initialize :: Int -> IO MutableFdCache

80initialize duration = do

81initialize duration = do

81 mfc <- newMutableFdCache

82 mfc <- newMutableFdCache

82− void . forkIO $ loop mfc

83+ tid <- forkIO $ loop mfc

84+ _ <- mkWeakIORef (unMutableFdCache mfc) $ terminate mfc tid

83 return mfc

85 return mfc

84 where

86 where

85 loop mfc = do

87 loop mfc = do

88+ mask_ $ do

86− old <- swapWithNew mfc

89+ old <- swapWithNew mfc

87− new <- pruneWith old prune

90+ new <- pruneWith old prune

88− update mfc (merge new)

91+ update mfc (merge new)

89 threadDelay duration

92 threadDelay duration

90 loop mfc

93 loop mfc

91

94

95+terminate :: MutableFdCache -> ThreadId -> IO ()

96+terminate (MutableFdCache icache) tid = do

97+ killThread tid

98+ readIORef icache >>= mapM_ go . toList

99+ where

100+ go (_, FdEntry _ fd _) = closeFd fd

101+

92prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]

102prune :: t -> Some FdEntry -> IO [(t, Some FdEntry)]

93prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'

103prune k v@(One (FdEntry _ fd mst)) = status mst >>= prune'

94 where

104 where