InMem.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Mail.Newsletter.Web.Dedup.InMem
 ( InMemoryDedup(..)
 , newInMemDedup
 , HasInMemoryDedup(..)
 , genericInMemRecentlySubscribed
 ) where

import           Control.Concurrent.STM
import           Control.Lens
import           Control.Monad.Reader
import           Data.HashPSQ (HashPSQ)
import qualified Data.HashPSQ as PSQ
import           Data.Time
import           Data.Text (Text)
import           Network.Mail.Mime

data InMemoryDedup
 = InMemoryDedup
   { _psqTimeout    :: NominalDiffTime
   , _psqSubscribes :: TVar (HashPSQ Text UTCTime ())
   }

makeClassy ''InMemoryDedup

newInMemDedup :: MonadIO m => NominalDiffTime -> m InMemoryDedup
newInMemDedup d = liftIO $ InMemoryDedup d <$> newTVarIO PSQ.empty

genericInMemRecentlySubscribed :: (HasInMemoryDedup d, MonadReader d m, MonadIO m)
                               => Address -> m Bool
genericInMemRecentlySubscribed (Address _ email) = do
  now <- liftIO getCurrentTime
  p <- view psqSubscribes
  d <- view psqTimeout
  liftIO . atomically . stateTVar p $ \s' -> do
    let (_, s) = PSQ.atMostView ((-d) `addUTCTime` now) s'
    case PSQ.lookup email s of
      Nothing -> (True, PSQ.insert email now () s)
      Just _  -> (False, s)