{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}
module Network.Wai.Middleware.Push.Referer (
pushOnReferer
, URLPath
, MakePushPromise
, defaultMakePushPromise
, Settings
, defaultSettings
, makePushPromise
, duration
, keyLimit
, valueLimit
) where
import Control.Monad (when, unless)
import Control.Reaper
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Internal (ByteString(..), memchr)
import Data.IORef
import Data.Maybe (isNothing)
import Data.Word (Word8)
import Data.Word8
import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
import Foreign.Storable (peek)
import Network.HTTP.Types (Status(..))
import Network.Wai
import Network.Wai.Handler.Warp hiding (Settings, defaultSettings)
import Network.Wai.Internal (Response(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Network.Wai.Middleware.Push.Referer.LimitMultiMap as M
type MakePushPromise = URLPath
-> URLPath
-> FilePath
-> IO (Maybe PushPromise)
type URLPath = ByteString
type Cache = M.LimitMultiMap URLPath PushPromise
initialized :: IORef Bool
initialized :: IORef Bool
initialized = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
{-# NOINLINE initialized #-}
cacheReaper :: IORef (Maybe (Reaper Cache (URLPath,PushPromise)))
cacheReaper :: IORef (Maybe (Reaper Cache (URLPath, PushPromise)))
cacheReaper = IO (IORef (Maybe (Reaper Cache (URLPath, PushPromise))))
-> IORef (Maybe (Reaper Cache (URLPath, PushPromise)))
forall a. IO a -> a
unsafePerformIO (IO (IORef (Maybe (Reaper Cache (URLPath, PushPromise))))
-> IORef (Maybe (Reaper Cache (URLPath, PushPromise))))
-> IO (IORef (Maybe (Reaper Cache (URLPath, PushPromise))))
-> IORef (Maybe (Reaper Cache (URLPath, PushPromise)))
forall a b. (a -> b) -> a -> b
$ Maybe (Reaper Cache (URLPath, PushPromise))
-> IO (IORef (Maybe (Reaper Cache (URLPath, PushPromise))))
forall a. a -> IO (IORef a)
newIORef Maybe (Reaper Cache (URLPath, PushPromise))
forall a. Maybe a
Nothing
{-# NOINLINE cacheReaper #-}
data Settings = Settings {
Settings -> MakePushPromise
makePushPromise :: MakePushPromise
, Settings -> Int
duration :: Int
, Settings -> Int
keyLimit :: Int
, Settings -> Int
valueLimit :: Int
}
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = $WSettings :: MakePushPromise -> Int -> Int -> Int -> Settings
Settings {
makePushPromise :: MakePushPromise
makePushPromise = MakePushPromise
defaultMakePushPromise
, duration :: Int
duration = 30000000
, keyLimit :: Int
keyLimit = 20
, valueLimit :: Int
valueLimit = 20
}
tryInitialize :: Settings -> IO ()
tryInitialize :: Settings -> IO ()
tryInitialize Settings{..} = do
Bool
isInitialized <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
initialized ((Bool -> (Bool, Bool)) -> IO Bool)
-> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \x :: Bool
x -> (Bool
True, Bool
x)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isInitialized (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Reaper Cache (URLPath, PushPromise)
reaper <- ReaperSettings Cache (URLPath, PushPromise)
-> IO (Reaper Cache (URLPath, PushPromise))
forall workload item.
ReaperSettings workload item -> IO (Reaper workload item)
mkReaper ReaperSettings Cache (URLPath, PushPromise)
settings
IORef (Maybe (Reaper Cache (URLPath, PushPromise)))
-> Maybe (Reaper Cache (URLPath, PushPromise)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Reaper Cache (URLPath, PushPromise)))
cacheReaper (Reaper Cache (URLPath, PushPromise)
-> Maybe (Reaper Cache (URLPath, PushPromise))
forall a. a -> Maybe a
Just Reaper Cache (URLPath, PushPromise)
reaper)
where
emptyCache :: LimitMultiMap k v
emptyCache = Int -> Int -> LimitMultiMap k v
forall k v. Int -> Int -> LimitMultiMap k v
M.empty Int
keyLimit Int
valueLimit
settings :: ReaperSettings Cache (URLPath,PushPromise)
settings :: ReaperSettings Cache (URLPath, PushPromise)
settings = ReaperSettings [Any] Any
forall item. ReaperSettings [item] item
defaultReaperSettings {
reaperAction :: Cache -> IO (Cache -> Cache)
reaperAction = \_ -> (Cache -> Cache) -> IO (Cache -> Cache)
forall (m :: * -> *) a. Monad m => a -> m a
return (\_ -> Cache
forall k v. LimitMultiMap k v
emptyCache)
, reaperCons :: (URLPath, PushPromise) -> Cache -> Cache
reaperCons = (URLPath, PushPromise) -> Cache -> Cache
forall k v.
(Ord k, Ord v) =>
(k, v) -> LimitMultiMap k v -> LimitMultiMap k v
M.insert
, reaperNull :: Cache -> Bool
reaperNull = Cache -> Bool
forall k t. LimitMultiMap k t -> Bool
M.isEmpty
, reaperEmpty :: Cache
reaperEmpty = Cache
forall k v. LimitMultiMap k v
emptyCache
, reaperDelay :: Int
reaperDelay = Int
duration
}
pushOnReferer :: Settings -> Middleware
pushOnReferer :: Settings -> Middleware
pushOnReferer settings :: Settings
settings@Settings{..} app :: Application
app req :: Request
req sendResponse :: Response -> IO ResponseReceived
sendResponse = do
Settings -> IO ()
tryInitialize Settings
settings
Maybe (Reaper Cache (URLPath, PushPromise))
mreaper <- IORef (Maybe (Reaper Cache (URLPath, PushPromise)))
-> IO (Maybe (Reaper Cache (URLPath, PushPromise)))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Reaper Cache (URLPath, PushPromise)))
cacheReaper
case Maybe (Reaper Cache (URLPath, PushPromise))
mreaper of
Nothing -> Application
app Request
req Response -> IO ResponseReceived
sendResponse
Just reaper :: Reaper Cache (URLPath, PushPromise)
reaper -> Application
app Request
req (Reaper Cache (URLPath, PushPromise)
-> Response -> IO ResponseReceived
push Reaper Cache (URLPath, PushPromise)
reaper)
where
push :: Reaper Cache (URLPath, PushPromise)
-> Response -> IO ResponseReceived
push reaper :: Reaper Cache (URLPath, PushPromise)
reaper res :: Response
res@(ResponseFile (Status 200 "OK") _ file :: FilePath
file Nothing) = do
let !path :: URLPath
path = Request -> URLPath
rawPathInfo Request
req
Cache
m <- Reaper Cache (URLPath, PushPromise) -> IO Cache
forall workload item. Reaper workload item -> IO workload
reaperRead Reaper Cache (URLPath, PushPromise)
reaper
case URLPath -> Cache -> [PushPromise]
forall k v. Ord k => k -> LimitMultiMap k v -> [v]
M.lookup URLPath
path Cache
m of
[] -> case Request -> Maybe URLPath
requestHeaderReferer Request
req of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just referer :: URLPath
referer -> do
(mauth :: Maybe URLPath
mauth,refPath :: URLPath
refPath) <- URLPath -> IO (Maybe URLPath, URLPath)
parseUrl URLPath
referer
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe URLPath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe URLPath
mauth
Bool -> Bool -> Bool
|| Request -> Maybe URLPath
requestHeaderHost Request
req Maybe URLPath -> Maybe URLPath -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe URLPath
mauth) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (URLPath
path URLPath -> URLPath -> Bool
forall a. Eq a => a -> a -> Bool
/= URLPath
refPath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let !path' :: URLPath
path' = URLPath -> URLPath
BS.copy URLPath
path
!refPath' :: URLPath
refPath' = URLPath -> URLPath
BS.copy URLPath
refPath
Maybe PushPromise
mpp <- MakePushPromise
makePushPromise URLPath
refPath' URLPath
path' FilePath
file
case Maybe PushPromise
mpp of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just pp :: PushPromise
pp -> Reaper Cache (URLPath, PushPromise)
-> (URLPath, PushPromise) -> IO ()
forall workload item. Reaper workload item -> item -> IO ()
reaperAdd Reaper Cache (URLPath, PushPromise)
reaper (URLPath
refPath',PushPromise
pp)
ps :: [PushPromise]
ps -> do
let !h2d :: HTTP2Data
h2d = HTTP2Data
defaultHTTP2Data { http2dataPushPromise :: [PushPromise]
http2dataPushPromise = [PushPromise]
ps}
Request -> Maybe HTTP2Data -> IO ()
setHTTP2Data Request
req (HTTP2Data -> Maybe HTTP2Data
forall a. a -> Maybe a
Just HTTP2Data
h2d)
Response -> IO ResponseReceived
sendResponse Response
res
push _ res :: Response
res = Response -> IO ResponseReceived
sendResponse Response
res
defaultMakePushPromise :: MakePushPromise
defaultMakePushPromise :: MakePushPromise
defaultMakePushPromise refPath :: URLPath
refPath path :: URLPath
path file :: FilePath
file
| URLPath -> Bool
isHTML URLPath
refPath = case URLPath -> Maybe URLPath
getCT URLPath
path of
Nothing -> Maybe PushPromise -> IO (Maybe PushPromise)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PushPromise
forall a. Maybe a
Nothing
Just ct :: URLPath
ct -> do
let pp :: PushPromise
pp = PushPromise
defaultPushPromise {
promisedPath :: URLPath
promisedPath = URLPath
path
, promisedFile :: FilePath
promisedFile = FilePath
file
, promisedResponseHeaders :: ResponseHeaders
promisedResponseHeaders = [("content-type", URLPath
ct)
,("x-http2-push", URLPath
refPath)]
}
Maybe PushPromise -> IO (Maybe PushPromise)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PushPromise -> IO (Maybe PushPromise))
-> Maybe PushPromise -> IO (Maybe PushPromise)
forall a b. (a -> b) -> a -> b
$ PushPromise -> Maybe PushPromise
forall a. a -> Maybe a
Just PushPromise
pp
| Bool
otherwise = Maybe PushPromise -> IO (Maybe PushPromise)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PushPromise
forall a. Maybe a
Nothing
getCT :: URLPath -> Maybe ByteString
getCT :: URLPath -> Maybe URLPath
getCT p :: URLPath
p
| ".js" URLPath -> URLPath -> Bool
`BS.isSuffixOf` URLPath
p = URLPath -> Maybe URLPath
forall a. a -> Maybe a
Just "application/javascript"
| ".css" URLPath -> URLPath -> Bool
`BS.isSuffixOf` URLPath
p = URLPath -> Maybe URLPath
forall a. a -> Maybe a
Just "text/css"
| Bool
otherwise = Maybe URLPath
forall a. Maybe a
Nothing
isHTML :: URLPath -> Bool
isHTML :: URLPath -> Bool
isHTML p :: URLPath
p = ("/" URLPath -> URLPath -> Bool
`BS.isSuffixOf` URLPath
p)
Bool -> Bool -> Bool
|| (".html" URLPath -> URLPath -> Bool
`BS.isSuffixOf` URLPath
p)
Bool -> Bool -> Bool
|| (".htm" URLPath -> URLPath -> Bool
`BS.isSuffixOf` URLPath
p)
parseUrl :: ByteString -> IO (Maybe ByteString, URLPath)
parseUrl :: URLPath -> IO (Maybe URLPath, URLPath)
parseUrl bs :: URLPath
bs@(PS fptr0 :: ForeignPtr Word8
fptr0 off :: Int
off len :: Int
len)
| Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = (Maybe URLPath, URLPath) -> IO (Maybe URLPath, URLPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URLPath
forall a. Maybe a
Nothing, "")
| Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = (Maybe URLPath, URLPath) -> IO (Maybe URLPath, URLPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URLPath
forall a. Maybe a
Nothing, URLPath
bs)
| Bool
otherwise = ForeignPtr Word8
-> (Ptr Word8 -> IO (Maybe URLPath, URLPath))
-> IO (Maybe URLPath, URLPath)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr0 ((Ptr Word8 -> IO (Maybe URLPath, URLPath))
-> IO (Maybe URLPath, URLPath))
-> (Ptr Word8 -> IO (Maybe URLPath, URLPath))
-> IO (Maybe URLPath, URLPath)
forall a b. (a -> b) -> a -> b
$ \ptr0 :: Ptr Word8
ptr0 -> do
let begptr :: Ptr b
begptr = Ptr Word8
ptr0 Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
limptr :: Ptr b
limptr = Ptr Any
forall b. Ptr b
begptr Ptr Any -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len
ForeignPtr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Int
-> IO (Maybe URLPath, URLPath)
parseUrl' ForeignPtr Word8
fptr0 Ptr Word8
ptr0 Ptr Word8
forall b. Ptr b
begptr Ptr Word8
forall b. Ptr b
limptr Int
len
parseUrl' :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int
-> IO (Maybe ByteString, URLPath)
parseUrl' :: ForeignPtr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Int
-> IO (Maybe URLPath, URLPath)
parseUrl' fptr0 :: ForeignPtr Word8
fptr0 ptr0 :: Ptr Word8
ptr0 begptr :: Ptr Word8
begptr limptr :: Ptr Word8
limptr len0 :: Int
len0 = do
Word8
w0 <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
begptr
if Word8
w0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_slash then do
Word8
w1 <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word8 -> IO Word8) -> Ptr Word8 -> IO Word8
forall a b. (a -> b) -> a -> b
$ Ptr Word8
begptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` 1
if Word8
w1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_slash then
Ptr Word8 -> Int -> IO (Maybe URLPath, URLPath)
doubleSlashed Ptr Word8
begptr Int
len0
else
Ptr Word8 -> Int -> Maybe URLPath -> IO (Maybe URLPath, URLPath)
slashed Ptr Word8
begptr Int
len0 Maybe URLPath
forall a. Maybe a
Nothing
else do
Ptr Word8
colonptr <- Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
memchr Ptr Word8
begptr Word8
_colon (CSize -> IO (Ptr Word8)) -> CSize -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len0
if Ptr Word8
colonptr Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall b. Ptr b
nullPtr then
(Maybe URLPath, URLPath) -> IO (Maybe URLPath, URLPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URLPath
forall a. Maybe a
Nothing, "")
else do
let !authptr :: Ptr b
authptr = Ptr Word8
colonptr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` 1
Ptr Word8 -> Int -> IO (Maybe URLPath, URLPath)
doubleSlashed Ptr Word8
forall b. Ptr b
authptr (Ptr Word8
limptr Ptr Word8 -> Ptr Any -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Any
forall b. Ptr b
authptr)
where
doubleSlashed :: Ptr Word8 -> Int -> IO (Maybe ByteString, URLPath)
doubleSlashed :: Ptr Word8 -> Int -> IO (Maybe URLPath, URLPath)
doubleSlashed ptr :: Ptr Word8
ptr len :: Int
len
| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 = (Maybe URLPath, URLPath) -> IO (Maybe URLPath, URLPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URLPath
forall a. Maybe a
Nothing, "")
| Bool
otherwise = do
let ptr1 :: Ptr b
ptr1 = Ptr Word8
ptr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` 2
Ptr Word8
pathptr <- Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
memchr Ptr Word8
forall b. Ptr b
ptr1 Word8
_slash (CSize -> IO (Ptr Word8)) -> CSize -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
if Ptr Word8
pathptr Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall b. Ptr b
nullPtr then
(Maybe URLPath, URLPath) -> IO (Maybe URLPath, URLPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URLPath
forall a. Maybe a
Nothing, "")
else do
let !auth :: URLPath
auth = Ptr Word8 -> Ptr Any -> Ptr Word8 -> URLPath
forall b a a. Ptr b -> Ptr a -> Ptr a -> URLPath
bs Ptr Word8
ptr0 Ptr Any
forall b. Ptr b
ptr1 Ptr Word8
pathptr
Ptr Word8 -> Int -> Maybe URLPath -> IO (Maybe URLPath, URLPath)
slashed Ptr Word8
pathptr (Ptr Word8
limptr Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
pathptr) (URLPath -> Maybe URLPath
forall a. a -> Maybe a
Just URLPath
auth)
slashed :: Ptr Word8 -> Int -> Maybe ByteString -> IO (Maybe ByteString, URLPath)
slashed :: Ptr Word8 -> Int -> Maybe URLPath -> IO (Maybe URLPath, URLPath)
slashed ptr :: Ptr Word8
ptr len :: Int
len mauth :: Maybe URLPath
mauth = do
Ptr Word8
questionptr <- Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
memchr Ptr Word8
ptr Word8
_question (CSize -> IO (Ptr Word8)) -> CSize -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
if Ptr Word8
questionptr Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall b. Ptr b
nullPtr then do
let !path :: URLPath
path = Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> URLPath
forall b a a. Ptr b -> Ptr a -> Ptr a -> URLPath
bs Ptr Word8
ptr0 Ptr Word8
ptr Ptr Word8
limptr
(Maybe URLPath, URLPath) -> IO (Maybe URLPath, URLPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URLPath
mauth, URLPath
path)
else do
let !path :: URLPath
path = Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> URLPath
forall b a a. Ptr b -> Ptr a -> Ptr a -> URLPath
bs Ptr Word8
ptr0 Ptr Word8
ptr Ptr Word8
questionptr
(Maybe URLPath, URLPath) -> IO (Maybe URLPath, URLPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URLPath
mauth, URLPath
path)
bs :: Ptr b -> Ptr a -> Ptr a -> URLPath
bs p0 :: Ptr b
p0 p1 :: Ptr a
p1 p2 :: Ptr a
p2 = URLPath
path
where
!off :: Int
off = Ptr a
p1 Ptr a -> Ptr b -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr b
p0
!siz :: Int
siz = Ptr a
p2 Ptr a -> Ptr a -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr a
p1
!path :: URLPath
path = ForeignPtr Word8 -> Int -> Int -> URLPath
PS ForeignPtr Word8
fptr0 Int
off Int
siz