git.iko.soy/typeable/wai
on master help sign in
Merge branch of first step for HTTP/2 server library.
commit1481ffb5ed9f6d288519576113601643bbcee510 authorKazu Yamamoto <kazu@iij.ad.jp> dateWed 5 Jun 2019, 16:16 (7 years ago) parent56831951b0944b
13 files changed+161−189
compare with master
unifiedsplit
warp/Network/Wai/Handler/Warp/FdCache.hs+18−22 warp/Network/Wai/Handler/Warp/FileInfoCache.hs+18−21 warp/Network/Wai/Handler/Warp/HTTP2.hs+4−4 warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hs+4−4 warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+4−8 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+5−6 warp/Network/Wai/Handler/Warp/HashMap.hs+24−15 warp/Network/Wai/Handler/Warp/MultiMap.hs+55−44 warp/Network/Wai/Handler/Warp/Request.hs+5−9 warp/Network/Wai/Handler/Warp/Response.hs+2−2 warp/Network/Wai/Handler/Warp/Run.hs+20−23 warp/Network/Wai/Handler/Warp/Types.hs+1−30 warp/test/FdCacheSpec.hs+1−1
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+18−21
@@ -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 =
@@ -99,8 +96,8 @@ initialize duration = mkReaper settings
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/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/Worker.hs+5−6
@@ -44,6 +44,7 @@ import Network.Wai.Handler.Warp.Types
4444-- This type implements the second argument (Response -> IO ResponseReceived)
4545-- with extra arguments.
4646type Responder = InternalInfo
47+ -> T.Handle
4748 -> ValueTable -- for Request
4849 -> ThreadContinue
4950 -> Stream
@@ -118,7 +119,7 @@ pushStream ctx@Context{http2settings,outputQ,streamTable}
118119-- They also pass 'Response's from 'Application's to this function.
119120-- This function enqueues commands for the HTTP/2 sender.
120121response :: S.Settings -> Context -> Manager -> Responder
121−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
122123 ResponseStream s0 hs0 strmbdy
123124 | noBody s0 -> responseNoBody s0 hs0
124125 | isHead -> responseNoBody s0 hs0
@@ -141,7 +142,6 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = E.handl
141142 noBody = not . R.hasBody
142143 !isHead = requestMethod req == H.methodHead
143144 !logger = S.settingsLogger settings
144− !th = threadHandle ii
145145 sid = streamNumber strm
146146 !h2data = getHTTP2Data req
147147
@@ -245,8 +245,7 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do
245245 setStreamInfo sinfo inp
246246 T.resume th
247247 T.tickle th
248− let !ii' = ii { threadHandle = th }
249− !body = getRequestBodyChunk req
248+ let !body = getRequestBodyChunk req
250249 !body' = do
251250 T.pause th
252251 bs <- body
@@ -254,12 +253,12 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do
254253 return bs
255254 !vaultValue = Vault.insert pauseTimeoutKey (T.pause th) $ vault req
256255 !req' = req { vault = vaultValue, requestBody = body' }
257− mr <- E.try $ app req' $ responder ii' reqvt tcont strm req'
256+ mr <- E.try $ app req' $ responder ii th reqvt tcont strm req'
258257 case mr of
259258 Right ok -> return ok
260259 Left e@(SomeException _)
261260 | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e'
262− | otherwise -> responder ii' reqvt tcont strm req' (S.settingsOnExceptionResponse set e)
261+ | otherwise -> responder ii th reqvt tcont strm req' (S.settingsOnExceptionResponse set e)
263262 cont1 <- case ex of
264263 Right ResponseReceived -> return True
265264 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/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+5−9
@@ -32,7 +32,6 @@ 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+2−2
@@ -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+20−23
@@ -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/Types.hs+1−30
@@ -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