wai-http2-extra 0.0.1 → 0.0.2

raw patch · 3 files changed

+72/−33 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Network/Wai/Middleware/Push/Referer.hs +30/−32
• Network/Wai/Middleware/Push/Referer/LimitMultiMap.hs +40/−0
• wai-http2-extra.cabal +2/−1

@@ -13,11 +13,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..), memchr)-import Data.Map (Map)-import qualified Data.Map.Strict as M import Data.Maybe (isNothing)-import Data.Set (Set)-import qualified Data.Set as S import Data.Word (Word8) import Data.Word8 import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)@@ -29,6 +25,8 @@ import Network.Wai.Internal (Response(..)) import System.IO.Unsafe (unsafePerformIO) +import qualified Network.Wai.Middleware.Push.Referer.LimitMultiMap as M+ -- $setup -- >>> :set -XOverloadedStrings @@ -39,18 +37,18 @@ --   this function should return 'Just'. --   If 'Nothing' is returned, --   the middleware learns nothing.-type MakePushPromise = URLPath  -- ^ path in referer-                    -> URLPath  -- ^ path to be pushed-                    -> FilePath -- ^ file to be pushed+type MakePushPromise = URLPath  -- ^ path in referer  (key: /index.html)+                    -> URLPath  -- ^ path to be pushed (value: /style.css)+                    -> FilePath -- ^ file to be pushed (file_path/style.css)                     -> IO (Maybe PushPromise)  -- | Type for URL path. type URLPath = ByteString -type Cache = Map URLPath (Set PushPromise)+type Cache = M.LimitMultiMap URLPath PushPromise  emptyCache :: Cache-emptyCache = M.empty+emptyCache = M.empty 20 20 -- FIXME hard-coding  cacheReaper :: Reaper Cache (URLPath,PushPromise) cacheReaper = unsafePerformIO $ mkReaper settings@@ -59,30 +57,30 @@ settings :: ReaperSettings Cache (URLPath,PushPromise) settings = defaultReaperSettings {       reaperAction = \_ -> return (\_ -> emptyCache)-    , reaperCons   = insert-    , reaperNull   = M.null+    , reaperCons   = M.insert+    , reaperNull   = M.isEmpty     , reaperEmpty  = emptyCache --  , reaperDelay  = 30000000 -- FIXME hard-coding     } -insert :: (URLPath,PushPromise) -> Cache -> Cache-insert (path,pp) m = M.alter ins path m-  where-    ins Nothing    = Just $ S.singleton pp-    ins (Just set) = Just $ S.insert pp set- -- | The middleware to push files based on Referer:. --   Learning strategy is implemented in the first argument.---   Learning information is kept for 30 seconds.+--+--   Cache of learning information is kept for 30 seconds+--   and cleared completely.+--   Max number of keys (e.g. index.html) is 20.+--   Max number of values (e.g. style.css) for each key is 20.+--   These numbers are hard-coded at this moment. pushOnReferer :: MakePushPromise -> Middleware-pushOnReferer func app req sendResponse = app req $ \res -> do-    let !path = rawPathInfo req-    m <- reaperRead cacheReaper-    case M.lookup path m of-        Nothing -> case requestHeaderReferer req of-            Nothing      -> return ()-            Just referer -> case res of-                ResponseFile (Status 200 "OK") _ file Nothing -> do+pushOnReferer func app req sendResponse = app req push+  where+    push res@(ResponseFile (Status 200 "OK") _ file Nothing) = do+        let !path = rawPathInfo req+        m <- reaperRead cacheReaper+        case M.lookup path m of+            [] -> case requestHeaderReferer req of+                Nothing      -> return ()+                Just referer -> do                     (mauth,refPath) <- parseUrl referer                     when (isNothing mauth                        || requestHeaderHost req == mauth) $ do@@ -91,12 +89,12 @@                             case mpp of                                 Nothing -> return ()                                 Just pp -> reaperAdd cacheReaper (refPath,pp)-                _ -> return ()-        Just pset -> do-            let !ps = S.toList pset-                !h2d = defaultHTTP2Data { http2dataPushPromise = ps}-            setHTTP2Data req (Just h2d)-    sendResponse res+            ps -> do+                let !h2d = defaultHTTP2Data { http2dataPushPromise = ps}+                setHTTP2Data req (Just h2d)+        sendResponse res+    push res = sendResponse res+  -- | Learn if the file to be pushed is CSS (.css) or JavaScript (.js) file --   AND the Referer: ends with \"/\" or \".html\" or \".htm\".

@@ -0,0 +1,40 @@+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Middleware.Push.Referer.LimitMultiMap where++import Data.Map (Map)+import qualified Data.Map.Strict as M+import Data.Set (Set)+import qualified Data.Set as S++data LimitMultiMap k v = LimitMultiMap {+      limitKey :: !Int+    , limitVal :: !Int+    , multiMap :: !(Map k (Set v))+    } deriving (Eq, Show)++isEmpty :: LimitMultiMap k t -> Bool+isEmpty (LimitMultiMap _ _ m) = M.null m++empty :: Int -> Int -> LimitMultiMap k v+empty lk lv = LimitMultiMap lk lv M.empty++insert :: (Ord k, Ord v) => (k,v) -> LimitMultiMap k v -> LimitMultiMap k v+insert (k,v) (LimitMultiMap lk lv m)+  | siz <  lk = let !m' = M.alter  alt k m in LimitMultiMap lk lv m'+  | siz == lk = let !m' = M.adjust adj k m in LimitMultiMap lk lv m'+  | otherwise = error "insert"+  where+    siz = M.size m+    alt Nothing          = Just $ S.singleton v+    alt s@(Just set)+      | S.size set == lv = s+      | otherwise        = Just $ S.insert v set+    adj set+      | S.size set == lv = set+      | otherwise        = S.insert v set++lookup :: Ord k => k -> LimitMultiMap k v -> [v]+lookup k (LimitMultiMap _ _ m) = case M.lookup k m of+  Nothing  -> []+  Just set -> S.toList set

@@ -1,5 +1,5 @@ Name:                wai-http2-extra-Version:             0.0.1+Version:             0.0.2 Synopsis:            WAI utilities for HTTP/2 License:             MIT License-file:        LICENSE@@ -22,6 +22,7 @@                    , warp                    , word8   Exposed-modules:   Network.Wai.Middleware.Push.Referer+  Other-modules:     Network.Wai.Middleware.Push.Referer.LimitMultiMap   Ghc-Options:       -Wall  Test-Suite doctest