git.iko.soy/typeable/wai
on master help sign in
setting limitation to the referer: cache.
4bdf8afKazu Yamamoto
wai-http2-extra/Network/Wai/Middleware/Push/Referer.hs+9−18
compare with master
unifiedsplit
@@ -13,11 +13,7 @@ import Control.Reaper
13import Data.ByteString (ByteString)
13import Data.ByteString (ByteString)
14import qualified Data.ByteString as BS
14import qualified Data.ByteString as BS
15import Data.ByteString.Internal (ByteString(..), memchr)
15import Data.ByteString.Internal (ByteString(..), memchr)
16−import Data.Map (Map)
17−import qualified Data.Map.Strict as M
18import Data.Maybe (isNothing)
16import Data.Maybe (isNothing)
19−import Data.Set (Set)
20−import qualified Data.Set as S
21import Data.Word (Word8)
17import Data.Word (Word8)
22import Data.Word8
18import Data.Word8
23import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
19import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
@@ -29,6 +25,8 @@ import Network.Wai.Handler.Warp
29import Network.Wai.Internal (Response(..))
25import Network.Wai.Internal (Response(..))
30import System.IO.Unsafe (unsafePerformIO)
26import System.IO.Unsafe (unsafePerformIO)
31
27
28+import qualified Network.Wai.Middleware.Push.Referer.LimitMultiMap as M
29+
32-- $setup
30-- $setup
33-- >>> :set -XOverloadedStrings
31-- >>> :set -XOverloadedStrings
34
32
@@ -47,10 +45,10 @@ type MakePushPromise = URLPath -- ^ path in referer
47-- | Type for URL path.
45-- | Type for URL path.
48type URLPath = ByteString
46type URLPath = ByteString
49
47
50−type Cache = Map URLPath (Set PushPromise)
48+type Cache = M.LimitMultiMap URLPath PushPromise
51
49
52emptyCache :: Cache
50emptyCache :: Cache
53−emptyCache = M.empty
51+emptyCache = M.empty 20 20 -- FIXME hard-coding
54
52
55cacheReaper :: Reaper Cache (URLPath,PushPromise)
53cacheReaper :: Reaper Cache (URLPath,PushPromise)
56cacheReaper = unsafePerformIO $ mkReaper settings
54cacheReaper = unsafePerformIO $ mkReaper settings
@@ -59,18 +57,12 @@ cacheReaper = unsafePerformIO $ mkReaper settings
59settings :: ReaperSettings Cache (URLPath,PushPromise)
57settings :: ReaperSettings Cache (URLPath,PushPromise)
60settings = defaultReaperSettings {
58settings = defaultReaperSettings {
61 reaperAction = \_ -> return (\_ -> emptyCache)
59 reaperAction = \_ -> return (\_ -> emptyCache)
62− , reaperCons = insert
60+ , reaperCons = M.insert
63− , reaperNull = M.null
61+ , reaperNull = M.isEmpty
64 , reaperEmpty = emptyCache
62 , reaperEmpty = emptyCache
65-- , reaperDelay = 30000000 -- FIXME hard-coding
63-- , reaperDelay = 30000000 -- FIXME hard-coding
66 }
64 }
67
65
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−
74-- | The middleware to push files based on Referer:.
66-- | The middleware to push files based on Referer:.
75-- Learning strategy is implemented in the first argument.
67-- Learning strategy is implemented in the first argument.
76-- Learning information is kept for 30 seconds.
68-- Learning information is kept for 30 seconds.
@@ -81,7 +73,7 @@ pushOnReferer func app req sendResponse = app req push
81 let !path = rawPathInfo req
73 let !path = rawPathInfo req
82 m <- reaperRead cacheReaper
74 m <- reaperRead cacheReaper
83 case M.lookup path m of
75 case M.lookup path m of
84− Nothing -> case requestHeaderReferer req of
76+ [] -> case requestHeaderReferer req of
85 Nothing -> return ()
77 Nothing -> return ()
86 Just referer -> do
78 Just referer -> do
87 (mauth,refPath) <- parseUrl referer
79 (mauth,refPath) <- parseUrl referer
@@ -92,9 +84,8 @@ pushOnReferer func app req sendResponse = app req push
92 case mpp of
84 case mpp of
93 Nothing -> return ()
85 Nothing -> return ()
94 Just pp -> reaperAdd cacheReaper (refPath,pp)
86 Just pp -> reaperAdd cacheReaper (refPath,pp)
95− Just pset -> do
87+ ps -> do
96− let !ps = S.toList pset
97− !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
88+ let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
98 setHTTP2Data req (Just h2d)
89 setHTTP2Data req (Just h2d)
99 sendResponse res
90 sendResponse res
100 push res = sendResponse res
91 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
22 , warp
22 , warp
23 , word8
23 , word8
24 Exposed-modules: Network.Wai.Middleware.Push.Referer
24 Exposed-modules: Network.Wai.Middleware.Push.Referer
25+ Other-modules: Network.Wai.Middleware.Push.Referer.LimitMultiMap
25 Ghc-Options: -Wall
26 Ghc-Options: -Wall
26
27
27Test-Suite doctest
28Test-Suite doctest