{-# 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
    mgr <- Settings -> IO Manager
M.getManager Settings
settings
    app req $ push 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
_ String
file Maybe FilePart
Nothing)
      -- file:    /index.html
      -- path:    /
      -- referer:
      -- refPath:
      | ByteString -> Bool
isHTML ByteString
path = do
            xs <- ByteString -> Manager -> IO [PushPromise]
M.lookup ByteString
path Manager
mgr
            case 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
            sendResponse 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
              (mauth,refPath) <- ByteString -> IO (Maybe ByteString, ByteString)
parseUrl ByteString
referer
              when ((isNothing mauth || requestHeaderHost req == mauth)
                  && path /= refPath
                  && isHTML refPath) $ do
                  let path' = ByteString -> ByteString
BS.copy ByteString
path
                      refPath' = ByteString -> ByteString
BS.copy ByteString
refPath
                  mpp <- makePushPromise settings refPath' path' file
                  case 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
              sendResponse 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)