{-# 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 Application
app Request
req 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 Manager
mgr res :: Response
res@(ResponseFile (Status Int
200 ByteString
"OK") ResponseHeaders
_ FilePath
file Maybe FilePart
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[PushPromise]
ps -> do
let h2d :: HTTP2Data
h2d = HTTP2Data
defaultHTTP2Data { http2dataPushPromise = 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
Maybe ByteString
Nothing -> Response -> IO ResponseReceived
sendResponse Response
res
Just ByteString
referer -> do
(Maybe ByteString
mauth,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
Maybe PushPromise
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PushPromise
pp -> ByteString -> PushPromise -> Manager -> IO ()
M.insert ByteString
refPath' PushPromise
pp Manager
mgr
Response -> IO ResponseReceived
sendResponse Response
res
push Manager
_ Response
res = Response -> IO ResponseReceived
sendResponse Response
res
isHTML :: URLPath -> Bool
isHTML :: ByteString -> Bool
isHTML ByteString
p = (ByteString
"/" ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
p)
Bool -> Bool -> Bool
|| (ByteString
".html" ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
p)
Bool -> Bool -> Bool
|| (ByteString
".htm" ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
p)