git.iko.soy/typeable/wai
on master help sign in
settings for server push middleware with singleton pattern.
63edd4bKazu Yamamoto
wai-http2-extra/Network/Wai/Middleware/Push/Referer.hs+64−30
compare with master
unifiedsplit
@@ -1,18 +1,28 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1+{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}
2
2
3-- | Middleware for server push learning dependency based on Referer:.
3-- | Middleware for server push learning dependency based on Referer:.
4module Network.Wai.Middleware.Push.Referer (
4module Network.Wai.Middleware.Push.Referer (
5+ -- * Middleware
5 pushOnReferer
6 pushOnReferer
7+ -- * Making push promise
8+ , URLPath
6 , MakePushPromise
9 , MakePushPromise
7 , defaultMakePushPromise
10 , defaultMakePushPromise
8− , URLPath
11+ -- * Settings
12+ , Settings
13+ , defaultSettings
14+ , makePushPromise
15+ , duration
16+ , keyLimit
17+ , valueLimit
9 ) where
18 ) where
10
19
11−import Control.Monad (when)
20+import Control.Monad (when, unless)
12import Control.Reaper
21import Control.Reaper
13import Data.ByteString (ByteString)
22import Data.ByteString (ByteString)
14import qualified Data.ByteString as BS
23import qualified Data.ByteString as BS
15import Data.ByteString.Internal (ByteString(..), memchr)
24import Data.ByteString.Internal (ByteString(..), memchr)
25+import Data.IORef
16import Data.Maybe (isNothing)
26import Data.Maybe (isNothing)
17import Data.Word (Word8)
27import Data.Word (Word8)
18import Data.Word8
28import Data.Word8
@@ -21,7 +31,7 @@ import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
21import Foreign.Storable (peek)
31import Foreign.Storable (peek)
22import Network.HTTP.Types (Status(..))
32import Network.HTTP.Types (Status(..))
23import Network.Wai
33import Network.Wai
24−import Network.Wai.Handler.Warp
34+import Network.Wai.Handler.Warp hiding (Settings, defaultSettings)
25import Network.Wai.Internal (Response(..))
35import Network.Wai.Internal (Response(..))
26import System.IO.Unsafe (unsafePerformIO)
36import System.IO.Unsafe (unsafePerformIO)
27
37
@@ -47,36 +57,61 @@ type URLPath = ByteString
47
57
48type Cache = M.LimitMultiMap URLPath PushPromise
58type Cache = M.LimitMultiMap URLPath PushPromise
49
59
50−emptyCache :: Cache
60+initialized :: IORef Bool
51−emptyCache = M.empty 20 20 -- FIXME hard-coding
61+initialized = unsafePerformIO $ newIORef False
62+{-# NOINLINE initialized #-}
52
63
53−cacheReaper :: Reaper Cache (URLPath,PushPromise)
64+cacheReaper :: IORef (Maybe (Reaper Cache (URLPath,PushPromise)))
54−cacheReaper = unsafePerformIO $ mkReaper settings
65+cacheReaper = unsafePerformIO $ newIORef Nothing
55{-# NOINLINE cacheReaper #-}
66{-# NOINLINE cacheReaper #-}
56
67
68+-- | Settings for server push based on Referer:.
69+data Settings = Settings {
70+ makePushPromise :: MakePushPromise -- ^ Default: 'defaultMakePushPromise'
71+ , duration :: Int -- ^ Duration (in micro seconds) to keep the learning information. The information completely cleared every this duration. Default: 30000000
72+ , keyLimit :: Int -- ^ Max number of keys (e.g. index.html) in the learning information. Default: 20
73+ , valueLimit :: Int -- ^ Max number of values (e.g. style.css) in the learning information. Default: 20
74+ }
75+
76+-- | Default settings.
77+defaultSettings :: Settings
78+defaultSettings = Settings {
79+ makePushPromise = defaultMakePushPromise
80+ , duration = 30000000
81+ , keyLimit = 20
82+ , valueLimit = 20
83+ }
84+
85+tryInitialize :: Settings -> IO ()
86+tryInitialize Settings{..} = do
87+ isInitialized <- atomicModifyIORef' initialized $ \x -> (True, x)
88+ unless isInitialized $ do
89+ reaper <- mkReaper settings
90+ writeIORef cacheReaper (Just reaper)
91+ where
92+ emptyCache = M.empty keyLimit valueLimit
57−settings :: ReaperSettings Cache (URLPath,PushPromise)
93+ settings :: ReaperSettings Cache (URLPath,PushPromise)
58−settings = defaultReaperSettings {
94+ settings = defaultReaperSettings {
59− reaperAction = \_ -> return (\_ -> emptyCache)
95+ reaperAction = \_ -> return (\_ -> emptyCache)
60− , reaperCons = M.insert
96+ , reaperCons = M.insert
61− , reaperNull = M.isEmpty
97+ , reaperNull = M.isEmpty
62− , reaperEmpty = emptyCache
98+ , reaperEmpty = emptyCache
63−-- , reaperDelay = 30000000 -- FIXME hard-coding
99+ , reaperDelay = duration
64− }
100+ }
65
101
66-- | The middleware to push files based on Referer:.
102-- | The middleware to push files based on Referer:.
67-- Learning strategy is implemented in the first argument.
103-- Learning strategy is implemented in the first argument.
68−--
69−-- Cache of learning information is kept for 30 seconds
70−-- and cleared completely.
71−-- Max number of keys (e.g. index.html) is 20.
72−-- Max number of values (e.g. style.css) for each key is 20.
73−-- These numbers are hard-coded at this moment.
74−pushOnReferer :: MakePushPromise -> Middleware
104+pushOnReferer :: Settings -> Middleware
75−pushOnReferer func app req sendResponse = app req push
105+pushOnReferer settings@Settings{..} app req sendResponse = do
106+ tryInitialize settings
107+ mreaper <- readIORef cacheReaper
108+ case mreaper of
109+ Nothing -> app req sendResponse
110+ Just reaper -> app req (push reaper)
76 where
111 where
77− push res@(ResponseFile (Status 200 "OK") _ file Nothing) = do
112+ push reaper res@(ResponseFile (Status 200 "OK") _ file Nothing) = do
78 let !path = rawPathInfo req
113 let !path = rawPathInfo req
79− m <- reaperRead cacheReaper
114+ m <- reaperRead reaper
80 case M.lookup path m of
115 case M.lookup path m of
81 [] -> case requestHeaderReferer req of
116 [] -> case requestHeaderReferer req of
82 Nothing -> return ()
117 Nothing -> return ()
@@ -85,15 +120,15 @@ pushOnReferer func app req sendResponse = app req push
85 when (isNothing mauth
120 when (isNothing mauth
86 || requestHeaderHost req == mauth) $ do
121 || requestHeaderHost req == mauth) $ do
87 when (path /= refPath) $ do -- just in case
122 when (path /= refPath) $ do -- just in case
88− mpp <- func refPath path file
123+ mpp <- makePushPromise refPath path file
89 case mpp of
124 case mpp of
90 Nothing -> return ()
125 Nothing -> return ()
91− Just pp -> reaperAdd cacheReaper (refPath,pp)
126+ Just pp -> reaperAdd reaper (refPath,pp)
92 ps -> do
127 ps -> do
93 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
128 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
94 setHTTP2Data req (Just h2d)
129 setHTTP2Data req (Just h2d)
95 sendResponse res
130 sendResponse res
96− push res = sendResponse res
131+ push _ res = sendResponse res
97
132
98
133
99-- | Learn if the file to be pushed is CSS (.css) or JavaScript (.js) file
134-- | Learn if the file to be pushed is CSS (.css) or JavaScript (.js) file
@@ -197,4 +232,3 @@ parseUrl' fptr0 ptr0 begptr limptr len0 = do
197 !off = p1 `minusPtr` p0
232 !off = p1 `minusPtr` p0
198 !siz = p2 `minusPtr` p1
233 !siz = p2 `minusPtr` p1
199 !path = PS fptr0 off siz
234 !path = PS fptr0 off siz
200−