Manager.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.Wai.Middleware.Push.Referer.Manager (
    MakePushPromise
  , defaultMakePushPromise
  , Settings(..)
  , defaultSettings
  , Manager
  , URLPath
  , getManager
  , Network.Wai.Middleware.Push.Referer.Manager.lookup
  , Network.Wai.Middleware.Push.Referer.Manager.insert
  ) where

import Control.Monad (unless)
import Data.IORef
import Network.Wai.Handler.Warp hiding (Settings, defaultSettings)
import System.IO.Unsafe (unsafePerformIO)

import Network.Wai.Middleware.Push.Referer.Types
import qualified Network.Wai.Middleware.Push.Referer.LRU as LRU

newtype Manager = Manager (IORef (LRU.Cache URLPath PushPromise))

getManager :: Settings -> IO Manager
getManager Settings{..} = do
    isInitialized <- atomicModifyIORef' lruInitialized $ \x -> (True, x)
    unless isInitialized $ do
        let cache = LRU.empty keyLimit valueLimit
            Manager ref = cacheManager
        writeIORef ref cache
    return cacheManager

lruInitialized :: IORef Bool
lruInitialized = unsafePerformIO $ newIORef False
{-# NOINLINE lruInitialized #-}

cacheManager :: Manager
cacheManager = Manager $ unsafePerformIO $ newIORef $ LRU.empty 0 0
{-# NOINLINE cacheManager #-}

lookup :: URLPath -> Manager -> IO [PushPromise]
lookup k (Manager ref) = atomicModifyIORef' ref $ LRU.lookup k

insert :: URLPath -> PushPromise -> Manager -> IO ()
insert k v (Manager ref) = atomicModifyIORef' ref $ \c -> (LRU.insert k v c, ())