{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Middleware.Push.Referer (
pushOnReferer
, URLPath
, MakePushPromise
, defaultMakePushPromise
, 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
pushOnReferer :: Settings -> Middleware
pushOnReferer :: Settings -> Middleware
pushOnReferer settings :: Settings
settings app :: Application
app req :: Request
req sendResponse :: Response -> IO ResponseReceived
sendResponse = do
Manager
mgr <- Settings -> IO Manager
M.getManager Settings
settings
Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Manager -> Response -> IO ResponseReceived
push Manager
mgr
where
path :: ByteString
path = Request -> ByteString
rawPathInfo Request
req
push :: Manager -> Response -> IO ResponseReceived
push mgr :: Manager
mgr res :: Response
res@(ResponseFile (Status 200 "OK") _ file :: FilePath
file Nothing)
| ByteString -> Bool
isHTML ByteString
path = do
[PushPromise]
xs <- ByteString -> Manager -> IO [PushPromise]
M.lookup ByteString
path Manager
mgr
case [PushPromise]
xs of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ps :: [PushPromise]
ps -> do
let h2d :: HTTP2Data
h2d = HTTP2Data
defaultHTTP2Data { http2dataPushPromise :: [PushPromise]
http2dataPushPromise = [PushPromise]
ps }
Request -> Maybe HTTP2Data -> IO ()
setHTTP2Data Request
req (Maybe HTTP2Data -> IO ()) -> Maybe HTTP2Data -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Data -> Maybe HTTP2Data
forall a. a -> Maybe a
Just HTTP2Data
h2d
Response -> IO ResponseReceived
sendResponse Response
res
| Bool
otherwise = case Request -> Maybe ByteString
requestHeaderReferer Request
req of
Nothing -> Response -> IO ResponseReceived
sendResponse Response
res
Just referer :: ByteString
referer -> do
(mauth :: Maybe ByteString
mauth,refPath :: ByteString
refPath) <- ByteString -> IO (Maybe ByteString, ByteString)
parseUrl ByteString
referer
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
mauth Bool -> Bool -> Bool
|| Request -> Maybe ByteString
requestHeaderHost Request
req Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
mauth)
Bool -> Bool -> Bool
&& ByteString
path ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
refPath
Bool -> Bool -> Bool
&& ByteString -> Bool
isHTML ByteString
refPath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let path' :: ByteString
path' = ByteString -> ByteString
BS.copy ByteString
path
refPath' :: ByteString
refPath' = ByteString -> ByteString
BS.copy ByteString
refPath
Maybe PushPromise
mpp <- Settings -> MakePushPromise
makePushPromise Settings
settings ByteString
refPath' ByteString
path' FilePath
file
case Maybe PushPromise
mpp of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just pp :: PushPromise
pp -> ByteString -> PushPromise -> Manager -> IO ()
M.insert ByteString
refPath' PushPromise
pp Manager
mgr
Response -> IO ResponseReceived
sendResponse Response
res
push _ res :: Response
res = Response -> IO ResponseReceived
sendResponse Response
res
isHTML :: URLPath -> Bool
isHTML :: ByteString -> Bool
isHTML p :: ByteString
p = ("/" ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
p)
Bool -> Bool -> Bool
|| (".html" ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
p)
Bool -> Bool -> Bool
|| (".htm" ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
p)