    {-# 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)