{-# 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 -> IO Manager
getManager Settings{Int
MakePushPromise
makePushPromise :: MakePushPromise
duration :: Int
keyLimit :: Int
valueLimit :: Int
makePushPromise :: Settings -> MakePushPromise
duration :: Settings -> Int
keyLimit :: Settings -> Int
valueLimit :: Settings -> Int
..} = do
    Bool
isInitialized <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
lruInitialized ((Bool -> (Bool, Bool)) -> IO Bool)
-> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Bool
x -> (Bool
True, Bool
x)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isInitialized (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let cache :: Cache k v
cache = Int -> Int -> Cache k v
forall k v. Int -> Int -> Cache k v
LRU.empty Int
keyLimit Int
valueLimit
            Manager IORef (Cache URLPath PushPromise)
ref = Manager
cacheManager
        IORef (Cache URLPath PushPromise)
-> Cache URLPath PushPromise -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Cache URLPath PushPromise)
ref Cache URLPath PushPromise
forall {k} {v}. Cache k v
cache
    Manager -> IO Manager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
cacheManager

lruInitialized :: IORef Bool
lruInitialized :: IORef Bool
lruInitialized = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
{-# NOINLINE lruInitialized #-}

cacheManager :: Manager
cacheManager :: Manager
cacheManager = IORef (Cache URLPath PushPromise) -> Manager
Manager (IORef (Cache URLPath PushPromise) -> Manager)
-> IORef (Cache URLPath PushPromise) -> Manager
forall a b. (a -> b) -> a -> b
$ IO (IORef (Cache URLPath PushPromise))
-> IORef (Cache URLPath PushPromise)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Cache URLPath PushPromise))
 -> IORef (Cache URLPath PushPromise))
-> IO (IORef (Cache URLPath PushPromise))
-> IORef (Cache URLPath PushPromise)
forall a b. (a -> b) -> a -> b
$ Cache URLPath PushPromise -> IO (IORef (Cache URLPath PushPromise))
forall a. a -> IO (IORef a)
newIORef (Cache URLPath PushPromise
 -> IO (IORef (Cache URLPath PushPromise)))
-> Cache URLPath PushPromise
-> IO (IORef (Cache URLPath PushPromise))
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Cache URLPath PushPromise
forall k v. Int -> Int -> Cache k v
LRU.empty Int
0 Int
0
{-# NOINLINE cacheManager #-}

lookup :: URLPath -> Manager -> IO [PushPromise]
lookup :: URLPath -> Manager -> IO [PushPromise]
lookup URLPath
k (Manager IORef (Cache URLPath PushPromise)
ref) = IORef (Cache URLPath PushPromise)
-> (Cache URLPath PushPromise
    -> (Cache URLPath PushPromise, [PushPromise]))
-> IO [PushPromise]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Cache URLPath PushPromise)
ref ((Cache URLPath PushPromise
  -> (Cache URLPath PushPromise, [PushPromise]))
 -> IO [PushPromise])
-> (Cache URLPath PushPromise
    -> (Cache URLPath PushPromise, [PushPromise]))
-> IO [PushPromise]
forall a b. (a -> b) -> a -> b
$ URLPath
-> Cache URLPath PushPromise
-> (Cache URLPath PushPromise, [PushPromise])
forall k v. Ord k => k -> Cache k v -> (Cache k v, [v])
LRU.lookup URLPath
k

insert :: URLPath -> PushPromise -> Manager -> IO ()
insert :: URLPath -> PushPromise -> Manager -> IO ()
insert URLPath
k PushPromise
v (Manager IORef (Cache URLPath PushPromise)
ref) = IORef (Cache URLPath PushPromise)
-> (Cache URLPath PushPromise -> (Cache URLPath PushPromise, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Cache URLPath PushPromise)
ref ((Cache URLPath PushPromise -> (Cache URLPath PushPromise, ()))
 -> IO ())
-> (Cache URLPath PushPromise -> (Cache URLPath PushPromise, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Cache URLPath PushPromise
c -> (URLPath
-> PushPromise
-> Cache URLPath PushPromise
-> Cache URLPath PushPromise
forall k v. (Ord k, Ord v) => k -> v -> Cache k v -> Cache k v
LRU.insert URLPath
k PushPromise
v Cache URLPath PushPromise
c, ())