git.iko.soy/typeable/wai
on master help sign in
setting limitation to the referer: cache.
commit4bdf8afabcc87abfb3b1b3912f81d44441b03837 authorKazu Yamamoto <kazu@iij.ad.jp> dateThu 21 Jul 2016, 14:35 (10 years ago) parent0edb0e5
3 files changed+50−18
compare with master
unifiedsplit
wai-http2-extra/Network/Wai/Middleware/Push/Referer.hs+9−18 wai-http2-extra/Network/Wai/Middleware/Push/Referer/LimitMultiMap.hs+40 wai-http2-extra/wai-http2-extra.cabal+1
wai-http2-extra/Network/Wai/Middleware/Push/Referer.hs+9−18
@@ -13,11 +13,7 @@ import Control.Reaper
1313import Data.ByteString (ByteString)
1414import qualified Data.ByteString as BS
1515import Data.ByteString.Internal (ByteString(..), memchr)
16−import Data.Map (Map)
17−import qualified Data.Map.Strict as M
1816import Data.Maybe (isNothing)
19−import Data.Set (Set)
20−import qualified Data.Set as S
2117import Data.Word (Word8)
2218import Data.Word8
2319import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
@@ -29,6 +25,8 @@ import Network.Wai.Handler.Warp
2925import Network.Wai.Internal (Response(..))
3026import System.IO.Unsafe (unsafePerformIO)
3127
28+import qualified Network.Wai.Middleware.Push.Referer.LimitMultiMap as M
29+
3230-- $setup
3331-- >>> :set -XOverloadedStrings
3432
@@ -47,10 +45,10 @@ type MakePushPromise = URLPath -- ^ path in referer
4745-- | Type for URL path.
4846type URLPath = ByteString
4947
50−type Cache = Map URLPath (Set PushPromise)
48+type Cache = M.LimitMultiMap URLPath PushPromise
5149
5250emptyCache :: Cache
53−emptyCache = M.empty
51+emptyCache = M.empty 20 20 -- FIXME hard-coding
5452
5553cacheReaper :: Reaper Cache (URLPath,PushPromise)
5654cacheReaper = unsafePerformIO $ mkReaper settings
@@ -59,18 +57,12 @@ cacheReaper = unsafePerformIO $ mkReaper settings
5957settings :: ReaperSettings Cache (URLPath,PushPromise)
6058settings = defaultReaperSettings {
6159 reaperAction = \_ -> return (\_ -> emptyCache)
62− , reaperCons = insert
63− , reaperNull = M.null
60+ , reaperCons = M.insert
61+ , reaperNull = M.isEmpty
6462 , reaperEmpty = emptyCache
6563-- , reaperDelay = 30000000 -- FIXME hard-coding
6664 }
6765
68−insert :: (URLPath,PushPromise) -> Cache -> Cache
69−insert (path,pp) m = M.alter ins path m
70− where
71− ins Nothing = Just $ S.singleton pp
72− ins (Just set) = Just $ S.insert pp set
73−
7466-- | The middleware to push files based on Referer:.
7567-- Learning strategy is implemented in the first argument.
7668-- Learning information is kept for 30 seconds.
@@ -81,7 +73,7 @@ pushOnReferer func app req sendResponse = app req push
8173 let !path = rawPathInfo req
8274 m <- reaperRead cacheReaper
8375 case M.lookup path m of
84− Nothing -> case requestHeaderReferer req of
76+ [] -> case requestHeaderReferer req of
8577 Nothing -> return ()
8678 Just referer -> do
8779 (mauth,refPath) <- parseUrl referer
@@ -92,9 +84,8 @@ pushOnReferer func app req sendResponse = app req push
9284 case mpp of
9385 Nothing -> return ()
9486 Just pp -> reaperAdd cacheReaper (refPath,pp)
95− Just pset -> do
96− let !ps = S.toList pset
97− !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
87+ ps -> do
88+ let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
9889 setHTTP2Data req (Just h2d)
9990 sendResponse res
10091 push res = sendResponse res
wai-http2-extra/Network/Wai/Middleware/Push/Referer/LimitMultiMap.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE BangPatterns #-}
2+
3+module Network.Wai.Middleware.Push.Referer.LimitMultiMap where
4+
5+import Data.Map (Map)
6+import qualified Data.Map.Strict as M
7+import Data.Set (Set)
8+import qualified Data.Set as S
9+
10+data LimitMultiMap k v = LimitMultiMap {
11+ limitKey :: !Int
12+ , limitVal :: !Int
13+ , multiMap :: !(Map k (Set v))
14+ } deriving (Eq, Show)
15+
16+isEmpty :: LimitMultiMap k t -> Bool
17+isEmpty (LimitMultiMap _ _ m) = M.null m
18+
19+empty :: Int -> Int -> LimitMultiMap k v
20+empty lk lv = LimitMultiMap lk lv M.empty
21+
22+insert :: (Ord k, Ord v) => (k,v) -> LimitMultiMap k v -> LimitMultiMap k v
23+insert (k,v) (LimitMultiMap lk lv m)
24+ | siz < lk = let !m' = M.alter alt k m in LimitMultiMap lk lv m'
25+ | siz == lk = let !m' = M.adjust adj k m in LimitMultiMap lk lv m'
26+ | otherwise = error "insert"
27+ where
28+ siz = M.size m
29+ alt Nothing = Just $ S.singleton v
30+ alt s@(Just set)
31+ | S.size set == lv = s
32+ | otherwise = Just $ S.insert v set
33+ adj set
34+ | S.size set == lv = set
35+ | otherwise = S.insert v set
36+
37+lookup :: Ord k => k -> LimitMultiMap k v -> [v]
38+lookup k (LimitMultiMap _ _ m) = case M.lookup k m of
39+ Nothing -> []
40+ Just set -> S.toList set
wai-http2-extra/wai-http2-extra.cabal+1
@@ -22,6 +22,7 @@ Library
2222 , warp
2323 , word8
2424 Exposed-modules: Network.Wai.Middleware.Push.Referer
25+ Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap
2526 Ghc-Options: -Wall
2627
2728Test-Suite doctest