@@ -1,18 +1,28 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1+{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}
22
33-- | Middleware for server push learning dependency based on Referer:.
44module Network.Wai.Middleware.Push.Referer (
5+ -- * Middleware
56 pushOnReferer
7+ -- * Making push promise
8+ , URLPath
69 , MakePushPromise
710 , defaultMakePushPromise
8− , URLPath
11+ -- * Settings
12+ , Settings
13+ , defaultSettings
14+ , makePushPromise
15+ , duration
16+ , keyLimit
17+ , valueLimit
918 ) where
1019
11−import Control.Monad (when)
20+import Control.Monad (when, unless)
1221import Control.Reaper
1322import Data.ByteString (ByteString)
1423import qualified Data.ByteString as BS
1524import Data.ByteString.Internal (ByteString(..), memchr)
25+import Data.IORef
1626import Data.Maybe (isNothing)
1727import Data.Word (Word8)
1828import Data.Word8
@@ -21,7 +31,7 @@ import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
2131import Foreign.Storable (peek)
2232import Network.HTTP.Types (Status(..))
2333import Network.Wai
24−import Network.Wai.Handler.Warp
34+import Network.Wai.Handler.Warp hiding (Settings, defaultSettings)
2535import Network.Wai.Internal (Response(..))
2636import System.IO.Unsafe (unsafePerformIO)
2737
@@ -47,36 +57,61 @@ type URLPath = ByteString
4757
4858type Cache = M.LimitMultiMap URLPath PushPromise
4959
50−emptyCache :: Cache
51−emptyCache = M.empty 20 20 -- FIXME hard-coding
60+initialized :: IORef Bool
61+initialized = unsafePerformIO $ newIORef False
62+{-# NOINLINE initialized #-}
5263
53−cacheReaper :: Reaper Cache (URLPath,PushPromise)
54−cacheReaper = unsafePerformIO $ mkReaper settings
64+cacheReaper :: IORef (Maybe (Reaper Cache (URLPath,PushPromise)))
65+cacheReaper = unsafePerformIO $ newIORef Nothing
5566{-# NOINLINE cacheReaper #-}
5667
57−settings :: ReaperSettings Cache (URLPath,PushPromise)
58−settings = defaultReaperSettings {
59− reaperAction = \_ -> return (\_ -> emptyCache)
60− , reaperCons = M.insert
61− , reaperNull = M.isEmpty
62− , reaperEmpty = emptyCache
63−-- , reaperDelay = 30000000 -- FIXME hard-coding
64− }
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
93+ settings :: ReaperSettings Cache (URLPath,PushPromise)
94+ settings = defaultReaperSettings {
95+ reaperAction = \_ -> return (\_ -> emptyCache)
96+ , reaperCons = M.insert
97+ , reaperNull = M.isEmpty
98+ , reaperEmpty = emptyCache
99+ , reaperDelay = duration
100+ }
65101
66102-- | The middleware to push files based on Referer:.
67103-- 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
75−pushOnReferer func app req sendResponse = app req push
104+pushOnReferer :: Settings -> Middleware
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)
76111 where
77− push res@(ResponseFile (Status 200 "OK") _ file Nothing) = do
112+ push reaper res@(ResponseFile (Status 200 "OK") _ file Nothing) = do
78113 let !path = rawPathInfo req
79− m <- reaperRead cacheReaper
114+ m <- reaperRead reaper
80115 case M.lookup path m of
81116 [] -> case requestHeaderReferer req of
82117 Nothing -> return ()
@@ -85,15 +120,15 @@ pushOnReferer func app req sendResponse = app req push
85120 when (isNothing mauth
86121 || requestHeaderHost req == mauth) $ do
87122 when (path /= refPath) $ do -- just in case
88− mpp <- func refPath path file
123+ mpp <- makePushPromise refPath path file
89124 case mpp of
90125 Nothing -> return ()
91− Just pp -> reaperAdd cacheReaper (refPath,pp)
126+ Just pp -> reaperAdd reaper (refPath,pp)
92127 ps -> do
93128 let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}
94129 setHTTP2Data req (Just h2d)
95130 sendResponse res
96− push res = sendResponse res
131+ push _ res = sendResponse res
97132
98133
99134-- | 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
197232 !off = p1 `minusPtr` p0
198233 !siz = p2 `minusPtr` p1
199234 !path = PS fptr0 off siz
200−