8af2f94 · typeable/wai

git.iko.soy/typeable/wai

Merge branch 'master' into internal-state

Conflicts: wai-app-static/wai-app-static.cabal wai-extra/wai-extra.cabal wai/Network/Wai.hs wai/wai.cabal warp-tls/warp-tls.cabal warp/warp.cabal

commit8af2f94e4038af402af6c6ea248ffcd3fac22a19 authorMichael Snoyman <michael@snoyman.com> dateSun 8 Sep 2013, 11:03 (13 years ago) parent1fd0671 a8bcde1

13 files changed+87−29

compare with master

unifiedsplit

wai-app-static/WaiAppStatic/Storage/Embedded.hs+3−2 wai-app-static/WaiAppStatic/Storage/Filesystem.hs+1−1 wai-app-static/wai-app-static.cabal+2−1 wai-extra/Network/Wai/Middleware/Gzip.hs+7−2 wai-extra/Network/Wai/Middleware/Jsonp.hs+1−1 wai-extra/test/WaiExtraTest.hs+17 wai-extra/test/sample.hs+16−15 wai/Network/Wai.hs+1 wai/Network/Wai/Internal.hs+6−1 wai/wai.cabal+1−1 warp-tls/Network/Wai/Handler/WarpTLS.hs+8 warp-tls/warp-tls.cabal+9 warp/Network/Wai/Handler/Warp/FdCache.hs+15−5

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

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

1515import qualified Data.Text as T

1616import Data.Ord

1717import 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)

1920import qualified Data.ByteString.Base64 as B64

2021import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)

2122

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

8990 }

9091

9192runHash :: 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

2727import Data.Maybe (catMaybes)

2828import qualified Crypto.Conduit

2929import Data.Serialize (encode)

30−import Crypto.Hash.MD5 (MD5)

30+import Crypto.Hash.CryptoAPI (MD5)

3131import qualified Data.ByteString.Base64 as B64

3232

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

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

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

3737 , text >= 0.7

3838 , blaze-builder >= 0.2.1.4

3939 , base64-bytestring >= 0.1

40− , cryptohash >= 0.7

40+ , crypto-api >= 0.12.2

41+ , cryptohash-cryptoapi >= 0.1.0

4142 , system-filepath >= 0.4

4243 , system-fileio >= 0.3

4344 , http-date

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

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

2525 ) where

2626

2727import Network.Wai

28−import Data.Maybe (fromMaybe)

28+import Data.Maybe (fromMaybe, isJust)

2929import qualified Data.ByteString.Char8 as S8

3030import qualified Data.ByteString as S

3131import Data.Default

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

7777 res <- app env

7878 case res of

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

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

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

8181 then

8282 case (res, gzipFiles set) of

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

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

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

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

9494 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

95100

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

97102compressFile 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

3232--

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

3434-- \"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,

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

3737-- callback function.

3838jsonp :: Middleware

wai-extra/test/WaiExtraTest.hs+17

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

6464 it "jsonp" caseJsonp

6565 it "gzip" caseGzip

6666 it "gzip not for MSIE" caseGzipMSIE

67+ it "gzip bypass when precompressed" caseGzipBypassPre

6768 it "defaultCheckMime" caseDefaultCheckMime

6869 it "vhost" caseVhost

6970 it "autohead" caseAutohead

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

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

320321 "test"

321322

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+

322331caseGzip :: Assertion

323332caseGzip = flip runSession gzipApp $ do

324333 sres1 <- request defaultRequest

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

354363 assertNoHeader "Content-Encoding" sres1

355364 liftIO $ simpleBody sres1 @?= "test"

356365

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+

357374vhostApp1, vhostApp2, vhostApp :: Application

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

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

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

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

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

1+{-# LANGUAGE OverloadedStrings #-}

3+import Data.ByteString.Char8 (pack)

24import Data.ByteString.Lazy (fromChunks)

5+import Data.Text ()

6+import Network.HTTP.Types

37import Network.Wai

4−import Network.Wai.Enumerator

58import Network.Wai.Middleware.Gzip

69import Network.Wai.Middleware.Jsonp

7−import Network.Wai.Middleware.CleanPath

8−import Network.Wai.Handler.SimpleServer

10+import Network.Wai.Handler.Warp

911

10−app :: [String] -> Application

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

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

13− concat

12+app :: Application

13+app request = return $ case pathInfo request of

14+ [] -> responseLBS status200 []

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

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

15− , show i

17+ , show (i :: Int)

1618 , "</p>"

1719 ]

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

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

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

21− $ Left "json"

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

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

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

22+ "json" Nothing

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

2324

2425main :: 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 @@

11{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE CPP #-}

23{-|

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

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

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

11{-# OPTIONS_HADDOCK not-home #-}

22{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE CPP #-}

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

45-- given for stability of these interfaces.

56module Network.Wai.Internal where

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

1011import qualified Data.Conduit as C

1112import Data.Text (Text)

1213import Data.Typeable (Typeable)

13−import Data.Vault (Vault)

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

15+import Data.Vault.Lazy (Vault)

16+#else

17+import Data.Vault (Vault)

18+#endif

1419import Data.Word (Word64)

1520import qualified Network.HTTP.Types as H

1621import Network.Socket (SockAddr)

wai/wai.cabal+1−1

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

2525 , http-types >= 0.7

2626 , text >= 0.7

2727 , transformers >= 0.2.2

28− , vault >= 0.1 && < 0.3

28+ , vault >= 0.1 && < 0.4

2929 , resourcet >= 0.4.7

3030 Exposed-modules: Network.Wai

3131 Network.Wai.Internal

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE OverloadedStrings #-}

23{-# LANGUAGE RankNTypes #-}

34{-# LANGUAGE RecordWildCards #-}

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

4647import Control.Exception (Exception, throwIO)

4748import Data.Typeable (Typeable)

4849import qualified Data.Conduit.Binary as CB

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

51+import qualified Crypto.Random.AESCtr

52+#endif

4953

5054data TLSSettings = TLSSettings

5155 { certFile :: FilePath

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

117121 return bs

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

119123 then do

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

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

126+#else

120127 gen <- makeSystem

128+#endif

121129 ctx <- TLS.contextNew

122130 TLS.Backend

123131 { TLS.backendFlush = return ()

warp-tls/warp-tls.cabal+9

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

1212Stability: Stable

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

1414

15+flag tls_1_1_3

16+ default: True

17+

1518Library

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

1720 , bytestring >= 0.9

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

2831 , crypto-random-api >= 0.2

2932 , network >= 2.2.1

3033 , 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

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

3241 ghc-options: -Wall

3342

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

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

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

1010import Control.Concurrent

11+import Control.Exception (mask_)

1112import Control.Monad

1213import Data.Hashable

1314import Data.IORef

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

4849

4950type Hash = Int

5051type FdCache = MMap Hash FdEntry

51−newtype MutableFdCache = MutableFdCache (IORef FdCache)

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

5253

5354newMutableFdCache :: IO MutableFdCache

5455newMutableFdCache = MutableFdCache <$> newIORef empty

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

7980initialize :: Int -> IO MutableFdCache

8081initialize duration = do

8182 mfc <- newMutableFdCache

82− void . forkIO $ loop mfc

83+ tid <- forkIO $ loop mfc

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

8385 return mfc

8486 where

8587 loop mfc = do

86− old <- swapWithNew mfc

87− new <- pruneWith old prune

88− update mfc (merge new)

88+ mask_ $ do

89+ old <- swapWithNew mfc

90+ new <- pruneWith old prune

91+ update mfc (merge new)

8992 threadDelay duration

9093 loop mfc

9194

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+

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

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

94104 where