{-# 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 -> 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)
      -- file:    /index.html
      -- path:    /
      -- referer:
      -- refPath:
      | 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
      -- file:    /style.css
      -- path:    /style.css
      -- referer: /index.html
      -- refPath: /
      | 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)