wai-http2-extra-0.1.3/0000755000000000000000000000000013663610537012653 5ustar0000000000000000wai-http2-extra-0.1.3/Setup.hs0000644000000000000000000000005613663610537014310 0ustar0000000000000000import Distribution.Simple main = defaultMain wai-http2-extra-0.1.3/LICENSE0000644000000000000000000000207313663610537013662 0ustar0000000000000000Copyright (c) 2016 Kazu Yamamoto, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. wai-http2-extra-0.1.3/wai-http2-extra.cabal0000644000000000000000000000316013663610537016577 0ustar0000000000000000Name: wai-http2-extra Version: 0.1.3 Synopsis: WAI utilities for HTTP/2 License: MIT License-file: LICENSE Author: Kazu Yamamoto Maintainer: kazu@iij.ad.jp Homepage: http://github.com/yesodweb/wai Category: Web Build-Type: Simple Cabal-Version: >=1.10 Stability: Stable Description: WAI utilities for HTTP/2 Library Build-Depends: base >= 3 && < 5 , bytestring , containers , http-types , psqueues , wai , warp , word8 Exposed-modules: Network.Wai.Middleware.Push.Referer Other-modules: Network.Wai.Middleware.Push.Referer.LRU Network.Wai.Middleware.Push.Referer.Manager Network.Wai.Middleware.Push.Referer.Multi Network.Wai.Middleware.Push.Referer.ParseURL Network.Wai.Middleware.Push.Referer.Types Ghc-Options: -Wall if impl(ghc >= 8) default-extensions: Strict StrictData default-language: Haskell2010 Test-Suite doctest Type: exitcode-stdio-1.0 HS-Source-Dirs: test Ghc-Options: -threaded -Wall Main-Is: doctests.hs Build-Depends: base , doctest >= 0.10.1 if impl(ghc >= 8) default-extensions: Strict StrictData default-language: Haskell2010 Source-Repository head Type: git Location: git://github.com/yesodweb/wai.git wai-http2-extra-0.1.3/test/0000755000000000000000000000000013663610537013632 5ustar0000000000000000wai-http2-extra-0.1.3/test/doctests.hs0000644000000000000000000000007613663610537016021 0ustar0000000000000000import Test.DocTest main :: IO () main = doctest ["Network"] wai-http2-extra-0.1.3/Network/0000755000000000000000000000000013663610537014304 5ustar0000000000000000wai-http2-extra-0.1.3/Network/Wai/0000755000000000000000000000000013663610537015024 5ustar0000000000000000wai-http2-extra-0.1.3/Network/Wai/Middleware/0000755000000000000000000000000013663610537017101 5ustar0000000000000000wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/0000755000000000000000000000000013663610537020020 5ustar0000000000000000wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/Referer.hs0000644000000000000000000000500613663610537021747 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | Middleware for server push learning dependency based on Referer:. module Network.Wai.Middleware.Push.Referer ( -- * Middleware pushOnReferer -- * Making push promise , URLPath , MakePushPromise , defaultMakePushPromise -- * Settings , Settings , M.defaultSettings , makePushPromise , duration , keyLimit , valueLimit ) where import Control.Monad (when) import qualified Data.ByteString as BS import Data.Maybe (isNothing) import Network.HTTP.Types (Status(..)) import Network.Wai import Network.Wai.Handler.Warp hiding (Settings, defaultSettings) import Network.Wai.Internal (Response(..)) import qualified Network.Wai.Middleware.Push.Referer.Manager as M import Network.Wai.Middleware.Push.Referer.ParseURL import Network.Wai.Middleware.Push.Referer.Types -- $setup -- >>> :set -XOverloadedStrings -- | The middleware to push files based on Referer:. -- Learning strategy is implemented in the first argument. pushOnReferer :: Settings -> Middleware pushOnReferer settings app req sendResponse = do mgr <- M.getManager settings app req $ push mgr where path = rawPathInfo req push mgr res@(ResponseFile (Status 200 "OK") _ file Nothing) -- file: /index.html -- path: / -- referer: -- refPath: | isHTML path = do xs <- M.lookup path mgr case xs of [] -> return () ps -> do let h2d = defaultHTTP2Data { http2dataPushPromise = ps } setHTTP2Data req $ Just h2d sendResponse res -- file: /style.css -- path: /style.css -- referer: /index.html -- refPath: / | otherwise = case requestHeaderReferer req of Nothing -> sendResponse res Just referer -> do (mauth,refPath) <- parseUrl referer when ((isNothing mauth || requestHeaderHost req == mauth) && path /= refPath && isHTML refPath) $ do let path' = BS.copy path refPath' = BS.copy refPath mpp <- makePushPromise settings refPath' path' file case mpp of Nothing -> return () Just pp -> M.insert refPath' pp mgr sendResponse res push _ res = sendResponse res isHTML :: URLPath -> Bool isHTML p = ("/" `BS.isSuffixOf` p) || (".html" `BS.isSuffixOf` p) || (".htm" `BS.isSuffixOf` p) wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/Referer/0000755000000000000000000000000013663610537021412 5ustar0000000000000000wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/Referer/LRU.hs0000644000000000000000000000413213663610537022410 0ustar0000000000000000-- from https://jaspervdj.be/posts/2015-02-24-lru-cache.html module Network.Wai.Middleware.Push.Referer.LRU ( Cache(..) , Priority , empty , insert , lookup ) where import Data.OrdPSQ (OrdPSQ) import qualified Data.OrdPSQ as PSQ import Data.Int (Int64) import Prelude hiding (lookup) import Network.Wai.Middleware.Push.Referer.Multi (Multi) import qualified Network.Wai.Middleware.Push.Referer.Multi as M type Priority = Int64 data Cache k v = Cache { cCapacity :: Int -- ^ The maximum number of elements in the queue , cSize :: Int -- ^ The current number of elements in the queue , cValLimit :: Int , cTick :: Priority -- ^ The next logical time , cQueue :: OrdPSQ k Priority (Multi v) } deriving (Eq, Show) empty :: Int -> Int -> Cache k v empty capacity valLimit | capacity < 1 = error "Cache.empty: capacity < 1" | otherwise = Cache { cCapacity = capacity , cSize = 0 , cValLimit = valLimit , cTick = 0 , cQueue = PSQ.empty } trim :: Ord k => Cache k v -> Cache k v trim c | cTick c == maxBound = empty (cCapacity c) (cValLimit c) | cSize c > cCapacity c = c { cSize = cSize c - 1 , cQueue = PSQ.deleteMin (cQueue c) } | otherwise = c insert :: (Ord k, Ord v) => k -> v -> Cache k v -> Cache k v insert k v c = case PSQ.alter lookupAndBump k (cQueue c) of (True, q) -> trim $ c { cTick = cTick c + 1, cQueue = q, cSize = cSize c + 1} (False, q) -> trim $ c { cTick = cTick c + 1, cQueue = q } where lookupAndBump Nothing = (True, Just (cTick c, M.singleton (cValLimit c) v)) lookupAndBump (Just (_, x)) = (False, Just (cTick c, M.insert v x)) lookup :: Ord k => k -> Cache k v -> (Cache k v, [v]) lookup k c = case PSQ.alter lookupAndBump k (cQueue c) of (Nothing, _) -> (c, []) (Just x, q) -> let c' = trim $ c { cTick = cTick c + 1, cQueue = q } xs = M.list x in (c', xs) where lookupAndBump Nothing = (Nothing, Nothing) lookupAndBump (Just (_, x)) = (Just x, Just (cTick c, x)) wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/Referer/Manager.hs0000644000000000000000000000273313663610537023325 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.Wai.Middleware.Push.Referer.Manager ( MakePushPromise , defaultMakePushPromise , Settings(..) , defaultSettings , Manager , URLPath , getManager , Network.Wai.Middleware.Push.Referer.Manager.lookup , Network.Wai.Middleware.Push.Referer.Manager.insert ) where import Control.Monad (unless) import Data.IORef import Network.Wai.Handler.Warp hiding (Settings, defaultSettings) import System.IO.Unsafe (unsafePerformIO) import Network.Wai.Middleware.Push.Referer.Types import qualified Network.Wai.Middleware.Push.Referer.LRU as LRU newtype Manager = Manager (IORef (LRU.Cache URLPath PushPromise)) getManager :: Settings -> IO Manager getManager Settings{..} = do isInitialized <- atomicModifyIORef' lruInitialized $ \x -> (True, x) unless isInitialized $ do let cache = LRU.empty keyLimit valueLimit Manager ref = cacheManager writeIORef ref cache return cacheManager lruInitialized :: IORef Bool lruInitialized = unsafePerformIO $ newIORef False {-# NOINLINE lruInitialized #-} cacheManager :: Manager cacheManager = Manager $ unsafePerformIO $ newIORef $ LRU.empty 0 0 {-# NOINLINE cacheManager #-} lookup :: URLPath -> Manager -> IO [PushPromise] lookup k (Manager ref) = atomicModifyIORef' ref $ LRU.lookup k insert :: URLPath -> PushPromise -> Manager -> IO () insert k v (Manager ref) = atomicModifyIORef' ref $ \c -> (LRU.insert k v c, ()) wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/Referer/ParseURL.hs0000644000000000000000000000571413663610537023412 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Push.Referer.ParseURL ( parseUrl ) where import Data.ByteString (ByteString) import Data.ByteString.Internal (ByteString(..), memchr) import Data.Word8 import Foreign.ForeignPtr (withForeignPtr, ForeignPtr) import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr) import Foreign.Storable (peek) import Network.Wai.Middleware.Push.Referer.Types -- | -- -- >>> parseUrl "" -- (Nothing,"") -- >>> parseUrl "/" -- (Nothing,"/") -- >>> parseUrl "ht" -- (Nothing,"") -- >>> parseUrl "http://example.com/foo/bar/" -- (Just "example.com","/foo/bar/") -- >>> parseUrl "https://www.example.com/path/to/dir/" -- (Just "www.example.com","/path/to/dir/") -- >>> parseUrl "http://www.example.com:8080/path/to/dir/" -- (Just "www.example.com:8080","/path/to/dir/") -- >>> parseUrl "//www.example.com:8080/path/to/dir/" -- (Just "www.example.com:8080","/path/to/dir/") -- >>> parseUrl "/path/to/dir/" -- (Nothing,"/path/to/dir/") parseUrl :: ByteString -> IO (Maybe ByteString, URLPath) parseUrl bs@(PS fptr0 off len) | len == 0 = return (Nothing, "") | len == 1 = return (Nothing, bs) | otherwise = withForeignPtr fptr0 $ \ptr0 -> do let begptr = ptr0 `plusPtr` off limptr = begptr `plusPtr` len parseUrl' fptr0 ptr0 begptr limptr len parseUrl' :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe ByteString, URLPath) parseUrl' fptr0 ptr0 begptr limptr len0 = do w0 <- peek begptr if w0 == _slash then do w1 <- peek $ begptr `plusPtr` 1 if w1 == _slash then doubleSlashed begptr len0 else slashed begptr len0 Nothing else do colonptr <- memchr begptr _colon $ fromIntegral len0 if colonptr == nullPtr then return (Nothing, "") else do let authptr = colonptr `plusPtr` 1 doubleSlashed authptr (limptr `minusPtr` authptr) where -- // / ? doubleSlashed :: Ptr Word8 -> Int -> IO (Maybe ByteString, URLPath) doubleSlashed ptr len | len < 2 = return (Nothing, "") | otherwise = do let ptr1 = ptr `plusPtr` 2 pathptr <- memchr ptr1 _slash $ fromIntegral len if pathptr == nullPtr then return (Nothing, "") else do let auth = bs ptr0 ptr1 pathptr slashed pathptr (limptr `minusPtr` pathptr) (Just auth) -- / ? slashed :: Ptr Word8 -> Int -> Maybe ByteString -> IO (Maybe ByteString, URLPath) slashed ptr len mauth = do questionptr <- memchr ptr _question $ fromIntegral len if questionptr == nullPtr then do let path = bs ptr0 ptr limptr return (mauth, path) else do let path = bs ptr0 ptr questionptr return (mauth, path) bs p0 p1 p2 = path where off = p1 `minusPtr` p0 siz = p2 `minusPtr` p1 path = PS fptr0 off siz wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/Referer/Types.hs0000644000000000000000000000433613663610537023060 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Push.Referer.Types ( URLPath , MakePushPromise , defaultMakePushPromise , Settings(..) , defaultSettings ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Network.Wai.Handler.Warp (PushPromise(..), defaultPushPromise) -- | Type for URL path. type URLPath = ByteString -- | Making a push promise based on Referer:, -- path to be pushed and file to be pushed. -- If the middleware should push this file in the next time when -- the page of Referer: is accessed, -- this function should return 'Just'. -- If 'Nothing' is returned, -- the middleware learns nothing. 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) -- | Learn if the file to be pushed is CSS (.css) or JavaScript (.js) file. defaultMakePushPromise :: MakePushPromise defaultMakePushPromise refPath path file = case getCT path of Nothing -> return Nothing Just ct -> do let pp = defaultPushPromise { promisedPath = path , promisedFile = file , promisedResponseHeaders = [("content-type", ct) ,("x-http2-push", refPath)] } return $ Just pp getCT :: URLPath -> Maybe ByteString getCT p | ".js" `BS.isSuffixOf` p = Just "application/javascript" | ".css" `BS.isSuffixOf` p = Just "text/css" | otherwise = Nothing -- | Settings for server push based on Referer:. data Settings = Settings { makePushPromise :: MakePushPromise -- ^ Default: 'defaultMakePushPromise' , duration :: Int -- ^ Deprecated , keyLimit :: Int -- ^ Max number of keys (e.g. index.html) in the learning information. Default: 20 , valueLimit :: Int -- ^ Max number of values (e.g. style.css) in the learning information. Default: 20 } -- | Default settings. defaultSettings :: Settings defaultSettings = Settings { makePushPromise = defaultMakePushPromise , duration = 0 , keyLimit = 20 , valueLimit = 20 } wai-http2-extra-0.1.3/Network/Wai/Middleware/Push/Referer/Multi.hs0000644000000000000000000000122313663610537023036 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Network.Wai.Middleware.Push.Referer.Multi where import Data.Set (Set) import qualified Data.Set as Set data Multi a = Multi { limit :: Int , list :: [a] , check :: Set a } deriving (Eq, Show) empty :: Int -> Multi a empty n = Multi n [] Set.empty singleton :: Int -> a -> Multi a singleton n v = Multi n [v] $ Set.singleton v insert :: Ord a => a -> Multi a -> Multi a insert _ m@Multi{..} | Set.size check == limit = m insert v m@Multi{..} | Set.size check == Set.size check' = m | otherwise = Multi limit (v:list) check' where check' = Set.insert v check