module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
  ( -- * DNS semaphore
    DNSSemaphore
  , newLedgerAndPublicRootDNSSemaphore
  , newDNSLocalRootSemaphore
  , withDNSSemaphore
  ) where

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Concurrent.Class.MonadSTM.TSem
import Control.Monad.Class.MonadThrow

-- | Maximal concurrency when resolving DNS names of root and ledger peers.
--
maxDNSConcurrency :: Integer
maxDNSConcurrency :: Integer
maxDNSConcurrency = Integer
8

-- | Maximal concurrency when resolving DNS names of local root peers.
--
maxDNSLocalRootConcurrency :: Integer
maxDNSLocalRootConcurrency :: Integer
maxDNSLocalRootConcurrency = Integer
2

-- | A semaphore used to limit concurrency of dns names resolution.
--
newtype DNSSemaphore m = DNSSemaphore (TSem m)

-- | Create a `DNSSemaphore` for root and ledger peers.
--
newLedgerAndPublicRootDNSSemaphore :: MonadSTM m => m (DNSSemaphore m)
newLedgerAndPublicRootDNSSemaphore :: forall (m :: * -> *). MonadSTM m => m (DNSSemaphore m)
newLedgerAndPublicRootDNSSemaphore = TSem m -> DNSSemaphore m
forall (m :: * -> *). TSem m -> DNSSemaphore m
DNSSemaphore (TSem m -> DNSSemaphore m) -> m (TSem m) -> m (DNSSemaphore m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (TSem m) -> m (TSem m)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Integer -> STM m (TSem m)
forall (m :: * -> *). MonadSTM m => Integer -> STM m (TSem m)
newTSem Integer
maxDNSConcurrency)

-- | Create a `DNSSemaphore` for local root peers.
--
newDNSLocalRootSemaphore :: MonadSTM m => STM m (DNSSemaphore m)
newDNSLocalRootSemaphore :: forall (m :: * -> *). MonadSTM m => STM m (DNSSemaphore m)
newDNSLocalRootSemaphore = TSem m -> DNSSemaphore m
forall (m :: * -> *). TSem m -> DNSSemaphore m
DNSSemaphore (TSem m -> DNSSemaphore m)
-> STM m (TSem m) -> STM m (DNSSemaphore m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM m (TSem m)
forall (m :: * -> *). MonadSTM m => Integer -> STM m (TSem m)
newTSem Integer
maxDNSLocalRootConcurrency

-- | Run a computation by attempting to acquire the semaphore first.
-- On termination or failure free the semaphore
--
withDNSSemaphore :: (MonadSTM m, MonadThrow m) => DNSSemaphore m -> m a -> m a
withDNSSemaphore :: forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m) =>
DNSSemaphore m -> m a -> m a
withDNSSemaphore (DNSSemaphore TSem m
s) =
    m () -> m () -> m a -> m a
forall a b c. m a -> m b -> m c -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TSem m -> STM m ()
forall (m :: * -> *). MonadSTM m => TSem m -> STM m ()
waitTSem TSem m
s)
             (STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TSem m -> STM m ()
forall (m :: * -> *). MonadSTM m => TSem m -> STM m ()
signalTSem TSem m
s)