{-# LANGUAGE ApplicativeDo #-}

module Freckle.App.Faktory.ProducerPool
  ( FaktoryProducerPool
  , FaktoryProducerPoolConfig (..)
  , envFaktoryProducerPoolConfig
  , HasFaktoryProducerPool (..)
  , createFaktoryProducerPool
  ) where

import Freckle.App.Prelude

import Control.Lens (Lens')
import Data.Pool
  ( Pool
  , defaultPoolConfig
  , newPool
  , setNumStripes
  )
import Faktory.Producer qualified as Faktory
import Faktory.Settings qualified as Faktory
import Freckle.App.Env qualified as Env
import Yesod.Core.Lens (envL, siteL)
import Yesod.Core.Types (HandlerData)

data FaktoryProducerPoolConfig = FaktoryProducerPoolConfig
  { FaktoryProducerPoolConfig -> Int
faktoryProducerPoolConfigStripes :: Int
  -- ^ The number of stripes (distinct sub-pools) to maintain.
  -- The smallest acceptable value is 1.
  , FaktoryProducerPoolConfig -> NominalDiffTime
faktoryProducerPoolConfigIdleTimeout :: NominalDiffTime
  -- ^ Amount of time for which an unused resource is kept open.
  -- The smallest acceptable value is 0.5 seconds.
  --
  -- The elapsed time before destroying a resource may be a little
  -- longer than requested, as the reaper thread wakes at 1-second
  -- intervals.
  , FaktoryProducerPoolConfig -> Int
faktoryProducerPoolConfigSize :: Int
  -- ^ Maximum number of resources to keep open per stripe.  The
  -- smallest acceptable value is 1.
  --
  -- Requests for resources will block if this limit is reached on a
  -- single stripe, even if other stripes have idle resources
  -- available.
  }
  deriving stock (Int -> FaktoryProducerPoolConfig -> ShowS
[FaktoryProducerPoolConfig] -> ShowS
FaktoryProducerPoolConfig -> String
(Int -> FaktoryProducerPoolConfig -> ShowS)
-> (FaktoryProducerPoolConfig -> String)
-> ([FaktoryProducerPoolConfig] -> ShowS)
-> Show FaktoryProducerPoolConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FaktoryProducerPoolConfig -> ShowS
showsPrec :: Int -> FaktoryProducerPoolConfig -> ShowS
$cshow :: FaktoryProducerPoolConfig -> String
show :: FaktoryProducerPoolConfig -> String
$cshowList :: [FaktoryProducerPoolConfig] -> ShowS
showList :: [FaktoryProducerPoolConfig] -> ShowS
Show)

-- | Same defaults as 'Database.Persist.Sql.ConnectionPoolConfig'
defaultFaktoryProducerPoolConfig :: FaktoryProducerPoolConfig
defaultFaktoryProducerPoolConfig :: FaktoryProducerPoolConfig
defaultFaktoryProducerPoolConfig = Int -> NominalDiffTime -> Int -> FaktoryProducerPoolConfig
FaktoryProducerPoolConfig Int
1 NominalDiffTime
600 Int
10

envFaktoryProducerPoolConfig
  :: Env.Parser Env.Error FaktoryProducerPoolConfig
envFaktoryProducerPoolConfig :: Parser Error FaktoryProducerPoolConfig
envFaktoryProducerPoolConfig = do
  Int
poolSize <- Reader Error Int -> String -> Mod Var Int -> Parser Error Int
forall e a.
AsUnset e =>
Reader e a -> String -> Mod Var a -> Parser e a
Env.var Reader Error Int
forall e a. (AsUnread e, Read a) => Reader e a
Env.auto String
"FAKTORY_PRODUCER_POOL_SIZE" (Mod Var Int -> Parser Error Int)
-> Mod Var Int -> Parser Error Int
forall a b. (a -> b) -> a -> b
$ Int -> Mod Var Int
forall a. a -> Mod Var a
Env.def Int
10
  pure $
    FaktoryProducerPoolConfig
defaultFaktoryProducerPoolConfig {faktoryProducerPoolConfigSize = poolSize}

type FaktoryProducerPool = Pool Faktory.Producer

class HasFaktoryProducerPool env where
  faktoryProducerPoolL :: Lens' env FaktoryProducerPool

instance HasFaktoryProducerPool site => HasFaktoryProducerPool (HandlerData child site) where
  faktoryProducerPoolL :: Lens' (HandlerData child site) FaktoryProducerPool
faktoryProducerPoolL = (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
forall child site (f :: * -> *).
Functor f =>
(RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
envL ((RunHandlerEnv child site -> f (RunHandlerEnv child site))
 -> HandlerData child site -> f (HandlerData child site))
-> ((FaktoryProducerPool -> f FaktoryProducerPool)
    -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> (FaktoryProducerPool -> f FaktoryProducerPool)
-> HandlerData child site
-> f (HandlerData child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
forall child site (f :: * -> *).
Functor f =>
(site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
siteL ((site -> f site)
 -> RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> ((FaktoryProducerPool -> f FaktoryProducerPool)
    -> site -> f site)
-> (FaktoryProducerPool -> f FaktoryProducerPool)
-> RunHandlerEnv child site
-> f (RunHandlerEnv child site)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FaktoryProducerPool -> f FaktoryProducerPool) -> site -> f site
forall env.
HasFaktoryProducerPool env =>
Lens' env FaktoryProducerPool
Lens' site FaktoryProducerPool
faktoryProducerPoolL

createFaktoryProducerPool
  :: Faktory.Settings -> FaktoryProducerPoolConfig -> IO FaktoryProducerPool
createFaktoryProducerPool :: Settings -> FaktoryProducerPoolConfig -> IO FaktoryProducerPool
createFaktoryProducerPool Settings
faktorySettings FaktoryProducerPoolConfig
poolConfig =
  PoolConfig Producer -> IO FaktoryProducerPool
forall a. PoolConfig a -> IO (Pool a)
newPool
    (PoolConfig Producer -> IO FaktoryProducerPool)
-> PoolConfig Producer -> IO FaktoryProducerPool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> PoolConfig Producer -> PoolConfig Producer
forall a. Maybe Int -> PoolConfig a -> PoolConfig a
setNumStripes
      (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ FaktoryProducerPoolConfig -> Int
faktoryProducerPoolConfigStripes FaktoryProducerPoolConfig
poolConfig)
    (PoolConfig Producer -> PoolConfig Producer)
-> PoolConfig Producer -> PoolConfig Producer
forall a b. (a -> b) -> a -> b
$ IO Producer
-> (Producer -> IO ()) -> Double -> Int -> PoolConfig Producer
forall a. IO a -> (a -> IO ()) -> Double -> Int -> PoolConfig a
defaultPoolConfig
      (Settings -> IO Producer
Faktory.newProducer Settings
faktorySettings)
      Producer -> IO ()
Faktory.closeProducer
      (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall a b. (a -> b) -> a -> b
$ FaktoryProducerPoolConfig -> NominalDiffTime
faktoryProducerPoolConfigIdleTimeout FaktoryProducerPoolConfig
poolConfig)
      (FaktoryProducerPoolConfig -> Int
faktoryProducerPoolConfigSize FaktoryProducerPoolConfig
poolConfig)