6ee3b2f · typeable/wai

auto-update/ChangeLog.md+5

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

11# ChangeLog for auto-update

22

3+## 0.1.5

4+

5+* Using the Strict and StrictData language extensions for GHC >8.

6+ [#752](https://github.com/yesodweb/wai/pull/752)

7+

38## 0.1.4.1

49

510* [#693](https://github.com/yesodweb/wai/pull/693):

auto-update/auto-update.cabal+3−1

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

11name: auto-update

2−version: 0.1.4.1

2+version: 0.1.5

33synopsis: Efficiently run periodic, on-demand actions

44description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.

55homepage: https://github.com/yesodweb/wai

@@ -21,6 +21,8 @@ library

2121 other-modules: Control.AutoUpdate.Util

2222 build-depends: base >= 4 && < 5

2323 default-language: Haskell2010

24+ if impl(ghc >= 8)

25+ default-extensions: Strict StrictData

2426

2527-- Test suite is currently not robust enough, gives too many false negatives.

2628

stack-lts-11.yaml+1

@@ -9,6 +9,7 @@ packages:

99- ./wai-app-static

1010- ./wai-websockets

1111- ./wai-conduit

12+- ./time-manager

1213flags:

1314 wai-extra:

1415 build-example: true

stack-lts-12.yaml+1

@@ -9,6 +9,7 @@ packages:

99- ./wai-app-static

1010- ./wai-websockets

1111- ./wai-conduit

12+- ./time-manager

1213flags:

1314 wai-extra:

1415 build-example: true

stack-lts-6.yaml+1

@@ -9,6 +9,7 @@ packages:

99- ./wai-app-static

1010- ./wai-websockets

1111- ./wai-conduit

12+- ./time-manager

1213extra-deps:

1314- bsb-http-chunked-0.0.0.2@sha256:0571ef33ec5530104503d32eaf24f2d7c221f350e5fc475a6dd8e84311bc0ca1,1792

1415- streaming-commons-0.2.1.0@sha256:163af02944f374f316e35257c1afbffefd2c2852a85a151d1ea0ad22152cf28d,4990

stack-lts-9.yaml+1

@@ -9,6 +9,7 @@ packages:

99- ./wai-app-static

1010- ./wai-websockets

1111- ./wai-conduit

12+- ./time-manager

1213extra-deps:

1314- bsb-http-chunked-0.0.0.2@sha256:0571ef33ec5530104503d32eaf24f2d7c221f350e5fc475a6dd8e84311bc0ca1,1792

1415- streaming-commons-0.2.1.0@sha256:163af02944f374f316e35257c1afbffefd2c2852a85a151d1ea0ad22152cf28d,4990

stack.yaml+1

@@ -9,6 +9,7 @@ packages:

99- ./wai-app-static

1010- ./wai-websockets

1111- ./wai-conduit

12+- ./time-manager

1213flags:

1314 wai-extra:

1415 build-example: true

time-manager/LICENSEnew file+20

@@ -0,0 +1,20 @@

2+

3+Permission is hereby granted, free of charge, to any person obtaining

4+a copy of this software and associated documentation files (the

5+"Software"), to deal in the Software without restriction, including

6+without limitation the rights to use, copy, modify, merge, publish,

7+distribute, sublicense, and/or sell copies of the Software, and to

8+permit persons to whom the Software is furnished to do so, subject to

9+the following conditions:

10+

11+The above copyright notice and this permission notice shall be

12+included in all copies or substantial portions of the Software.

13+

14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE

18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION

19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION

20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

warp/Network/Wai/Handler/Warp/Timeout.hs → time-manager/System/TimeManager.hsrenamed+2−3

@@ -1,7 +1,6 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DeriveDataTypeable #-}

32

4−module Network.Wai.Handler.Warp.Timeout (

3+module System.TimeManager (

54 -- ** Types

65 Manager

76 , TimeoutAction

@@ -115,7 +114,7 @@ instance E.Exception TimeoutThread where

115114 toException = E.asyncExceptionToException

116115 fromException = E.asyncExceptionFromException

117116instance Show TimeoutThread where

118− show TimeoutThread = "Thread killed by Warp's timeout reaper"

117+ show TimeoutThread = "Thread killed by timeout manager"

119118

120119----------------------------------------------------------------

121120

time-manager/time-manager.cabalnew file+19

@@ -0,0 +1,19 @@

1+Name: time-manager

2+Version: 0.0.0

3+Synopsis: Scalable timer

4+License: MIT

5+License-file: LICENSE

6+Author: Michael Snoyman and Kazu Yamamoto

7+Maintainer: kazu@iij.ad.jp

8+Homepage: http://github.com/yesodweb/wai

9+Category: System

10+Build-Type: Simple

11+Cabal-Version: >=1.8

12+Stability: Stable

13+Description: Scalable timer functions provided by a timer manager.

14+

15+Library

16+ Build-Depends: base >= 4.8 && < 5

17+ , auto-update

18+ Exposed-modules: System.TimeManager

19+ Ghc-Options: -Wall

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

@@ -102,7 +102,7 @@ test-suite runtests

102102 , temporary

103103 , mockery

104104 -- , containers

105− ghc-options: -Wall

105+ ghc-options: -Wall

106106

107107source-repository head

108108 type: git

warp-tls/ChangeLog.md+5

@@ -1,3 +1,8 @@

1+## 3.2.6

2+

3+* Using the Strict and StrictData language extensions for GHC >8.

4+ [#752](https://github.com/yesodweb/wai/pull/752)

5+

16## 3.2.5

27

38* When tls 1.5.0 is available, TLS 1.3 is automatically supported.

warp-tls/warp-tls.cabal+5−2

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

11Name: warp-tls

2−Version: 3.2.5

2+Version: 3.2.6

33Synopsis: HTTP over TLS support for Warp via the TLS package

44License: MIT

55License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

88Homepage: http://github.com/yesodweb/wai

99Category: Web, Yesod

1010Build-Type: Simple

11−Cabal-Version: >=1.6

11+Cabal-Version: >= 1.10

1212Stability: Stable

1313description: SSLv1 and SSLv2 are obsoleted by IETF.

1414 We should use TLS 1.2 (or TLS 1.1 or TLS 1.0 if necessary).

@@ -32,6 +32,9 @@ Library

3232 ghc-options: -Wall

3333 if os(windows)

3434 Cpp-Options: -DWINDOWS

35+ if impl(ghc >= 8)

36+ Default-Extensions: Strict StrictData

37+ Default-Language: Haskell2010

3538

3639

3740source-repository head

warp/ChangeLog.md+10

@@ -1,3 +1,13 @@

1+## 3.2.28

2+

3+* Using the Strict and StrictData language extensions for GHC >8.

4+ [#752](https://github.com/yesodweb/wai/pull/752)

5+* System.TimeManager is now in a separate package: time-manager.

6+ [#750](https://github.com/yesodweb/wai/pull/750)

7+* Fixing a bug of ALPN.

8+* Introducing the half closed state for HTTP/2.

9+ [#717](https://github.com/yesodweb/wai/pull/717)

10+

111## 3.2.27

212

313* Internally, use `lookupEnv` instead of `getEnvironment` to get the

warp/Network/Wai/Handler/Warp.hs+1−1

@@ -124,6 +124,7 @@ import qualified Data.Vault.Lazy as Vault

124124import qualified Network.HTTP.Types as H

125125import Network.Socket (SockAddr)

126126import Network.Wai (Request, Response, vault)

127+import System.TimeManager

127128

128129import Network.Wai.Handler.Warp.FileInfoCache

129130import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data, setHTTP2Data, modifyHTTP2Data)

@@ -133,7 +134,6 @@ import Network.Wai.Handler.Warp.Request

133134import Network.Wai.Handler.Warp.Response (warpVersion)

134135import Network.Wai.Handler.Warp.Run

135136import Network.Wai.Handler.Warp.Settings

136−import Network.Wai.Handler.Warp.Timeout

137137import Network.Wai.Handler.Warp.Types hiding (getFileInfo)

138138import Network.Wai.Handler.Warp.WithApplication

139139

warp/Network/Wai/Handler/Warp/FdCache.hs+18−22

@@ -17,26 +17,24 @@ module Network.Wai.Handler.Warp.FdCache (

1717import Control.Exception (bracket)

1818import Control.Reaper

1919import Data.IORef

20−import Network.Wai.Handler.Warp.MultiMap

20+import Network.Wai.Handler.Warp.MultiMap as MM

2121import System.Posix.IO (openFd, OpenFileFlags(..), defaultFileFlags, OpenMode(ReadOnly), closeFd, FdOption(CloseOnExec), setFdOption)

2222#endif

2323import System.Posix.Types (Fd)

2424

2525----------------------------------------------------------------

2626

27−type Hash = Int

28−

2927-- | An action to activate a Fd cache entry.

3028type Refresh = IO ()

3129

32−getFdNothing :: Hash -> FilePath -> IO (Maybe Fd, Refresh)

33−getFdNothing _ _ = return (Nothing, return ())

30+getFdNothing :: FilePath -> IO (Maybe Fd, Refresh)

31+getFdNothing _ = return (Nothing, return ())

3432

3533----------------------------------------------------------------

3634

3735-- | Creating 'MutableFdCache' and executing the action in the second

3836-- argument. The first argument is a cache duration in second.

39−withFdCache :: Int -> ((Hash -> FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

37+withFdCache :: Int -> ((FilePath -> IO (Maybe Fd, Refresh)) -> IO a) -> IO a

4038#ifdef WINDOWS

4139withFdCache _ action = action getFdNothing

4240#else

@@ -65,7 +63,7 @@ inactive (MutableStatus ref) = writeIORef ref Inactive

6563

6664----------------------------------------------------------------

6765

68−data FdEntry = FdEntry !FilePath !Fd !MutableStatus

66+data FdEntry = FdEntry !Fd !MutableStatus

6967

7068openFile :: FilePath -> IO Fd

7169openFile path = do

@@ -77,25 +75,23 @@ closeFile :: Fd -> IO ()

7775closeFile = closeFd

7876

7977newFdEntry :: FilePath -> IO FdEntry

80−newFdEntry path = FdEntry path <$> openFile path <*> newActiveStatus

78+newFdEntry path = FdEntry <$> openFile path <*> newActiveStatus

8179

8280setFileCloseOnExec :: Fd -> IO ()

8381setFileCloseOnExec fd = setFdOption fd CloseOnExec True

8482

8583----------------------------------------------------------------

8684

87−type FdCache = MMap FdEntry

85+type FdCache = MultiMap FdEntry

8886

8987-- | Mutable Fd cacher.

90−newtype MutableFdCache = MutableFdCache (Reaper FdCache (Hash, FdEntry))

88+newtype MutableFdCache = MutableFdCache (Reaper FdCache (FilePath,FdEntry))

9189

9290fdCache :: MutableFdCache -> IO FdCache

9391fdCache (MutableFdCache reaper) = reaperRead reaper

9492

95−look :: MutableFdCache -> FilePath -> Hash -> IO (Maybe FdEntry)

96−look mfc path key = searchWith key check <$> fdCache mfc

97− where

98− check (FdEntry path' _ _) = path == path'

93+look :: MutableFdCache -> FilePath -> IO (Maybe FdEntry)

94+look mfc path = MM.lookup path <$> fdCache mfc

9995

10096----------------------------------------------------------------

10197

@@ -116,7 +112,7 @@ clean old = do

116112 new <- pruneWith old prune

117113 return $ merge new

118114 where

119− prune (FdEntry _ fd mst) = status mst >>= act

115+ prune (_,FdEntry fd mst) = status mst >>= act

120116 where

121117 act Active = inactive mst >> return True

122118 act Inactive = closeFd fd >> return False

@@ -126,21 +122,21 @@ clean old = do

126122terminate :: MutableFdCache -> IO ()

127123terminate (MutableFdCache reaper) = do

128124 !t <- reaperStop reaper

129− mapM_ closeIt $ toList t

125+ mapM_ (closeIt . snd) $ toList t

130126 where

131− closeIt (FdEntry _ fd _) = closeFd fd

127+ closeIt (FdEntry fd _) = closeFd fd

132128

133129----------------------------------------------------------------

134130

135131-- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher.

136−getFd :: MutableFdCache -> Hash -> FilePath -> IO (Maybe Fd, Refresh)

137−getFd mfc@(MutableFdCache reaper) h path = look mfc path h >>= get

132+getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)

133+getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get

138134 where

139135 get Nothing = do

140− ent@(FdEntry _ fd mst) <- newFdEntry path

141− reaperAdd reaper (h, ent)

136+ ent@(FdEntry fd mst) <- newFdEntry path

137+ reaperAdd reaper (path,ent)

142138 return (Just fd, refresh mst)

143− get (Just (FdEntry _ fd mst)) = do

139+ get (Just (FdEntry fd mst)) = do

144140 refresh mst

145141 return (Just fd, refresh mst)

146142#endif

warp/Network/Wai/Handler/Warp/FileInfoCache.hs+19−22

@@ -2,7 +2,6 @@

22

33module Network.Wai.Handler.Warp.FileInfoCache (

44 FileInfo(..)

5− , Hash

65 , withFileInfoCache

76 , getInfo -- test purpose only

87 ) where

@@ -18,8 +17,6 @@ import Network.Wai.Handler.Warp.Imports

1817

1918----------------------------------------------------------------

2019

21−type Hash = Int

22−

2320-- | File information.

2421data FileInfo = FileInfo {

2522 fileInfoName :: !FilePath

@@ -29,8 +26,8 @@ data FileInfo = FileInfo {

2926 } deriving (Eq, Show)

3027

3128data Entry = Negative | Positive FileInfo

32−type Cache = HashMap FilePath Entry

33−type FileInfoCache = Reaper Cache (Int,FilePath,Entry)

29+type Cache = HashMap Entry

30+type FileInfoCache = Reaper Cache (FilePath,Entry)

3431

3532----------------------------------------------------------------

3633

@@ -54,29 +51,29 @@ getInfo path = do

5451 else

5552 throwIO (userError "FileInfoCache:getInfo")

5653

57−getInfoNaive :: Hash -> FilePath -> IO FileInfo

58−getInfoNaive _ = getInfo

54+getInfoNaive :: FilePath -> IO FileInfo

55+getInfoNaive = getInfo

5956

6057----------------------------------------------------------------

6158

62−getAndRegisterInfo :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

63−getAndRegisterInfo reaper@Reaper{..} h path = do

59+getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo

60+getAndRegisterInfo reaper@Reaper{..} path = do

6461 cache <- reaperRead

65− case M.lookup h path cache of

62+ case M.lookup path cache of

6663 Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")

6764 Just (Positive x) -> return x

68− Nothing -> positive reaper h path

69− `E.onException` negative reaper h path

65+ Nothing -> positive reaper path

66+ `E.onException` negative reaper path

7067

71−positive :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

72−positive Reaper{..} h path = do

68+positive :: FileInfoCache -> FilePath -> IO FileInfo

69+positive Reaper{..} path = do

7370 info <- getInfo path

74− reaperAdd (h, path, Positive info)

71+ reaperAdd (path, Positive info)

7572 return info

7673

77−negative :: FileInfoCache -> Hash -> FilePath -> IO FileInfo

78−negative Reaper{..} h path = do

79− reaperAdd (h, path,Negative)

74+negative :: FileInfoCache -> FilePath -> IO FileInfo

75+negative Reaper{..} path = do

76+ reaperAdd (path, Negative)

8077 throwIO (userError "FileInfoCache:negative")

8178

8279----------------------------------------------------------------

@@ -85,7 +82,7 @@ negative Reaper{..} h path = do

8582-- and executing the action in the second argument.

8683-- The first argument is a cache duration in second.

8784withFileInfoCache :: Int

88− -> ((Hash -> FilePath -> IO FileInfo) -> IO a)

85+ -> ((FilePath -> IO FileInfo) -> IO a)

8986 -> IO a

9087withFileInfoCache 0 action = action getInfoNaive

9188withFileInfoCache duration action =

@@ -93,14 +90,14 @@ withFileInfoCache duration action =

9390 terminate

9491 (action . getAndRegisterInfo)

9592

96−initialize :: Hash -> IO FileInfoCache

93+initialize :: Int -> IO FileInfoCache

9794initialize duration = mkReaper settings

9895 where

9996 settings = defaultReaperSettings {

10097 reaperAction = override

10198 , reaperDelay = duration

102− , reaperCons = \(h,k,v) -> M.insert h k v

103− , reaperNull = M.null

99+ , reaperCons = \(path,v) -> M.insert path v

100+ , reaperNull = M.isEmpty

104101 , reaperEmpty = M.empty

105102 }

106103

warp/Network/Wai/Handler/Warp/HTTP2.hs+4−4

@@ -22,8 +22,8 @@ import Network.Wai.Handler.Warp.Types

2222

2323----------------------------------------------------------------

2424

25−http2 :: Connection -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()

26−http2 conn ii1 addr transport settings readN app = do

25+http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()

26+http2 conn ii addr transport settings readN app = do

2727 checkTLS

2828 ok <- checkPreface

2929 when ok $ do

@@ -40,8 +40,8 @@ http2 conn ii1 addr transport settings readN app = do

4040 -- context switches happen.

4141 replicateM_ 3 $ spawnAction mgr

4242 -- Receiver

43− let mkreq = mkRequest ii1 settings addr

44− tid <- forkIO $ frameReceiver ctx mkreq readN

43+ let mkreq = mkRequest ii settings addr

44+ tid <- forkIO $ frameReceiver ctx ii mkreq readN

4545 -- Sender

4646 -- frameSender is the main thread because it ensures to send

4747 -- a goway frame.

warp/Network/Wai/Handler/Warp/HTTP2/Manager.hs+1−1

@@ -19,10 +19,10 @@ import Data.Foldable

1919import Data.IORef

2020import Data.Set (Set)

2121import qualified Data.Set as Set

22+import qualified System.TimeManager as T

2223

2324import Network.Wai.Handler.Warp.Imports

2425import Network.Wai.Handler.Warp.Settings

25−import qualified Network.Wai.Handler.Warp.Timeout as T

2626

2727----------------------------------------------------------------

2828

warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hs+4−4

@@ -27,8 +27,8 @@ import Network.Wai.Handler.Warp.Types

2727

2828----------------------------------------------------------------

2929

30−frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()

31−frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway

30+frameReceiver :: Context -> InternalInfo -> MkReq -> (BufSize -> IO ByteString) -> IO ()

31+frameReceiver ctx ii mkreq recvN = loop 0 `E.catch` sendGoaway

3232 where

3333 Context{ http2settings

3434 , streamTable

@@ -120,7 +120,7 @@ frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway

120120 E.throwIO $ StreamError ProtocolError streamId

121121 writeIORef streamPrecedence $ toPrecedence pri

122122 halfClosedRemote ctx strm

123− (!req, !ii) <- mkreq tbl (Just 0, return "")

123+ !req <- mkreq tbl (Just 0, return "")

124124 atomically $ writeTQueue inputQ $ Input strm req reqvt ii

125125 Open (HasBody tbl@(_,reqvt) pri) -> do

126126 resetContinued

@@ -131,7 +131,7 @@ frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway

131131 setStreamState ctx strm $ Open (Body q mcl bodyLength)

132132 readQ <- newReadBody q

133133 bodySource <- mkSource readQ

134− (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)

134+ !req <- mkreq tbl (mcl, readSource bodySource)

135135 atomically $ writeTQueue inputQ $ Input strm req reqvt ii

136136 s@(Open Continued{}) -> do

137137 setContinued

warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+4−8

@@ -22,23 +22,22 @@ import Network.Wai.Internal (Request(..))

2222import System.IO.Unsafe (unsafePerformIO)

2323

2424import Network.Wai.Handler.Warp.HTTP2.Types

25−import Network.Wai.Handler.Warp.HashMap (hashByteString)

2625import Network.Wai.Handler.Warp.Imports

2726import Network.Wai.Handler.Warp.Request (getFileInfoKey)

2827import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)

2928import Network.Wai.Handler.Warp.Types

3029

31−type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)

30+type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request)

3231

33−mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq

32+mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq

3433mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do

3534 ref <- newIORef Nothing

3635 mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)

3736

38−mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr

37+mkRequest' :: InternalInfo -> S.Settings -> SockAddr

3938 -> IORef (Maybe HTTP2Data)

4039 -> MkReq

41−mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)

40+mkRequest' ii settings addr ref (reqths,reqvt) (bodylen,body) = return req

4241 where

4342 !req = Request {

4443 requestMethod = colonMethod

@@ -77,9 +76,6 @@ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)

7776 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)

7877 !path = H.extractPath unparsedPath

7978 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path

80− !h = hashByteString rawPath

81− -- timeout handler must be overwritten with worker's one.

82− !ii = toInternalInfo ii1 h

8379 !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)

8480 $ Vault.insert getHTTP2DataKey (readIORef ref)

8581 $ Vault.insert setHTTP2DataKey (writeIORef ref)

warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+1−1

@@ -22,7 +22,7 @@ import qualified System.IO as IO

2222#else

2323import Network.Wai.Handler.Warp.FdCache

2424import Network.Wai.Handler.Warp.SendFile (positionRead)

25−import qualified Network.Wai.Handler.Warp.Timeout as T

25+import qualified System.TimeManager as T

2626#endif

2727

2828import Network.Wai.Handler.Warp.Buffer

warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+1−1

@@ -33,7 +33,7 @@ isHTTP2 tls = useHTTP2

3333 where

3434 useHTTP2 = case tlsNegotiatedProtocol tls of

3535 Nothing -> False

36− Just proto -> "h2-" `BS.isPrefixOf` proto

36+ Just proto -> "h2" `BS.isPrefixOf` proto

3737

3838----------------------------------------------------------------

3939

warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+7−9

@@ -23,8 +23,8 @@ import qualified Network.HTTP.Types as H

2323import Network.HTTP2

2424import Network.HTTP2.Priority

2525import Network.Wai

26−import qualified Network.Wai.Handler.Warp.Timeout as Timeout

2726import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..), getRequestBodyChunk)

27+import qualified System.TimeManager as T

2828

2929import Network.Wai.Handler.Warp.FileInfoCache

3030import Network.Wai.Handler.Warp.HTTP2.EncodeFrame

@@ -36,7 +36,6 @@ import Network.Wai.Handler.Warp.Imports hiding (insert)

3636import Network.Wai.Handler.Warp.Request (pauseTimeoutKey)

3737import qualified Network.Wai.Handler.Warp.Response as R

3838import qualified Network.Wai.Handler.Warp.Settings as S

39−import qualified Network.Wai.Handler.Warp.Timeout as T

4039import Network.Wai.Handler.Warp.Types

4140

4241----------------------------------------------------------------

@@ -45,6 +44,7 @@ import Network.Wai.Handler.Warp.Types

4544-- This type implements the second argument (Response -> IO ResponseReceived)

4645-- with extra arguments.

4746type Responder = InternalInfo

47+ -> T.Handle

4848 -> ValueTable -- for Request

4949 -> ThreadContinue

5050 -> Stream

@@ -119,7 +119,7 @@ pushStream ctx@Context{http2settings,outputQ,streamTable}

119119-- They also pass 'Response's from 'Application's to this function.

120120-- This function enqueues commands for the HTTP/2 sender.

121121response :: S.Settings -> Context -> Manager -> Responder

122−response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of

122+response settings ctx@Context{outputQ} mgr ii th reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of

123123 ResponseStream s0 hs0 strmbdy

124124 | noBody s0 -> responseNoBody s0 hs0

125125 | isHead -> responseNoBody s0 hs0

@@ -142,7 +142,6 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = E.handl

142142 noBody = not . R.hasBody

143143 !isHead = requestMethod req == H.methodHead

144144 !logger = S.settingsLogger settings

145− !th = threadHandle ii

146145 sid = streamNumber strm

147146 !h2data = getHTTP2Data req

148147

@@ -246,21 +245,20 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do

246245 setStreamInfo sinfo inp

247246 T.resume th

248247 T.tickle th

249− let !ii' = ii { threadHandle = th }

250− !body = getRequestBodyChunk req

248+ let !body = getRequestBodyChunk req

251249 !body' = do

252250 T.pause th

253251 bs <- body

254252 T.resume th

255253 return bs

256− !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ vault req

254+ !vaultValue = Vault.insert pauseTimeoutKey (T.pause th) $ vault req

257255 !req' = req { vault = vaultValue, requestBody = body' }

258− mr <- E.try $ app req' $ responder ii' reqvt tcont strm req'

256+ mr <- E.try $ app req' $ responder ii th reqvt tcont strm req'

259257 case mr of

260258 Right ok -> return ok

261259 Left e@(SomeException _)

262260 | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e'

263− | otherwise -> responder ii' reqvt tcont strm req' (S.settingsOnExceptionResponse set e)

261+ | otherwise -> responder ii th reqvt tcont strm req' (S.settingsOnExceptionResponse set e)

264262 cont1 <- case ex of

265263 Right ResponseReceived -> return True

266264 Left e@(SomeException _)

warp/Network/Wai/Handler/Warp/HashMap.hs+24−15

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

1+{-# LANGUAGE BangPatterns #-}

2+

13module Network.Wai.Handler.Warp.HashMap where

24

35import Data.Hashable (hash)

@@ -7,27 +9,34 @@ import Data.Map.Strict (Map)

79import qualified Data.Map.Strict as M

810import Prelude hiding (lookup)

911

10−import Network.Wai.Handler.Warp.Imports hiding (insert, lookup)

12+----------------------------------------------------------------

1113

12−type Hash = Int

13−newtype HashMap k v = HashMap (IntMap (Map k v))

14+-- | 'HashMap' is used for cache of file information.

15+-- Hash values of file pathes are used as outer keys.

16+-- Because negative entries are also contained,

17+-- a bad guy can intentionally cause the hash collison.

18+-- So, 'Map' is used internally to prevent

19+-- the hash collision attack.

20+newtype HashMap v = HashMap (IntMap (Map FilePath v))

1421

15−hashByteString :: ByteString -> Hash

16−hashByteString = hash

22+----------------------------------------------------------------

1723

18−empty :: HashMap k v

24+empty :: HashMap v

1925empty = HashMap I.empty

2026

21−null :: HashMap k v -> Bool

22−null (HashMap hm) = I.null hm

27+isEmpty :: HashMap v -> Bool

28+isEmpty (HashMap hm) = I.null hm

29+

30+----------------------------------------------------------------

2331

24−insert :: Ord k => Hash -> k -> v -> HashMap k v -> HashMap k v

25−insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm

32+insert :: FilePath -> v -> HashMap v -> HashMap v

33+insert path v (HashMap hm) = HashMap $ I.insertWith f h m hm

2634 where

27− m = M.singleton k v

35+ !h = hash path

36+ !m = M.singleton path v

2837 f = M.union -- fimxe

29−{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}

3038

31−lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v

32−lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k

33−{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}

39+lookup :: FilePath -> HashMap v -> Maybe v

40+lookup path (HashMap hm) = I.lookup h hm >>= M.lookup path

41+ where

42+ !h = hash path

warp/Network/Wai/Handler/Warp/Internal.hs+3−2

@@ -53,7 +53,7 @@ module Network.Wai.Handler.Warp.Internal (

5353 -- resumed as soon as we return from user code.

5454 --

5555 -- * Every time data is successfully sent to the client, the timeout is tickled.

56− , module Network.Wai.Handler.Warp.Timeout

56+ , module System.TimeManager

5757 -- * File descriptor cache

5858 , module Network.Wai.Handler.Warp.FdCache

5959 -- * File information cache

@@ -69,6 +69,8 @@ module Network.Wai.Handler.Warp.Internal (

6969 , windowsThreadBlockHack

7070 ) where

7171

72+import System.TimeManager

73+

7274import Network.Wai.Handler.Warp.Buffer

7375import Network.Wai.Handler.Warp.Date

7476import Network.Wai.Handler.Warp.FdCache

@@ -80,6 +82,5 @@ import Network.Wai.Handler.Warp.Response

8082import Network.Wai.Handler.Warp.Run

8183import Network.Wai.Handler.Warp.SendFile

8284import Network.Wai.Handler.Warp.Settings

83−import Network.Wai.Handler.Warp.Timeout

8485import Network.Wai.Handler.Warp.Types

8586import Network.Wai.Handler.Warp.Windows

warp/Network/Wai/Handler/Warp/MultiMap.hs+55−44

@@ -1,100 +1,111 @@

1+{-# LANGUAGE BangPatterns #-}

2+

13module Network.Wai.Handler.Warp.MultiMap (

2− MMap

4+ MultiMap

35 , isEmpty

46 , empty

57 , singleton

68 , insert

7− , search

8− , searchWith

9+ , Network.Wai.Handler.Warp.MultiMap.lookup

910 , pruneWith

1011 , toList

1112 , merge

1213 ) where

1314

15+import Data.Hashable (hash)

1416import Data.IntMap.Strict (IntMap)

1517import qualified Data.IntMap.Strict as I

16−import qualified Data.List.NonEmpty as NE

1718import Data.Semigroup

1819import Prelude -- Silence redundant import warnings

1920

20−import Network.Wai.Handler.Warp.Imports hiding ((<>), union, empty, insert)

21−

2221----------------------------------------------------------------

2322

24−type MMap v = IntMap (NonEmpty v)

23+-- | 'MultiMap' is used for cache of file descriptors.

24+-- Since multiple threads would open file descriptors for

25+-- the same file simultaneously, multiple entries must

26+-- be contained for the file.

27+-- Since hash values of file pathes are used as outer keys,

28+-- collison would happen for multiple file pathes.

29+-- Becase only positive entries are contained,

30+-- a bad guy cannot be cause the hash collision intentinally.

31+-- So, lists are good enough.

32+newtype MultiMap v = MultiMap (IntMap [(FilePath,v)])

2533

2634----------------------------------------------------------------

2735

2836-- | O(1)

29−isEmpty :: MMap v -> Bool

30−isEmpty = I.null

37+empty :: MultiMap v

38+empty = MultiMap $ I.empty

3139

3240-- | O(1)

33−empty :: MMap v

34−empty = I.empty

41+isEmpty :: MultiMap v -> Bool

42+isEmpty (MultiMap mm) = I.null mm

3543

3644----------------------------------------------------------------

3745

3846-- | O(1)

39−singleton :: Int -> v -> MMap v

40−singleton k v = I.singleton k (v :| [])

47+singleton :: FilePath -> v -> MultiMap v

48+singleton path v = MultiMap mm

49+ where

50+ !h = hash path

51+ !mm = I.singleton h [(path,v)]

4152

4253----------------------------------------------------------------

4354

44−-- | O(log n)

45−search :: Int -> MMap v -> Maybe v

46−search k m = case I.lookup k m of

55+-- | O(N)

56+lookup :: FilePath -> MultiMap v -> Maybe v

57+lookup path (MultiMap mm) = case I.lookup h mm of

4758 Nothing -> Nothing

48− Just s -> Just $! NE.head s

49−

50−-- | O(log n)

51−searchWith :: Int -> (v -> Bool) -> MMap v -> Maybe v

52−searchWith k f m = case I.lookup k m of

53− Nothing -> Nothing

54− Just nxs -> find f $ NE.toList nxs

59+ Just s -> Prelude.lookup path s

60+ where

61+ !h = hash path

5562

5663----------------------------------------------------------------

5764

5865-- | O(log n)

59−insert :: Int -> v -> MMap v -> MMap v

60−insert k v m = I.insertWith (<>) k (v :| []) m

66+insert :: FilePath -> v -> MultiMap v -> MultiMap v

67+insert path v (MultiMap mm) = MultiMap mm'

68+ where

69+ !h = hash path

70+ !mm' = I.insertWith (<>) h [(path,v)] mm

6171

6272----------------------------------------------------------------

6373

6474-- | O(n)

65−toList :: MMap v -> [v]

66−toList m = concatMap f $ I.toAscList m

67− where

68− f (_,s) = NE.toList s

75+toList :: MultiMap v -> [(FilePath,v)]

76+toList (MultiMap mm) = concatMap snd $ I.toAscList mm

6977

7078----------------------------------------------------------------

7179

7280-- | O(n)

73−pruneWith :: MMap v

74− -> (v -> IO Bool)

75− -> IO (MMap v)

76−pruneWith m action = I.fromAscList <$> go (I.toDescList m) []

81+pruneWith :: MultiMap v

82+ -> ((FilePath,v) -> IO Bool)

83+ -> IO (MultiMap v)

84+pruneWith (MultiMap mm) action = MultiMap <$> mm'

7785 where

78− go [] acc = return acc

79− go ((k,s):kss) acc = do

80− mt <- prune action s

81− case mt of

82− Nothing -> go kss acc

83− Just t -> go kss ((k,t) : acc)

86+ !mm' = I.fromAscList <$> go (I.toDescList mm) []

87+ go [] !acc = return acc

88+ go ((h,s):kss) !acc = do

89+ rs <- prune action s

90+ case rs of

91+ [] -> go kss acc

92+ _ -> go kss ((h,rs) : acc)

8493

8594----------------------------------------------------------------

8695

8796-- O(n + m) where N is the size of the second argument

88−merge :: MMap v -> MMap v -> MMap v

89−merge m1 m2 = I.unionWith (<>) m1 m2

97+merge :: MultiMap v -> MultiMap v -> MultiMap v

98+merge (MultiMap m1) (MultiMap m2) = MultiMap mm

99+ where

100+ !mm = I.unionWith (<>) m1 m2

90101

91102----------------------------------------------------------------

92103

93−prune :: (a -> IO Bool) -> NonEmpty a -> IO (Maybe (NonEmpty a))

94−prune act nxs = NE.nonEmpty <$> go (NE.toList nxs)

104+prune :: ((FilePath,v) -> IO Bool) -> [(FilePath,v)] -> IO [(FilePath,v)]

105+prune action xs0 = go xs0

95106 where

96107 go [] = return []

97108 go (x:xs) = do

98− keep <- act x

109+ keep <- action x

99110 rs <- go xs

100111 return $ if keep then x:rs else rs

warp/Network/Wai/Handler/Warp/Request.hs+6−10

@@ -24,15 +24,14 @@ import qualified Data.Vault.Lazy as Vault

2424import qualified Network.HTTP.Types as H

2525import Network.Socket (SockAddr)

2626import Network.Wai

27−import qualified Network.Wai.Handler.Warp.Timeout as Timeout

2827import Network.Wai.Handler.Warp.Types

2928import Network.Wai.Internal

3029import Prelude hiding (lines)

3130import System.IO.Unsafe (unsafePerformIO)

31+import qualified System.TimeManager as Timeout

3232

3333import Network.Wai.Handler.Warp.Conduit

3434import Network.Wai.Handler.Warp.FileInfoCache

35−import Network.Wai.Handler.Warp.HashMap (hashByteString)

3635import Network.Wai.Handler.Warp.Header

3736import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)

3837import Network.Wai.Handler.Warp.ReadInt

@@ -52,20 +51,20 @@ maxTotalHeaderLength = 50 * 1024

5251recvRequest :: Bool -- ^ first request on this connection?

5352 -> Settings

5453 -> Connection

55− -> InternalInfo1

54+ -> InternalInfo

55+ -> Timeout.Handle

5656 -> SockAddr -- ^ Peer's address.

5757 -> Source -- ^ Where HTTP request comes from.

5858 -> IO (Request

5959 ,Maybe (I.IORef Int)

6060 ,IndexedHeader

61− ,IO ByteString

62− ,InternalInfo) -- ^

61+ ,IO ByteString) -- ^

6362 -- 'Request' passed to 'Application',

6463 -- how many bytes remain to be consumed, if known

6564 -- 'IndexedHeader' of HTTP request for internal use,

6665 -- Body producing action used for flushing the request body

6766

68−recvRequest firstRequest settings conn ii1 addr src = do

67+recvRequest firstRequest settings conn ii th addr src = do

6968 hdrlines <- headerLines firstRequest src

7069 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines

7170 let idxhdr = indexRequestHeader hdr

@@ -74,9 +73,6 @@ recvRequest firstRequest settings conn ii1 addr src = do

7473 te = idxhdr ! fromEnum ReqTransferEncoding

7574 handle100Continue = handleExpect conn httpversion expect

7675 rawPath = if settingsNoParsePath settings then unparsedPath else path

77− h = hashByteString rawPath

78− ii = toInternalInfo ii1 h

79− th = threadHandle ii

8076 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)

8177 $ Vault.insert getFileInfoKey (getFileInfo ii)

8278 Vault.empty

@@ -103,7 +99,7 @@ recvRequest firstRequest settings conn ii1 addr src = do

10399 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer

104100 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent

105101 }

106− return (req, remainingRef, idxhdr, rbodyFlush, ii)

102+ return (req, remainingRef, idxhdr, rbodyFlush)

107103

108104----------------------------------------------------------------

109105

warp/Network/Wai/Handler/Warp/Response.hs+3−3

@@ -30,6 +30,7 @@ import qualified Network.HTTP.Types.Header as H

3030import Network.Wai

3131import Network.Wai.Internal

3232import qualified Paths_warp

33+import qualified System.TimeManager as T

3334

3435import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)

3536import qualified Network.Wai.Handler.Warp.Date as D

@@ -39,7 +40,6 @@ import Network.Wai.Handler.Warp.IO (toBufIOWith)

3940import Network.Wai.Handler.Warp.Imports

4041import Network.Wai.Handler.Warp.ResponseHeader

4142import Network.Wai.Handler.Warp.Settings

42−import qualified Network.Wai.Handler.Warp.Timeout as T

4343import Network.Wai.Handler.Warp.Types

4444

4545-- $setup

@@ -101,12 +101,13 @@ import Network.Wai.Handler.Warp.Types

101101sendResponse :: Settings

102102 -> Connection

103103 -> InternalInfo

104+ -> T.Handle

104105 -> Request -- ^ HTTP request.

105106 -> IndexedHeader -- ^ Indexed header of HTTP request.

106107 -> IO ByteString -- ^ source from client, for raw response

107108 -> Response -- ^ HTTP response including status code and response header.

108109 -> IO Bool -- ^ Returing True if the connection is persistent.

109−sendResponse settings conn ii req reqidxhdr src response = do

110+sendResponse settings conn ii th req reqidxhdr src response = do

110111 hs <- addServerAndDate hs0

111112 if hasBody s then do

112113 -- The response to HEAD does not have body.

@@ -133,7 +134,6 @@ sendResponse settings conn ii req reqidxhdr src response = do

133134 s = responseStatus response

134135 hs0 = sanitizeHeaders $ responseHeaders response

135136 rspidxhdr = indexResponseHeader hs0

136− th = threadHandle ii

137137 getdate = getDate ii

138138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr

139139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr

warp/Network/Wai/Handler/Warp/Run.hs+21−24

@@ -25,6 +25,7 @@ import Network.Wai

2525import Network.Wai.Internal (ResponseReceived (ResponseReceived))

2626import System.Environment (lookupEnv)

2727import System.Timeout (timeout)

28+import qualified System.TimeManager as T

2829

2930import Network.Wai.Handler.Warp.Buffer

3031import Network.Wai.Handler.Warp.Counter

@@ -40,7 +41,6 @@ import Network.Wai.Handler.Warp.Request

4041import Network.Wai.Handler.Warp.Response

4142import Network.Wai.Handler.Warp.SendFile

4243import Network.Wai.Handler.Warp.Settings

43−import qualified Network.Wai.Handler.Warp.Timeout as T

4444import Network.Wai.Handler.Warp.Types

4545

4646

@@ -168,15 +168,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),

168168runSettingsConnectionMakerSecure set getConnMaker app = do

169169 settingsBeforeMainLoop set

170170 counter <- newCounter

171− withII0 $ acceptConnection set getConnMaker app counter

171+ withII $ acceptConnection set getConnMaker app counter

172172 where

173− withII0 action =

173+ withII action =

174174 withTimeoutManager $ \tm ->

175175 D.withDateCache $ \dc ->

176176 F.withFdCache fdCacheDurationInSeconds $ \fdc ->

177177 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do

178− let ii0 = InternalInfo0 tm dc fdc fic

179− action ii0

178+ let ii = InternalInfo tm dc fdc fic

179+ action ii

180180

181181 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000

182182 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000

@@ -205,9 +205,9 @@ acceptConnection :: Settings

205205 -> IO (IO (Connection, Transport), SockAddr)

206206 -> Application

207207 -> Counter

208− -> InternalInfo0

208+ -> InternalInfo

209209 -> IO ()

210−acceptConnection set getConnMaker app counter ii0 = do

210+acceptConnection set getConnMaker app counter ii = do

211211 -- First mask all exceptions in acceptLoop. This is necessary to

212212 -- ensure that no async exception is throw between the call to

213213 -- acceptNewConnection and the registering of connClose.

@@ -234,7 +234,7 @@ acceptConnection set getConnMaker app counter ii0 = do

234234 case mx of

235235 Nothing -> return ()

236236 Just (mkConn, addr) -> do

237− fork set mkConn addr app counter ii0

237+ fork set mkConn addr app counter ii

238238 acceptLoop

239239

240240 acceptNewConnection = do

@@ -257,9 +257,9 @@ fork :: Settings

257257 -> SockAddr

258258 -> Application

259259 -> Counter

260− -> InternalInfo0

260+ -> InternalInfo

261261 -> IO ()

262−fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

262+fork set mkConn addr app counter ii = settingsFork set $ \unmask ->

263263 -- Call the user-supplied on exception code if any

264264 -- exceptions are thrown.

265265 handle (settingsOnException set Nothing) .

@@ -291,7 +291,6 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

291291 -- the connection immediately in case the child thread catches the

292292 -- async exception or performs some long-running cleanup action.

293293 serve unmask ref (conn, transport) = bracket register cancel $ \th -> do

294− let ii1 = toInternalInfo1 ii0 th

295294 -- We now have fully registered a connection close handler in

296295 -- the case of all exceptions, so it is safe to once again

297296 -- allow async exceptions.

@@ -301,9 +300,9 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

301300 bracket (onOpen addr) (onClose addr) $ \goingon ->

302301 -- Actually serve this connection. bracket with closeConn

303302 -- above ensures the connection is closed.

304− when goingon $ serveConnection conn ii1 addr transport set app

303+ when goingon $ serveConnection conn ii th addr transport set app

305304 where

306− register = T.registerKillThread (timeoutManager0 ii0)

305+ register = T.registerKillThread (timeoutManager ii)

307306 (closeConn ref conn)

308307 cancel = T.cancel

309308

@@ -311,13 +310,14 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->

311310 onClose adr _ = decrease counter >> settingsOnClose set adr

312311

313312serveConnection :: Connection

314− -> InternalInfo1

313+ -> InternalInfo

314+ -> T.Handle

315315 -> SockAddr

316316 -> Transport

317317 -> Settings

318318 -> Application

319319 -> IO ()

320−serveConnection conn ii1 origAddr transport settings app = do

320+serveConnection conn ii th origAddr transport settings app = do

321321 -- fixme: Upgrading to HTTP/2 should be supported.

322322 (h2,bs) <- if isHTTP2 transport then

323323 return (True, "")

@@ -332,7 +332,7 @@ serveConnection conn ii1 origAddr transport settings app = do

332332 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)

333333 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN

334334 -- fixme: origAddr

335− http2 conn ii1 origAddr transport settings recvN app

335+ http2 conn ii origAddr transport settings recvN app

336336 else do

337337 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))

338338 writeIORef istatus True

@@ -388,8 +388,6 @@ serveConnection conn ii1 origAddr transport settings app = do

388388

389389 decodeAscii = map (chr . fromEnum) . S.unpack

390390

391− th = threadHandle1 ii1

392−

393391 shouldSendErrorResponse se

394392 | Just ConnectionClosedByPeer <- fromException se = False

395393 | otherwise = True

@@ -398,8 +396,7 @@ serveConnection conn ii1 origAddr transport settings app = do

398396 status <- readIORef istatus

399397 if shouldSendErrorResponse e && status

400398 then do

401− let ii = toInternalInfo ii1 0 -- dummy

402− sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)

399+ sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)

403400 else return False

404401

405402 dummyreq addr = defaultRequest { remoteHost = addr }

@@ -407,9 +404,9 @@ serveConnection conn ii1 origAddr transport settings app = do

407404 errorResponse e = settingsOnExceptionResponse settings e

408405

409406 http1 firstRequest addr istatus src = do

410− (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src

407+ (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src

411408 let req = req' { isSecure = isTransportSecure transport }

412− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii

409+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush

413410 `E.catch` \e -> do

414411 settingsOnException settings (Just req) e

415412 -- Don't throw the error again to prevent calling settingsOnException twice.

@@ -425,7 +422,7 @@ serveConnection conn ii1 origAddr transport settings app = do

425422 -- and ignore. See: https://github.com/yesodweb/wai/issues/618

426423 when keepAlive $ http1 False addr istatus src

427424

428− processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do

425+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do

429426 -- Let the application run for as long as it wants

430427 T.pause th

431428

@@ -439,7 +436,7 @@ serveConnection conn ii1 origAddr transport settings app = do

439436 -- send more meaningful error messages to the user.

440437 -- However, it may affect performance.

441438 writeIORef istatus False

442− keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

439+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res

443440 writeIORef keepAliveRef keepAlive

444441 return ResponseReceived

445442 case r of

warp/Network/Wai/Handler/Warp/Settings.hs+1−1

@@ -21,9 +21,9 @@ import Network.Wai

2121import qualified Paths_warp

2222import System.IO (stderr)

2323import System.IO.Error (ioeGetErrorType)

24+import System.TimeManager

2425

2526import Network.Wai.Handler.Warp.Imports

26−import Network.Wai.Handler.Warp.Timeout

2727import Network.Wai.Handler.Warp.Types

2828

2929-- | Various Warp server settings. This is purposely kept as an abstract data

warp/Network/Wai/Handler/Warp/Types.hs+2−31

@@ -10,12 +10,12 @@ import Data.IORef (IORef, readIORef, writeIORef, newIORef)

1010import Data.Typeable (Typeable)

1111import Foreign.Ptr (Ptr)

1212import System.Posix.Types (Fd)

13+import qualified System.TimeManager as T

1314

1415import qualified Network.Wai.Handler.Warp.Date as D

1516import qualified Network.Wai.Handler.Warp.FdCache as F

1617import qualified Network.Wai.Handler.Warp.FileInfoCache as I

1718import Network.Wai.Handler.Warp.Imports

18−import qualified Network.Wai.Handler.Warp.Timeout as T

1919

2020----------------------------------------------------------------

2121

@@ -126,42 +126,13 @@ data Connection = Connection {

126126

127127----------------------------------------------------------------

128128

129−type Hash = Int

130−

131−

132−data InternalInfo0 =

133− InternalInfo0 T.Manager

134− (IO D.GMTDate)

135− (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

136− (Hash -> FilePath -> IO I.FileInfo)

137−

138−timeoutManager0 :: InternalInfo0 -> T.Manager

139−timeoutManager0 (InternalInfo0 tm _ _ _) = tm

140−

141−data InternalInfo1 =

142− InternalInfo1 T.Handle

143− T.Manager

144− (IO D.GMTDate)

145− (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))

146− (Hash -> FilePath -> IO I.FileInfo)

147−

148−toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1

149−toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e

150−

151−threadHandle1 :: InternalInfo1 -> T.Handle

152−threadHandle1 (InternalInfo1 th _ _ _ _) = th

153−

154129data InternalInfo = InternalInfo {

155− threadHandle :: T.Handle

156− , timeoutManager :: T.Manager

130+ timeoutManager :: T.Manager

157131 , getDate :: IO D.GMTDate

158132 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)

159133 , getFileInfo :: FilePath -> IO I.FileInfo

160134 }

161135

162−toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo

163−toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h)

164−

165136----------------------------------------------------------------

166137

167138-- | Type for input streaming.

warp/test/FdCacheSpec.hs+1−1

@@ -17,7 +17,7 @@ spec = describe "withFdCache" $ do

1717 it "clean up Fd" $ do

1818 ref <- newIORef (Fd (-1))

1919 withFdCache 30000000 $ \getFd -> do

20− (Just fd,_) <- getFd 0 "warp.cabal"

20+ (Just fd,_) <- getFd "warp.cabal"

2121 writeIORef ref fd

2222 nfd <- readIORef ref

2323 fdRead nfd 1 `shouldThrow` anyIOException

warp/test/RunSpec.hs+2−2

@@ -411,13 +411,13 @@ spec = do

411411 it "streaming echo #249" $ do

412412 countVar <- newTVarIO (0 :: Int)

413413 let app req f = f $ responseStream status200 [] $ \write _ -> do

414− let loop = do

414+ let loop = do

415415 bs <- getRequestBodyChunk req

416416 unless (S.null bs) $ do

417417 write $ byteString bs

418418 atomically $ modifyTVar countVar (+ 1)

419419 loop

420− loop

420+ loop

421421 withApp defaultSettings app $ \port -> do

422422 (sock, _addr) <- getSocketTCP "127.0.0.1" port

423423 sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"

warp/warp.cabal+40−28

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

11Name: warp

2−Version: 3.2.27

2+Version: 3.2.28

33Synopsis: A fast, light-weight web server for WAI applications.

44License: MIT

55License-file: LICENSE

@@ -8,7 +8,7 @@ Maintainer: michael@snoyman.com

88Homepage: http://github.com/yesodweb/wai

99Category: Web, Yesod

1010Build-Type: Simple

11−Cabal-Version: >=1.8

11+Cabal-Version: >= 1.10

1212Stability: Stable

1313description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported.

1414 For HTTP\/2, Warp supports direct and ALPN (in TLS)

@@ -42,19 +42,20 @@ Library

4242 , case-insensitive >= 0.2

4343 , containers

4444 , ghc-prim

45+ , hashable

46+ , http-date

4547 , http-types >= 0.11

46− , iproute >= 1.3.1

4748 , http2 >= 1.6 && < 1.7

49+ , iproute >= 1.3.1

4850 , simple-sendfile >= 0.2.7 && < 0.3

49− , unix-compat >= 0.2

50− , wai >= 3.2 && < 3.3

51− , text

51+ , stm >= 2.3

5252 , streaming-commons >= 0.1.10

53+ , text

54+ , time-manager

55+ , unix-compat >= 0.2

5356 , vault >= 0.3

54− , stm >= 2.3

57+ , wai >= 3.2 && < 3.3

5558 , word8

56− , hashable

57− , http-date

5859 if impl(ghc < 8)

5960 Build-Depends: semigroups

6061 if flag(network-bytestring)

@@ -95,7 +96,6 @@ Library

9596 Network.Wai.Handler.Warp.Run

9697 Network.Wai.Handler.Warp.SendFile

9798 Network.Wai.Handler.Warp.Settings

98− Network.Wai.Handler.Warp.Timeout

9999 Network.Wai.Handler.Warp.Types

100100 Network.Wai.Handler.Warp.Windows

101101 Network.Wai.Handler.Warp.WithApplication

@@ -112,6 +112,9 @@ Library

112112 else

113113 Build-Depends: unix

114114 Other-modules: Network.Wai.Handler.Warp.MultiMap

115+ if impl(ghc >= 8)

116+ Default-Extensions: Strict StrictData

117+ Default-Language: Haskell2010

115118

116119Test-Suite doctest

117120 Type: exitcode-stdio-1.0

@@ -122,6 +125,9 @@ Test-Suite doctest

122125 , doctest >= 0.10.1

123126 if os(windows)

124127 Buildable: False

128+ if impl(ghc >= 8)

129+ Default-Extensions: Strict StrictData

130+ Default-Language: Haskell2010

125131

126132Test-Suite spec

127133 Main-Is: Spec.hs

@@ -171,7 +177,6 @@ Test-Suite spec

171177 Network.Wai.Handler.Warp.Run

172178 Network.Wai.Handler.Warp.SendFile

173179 Network.Wai.Handler.Warp.Settings

174− Network.Wai.Handler.Warp.Timeout

175180 Network.Wai.Handler.Warp.Types

176181 Network.Wai.Handler.Warp.Windows

177182 Network.Wai.Handler.Warp.WithApplication

@@ -182,37 +187,38 @@ Test-Suite spec

182187

183188 Ghc-Options: -Wall -threaded

184189 Build-Depends: base >= 4.8 && < 5

190+ , HUnit

191+ , QuickCheck

185192 , array

193+ , async

186194 , auto-update

187195 , bsb-http-chunked < 0.1

188196 , bytestring >= 0.9.1.4

189197 , case-insensitive >= 0.2

198+ , containers

199+ , directory

190200 , ghc-prim

201+ , hashable

202+ , hspec >= 1.3

191203 , http-client

204+ , http-date

192205 , http-types >= 0.8.5

206+ , http2 >= 1.6 && < 1.7

193207 , iproute >= 1.3.1

194208 , lifted-base >= 0.1

209+ , network

210+ , process

195211 , simple-sendfile >= 0.2.4 && < 0.3

212+ , stm >= 2.3

213+ , streaming-commons >= 0.1.10

214+ , text

215+ , time

216+ , time-manager

196217 , transformers >= 0.2.2

197218 , unix-compat >= 0.2

198− , wai >= 3.2 && < 3.3

199− , network

200− , HUnit

201− , QuickCheck

202− , hspec >= 1.3

203− , time

204− , text

205− , streaming-commons >= 0.1.10

206− , async

207219 , vault

208− , stm >= 2.3

209− , directory

210− , process

211− , containers

212− , http2 >= 1.6 && < 1.7

220+ , wai >= 3.2 && < 3.3

213221 , word8

214− , hashable

215− , http-date

216222 -- Build-Tool-Depends: hspec-discover:hspec-discover

217223 if impl(ghc < 8)

218224 Build-Depends: semigroups

@@ -223,6 +229,9 @@ Test-Suite spec

223229 if os(windows)

224230 Cpp-Options: -DWINDOWS

225231 Build-Depends: time

232+ if impl(ghc >= 8)

233+ Default-Extensions: Strict StrictData

234+ Default-Language: Haskell2010

226235

227236Benchmark parser

228237 Type: exitcode-stdio-1.0

@@ -233,7 +242,6 @@ Benchmark parser

233242 Network.Wai.Handler.Warp.HashMap

234243 Network.Wai.Handler.Warp.Imports

235244 Network.Wai.Handler.Warp.MultiMap

236− Network.Wai.Handler.Warp.Timeout

237245 Network.Wai.Handler.Warp.Types

238246 HS-Source-Dirs: bench .

239247 Build-Depends: base >= 4.8 && < 5

@@ -246,6 +254,7 @@ Benchmark parser

246254 , http-types

247255 , network

248256 , network

257+ , time-manager

249258 , unix-compat

250259 if impl(ghc < 8)

251260 Build-Depends: semigroups

@@ -256,6 +265,9 @@ Benchmark parser

256265 if os(windows)

257266 Cpp-Options: -DWINDOWS

258267 Build-Depends: time

268+ if impl(ghc >= 8)

269+ Default-Extensions: Strict StrictData

270+ Default-Language: Haskell2010

259271

260272Source-Repository head

261273 Type: git