module Ribosome.Control.Lock where

import Control.Exception.Lifted (finally)
import qualified Control.Lens as Lens (at, view)
import qualified Data.Map.Strict as Map (insert)

import Ribosome.Control.Monad.Ribo (MonadRibo, pluginInternalL, pluginInternalModifyL)
import Ribosome.Control.Ribosome (Locks)
import qualified Ribosome.Control.Ribosome as Ribosome (locks)
import qualified Ribosome.Log as Log (debug)

getLocks :: MonadRibo m => m Locks
getLocks :: m Locks
getLocks =
  Lens' RibosomeInternal Locks -> m Locks
forall (m :: * -> *) a.
MonadRibo m =>
Lens' RibosomeInternal a -> m a
pluginInternalL forall c. HasRibosomeInternal c => Lens' c Locks
Lens' RibosomeInternal Locks
Ribosome.locks

inspectLocks :: MonadRibo m => (Locks -> a) -> m a
inspectLocks :: (Locks -> a) -> m a
inspectLocks = ((Locks -> a) -> m Locks -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Locks
forall (m :: * -> *). MonadRibo m => m Locks
getLocks)

modifyLocks :: MonadRibo m => (Locks -> Locks) -> m ()
modifyLocks :: (Locks -> Locks) -> m ()
modifyLocks =
  Lens' RibosomeInternal Locks -> (Locks -> Locks) -> m ()
forall (m :: * -> *) a.
MonadRibo m =>
Lens' RibosomeInternal a -> (a -> a) -> m ()
pluginInternalModifyL forall c. HasRibosomeInternal c => Lens' c Locks
Lens' RibosomeInternal Locks
Ribosome.locks

getOrCreateLock :: MonadRibo m => Text -> m (TMVar ())
getOrCreateLock :: Text -> m (TMVar ())
getOrCreateLock Text
key = do
  Maybe (TMVar ())
currentLock <- (Locks -> Maybe (TMVar ())) -> m (Maybe (TMVar ()))
forall (m :: * -> *) a. MonadRibo m => (Locks -> a) -> m a
inspectLocks ((Locks -> Maybe (TMVar ())) -> m (Maybe (TMVar ())))
-> (Locks -> Maybe (TMVar ())) -> m (Maybe (TMVar ()))
forall a b. (a -> b) -> a -> b
$ Getting (Maybe (TMVar ())) Locks (Maybe (TMVar ()))
-> Locks -> Maybe (TMVar ())
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
Lens.view (Getting (Maybe (TMVar ())) Locks (Maybe (TMVar ()))
 -> Locks -> Maybe (TMVar ()))
-> Getting (Maybe (TMVar ())) Locks (Maybe (TMVar ()))
-> Locks
-> Maybe (TMVar ())
forall a b. (a -> b) -> a -> b
$ Index Locks -> Lens' Locks (Maybe (IxValue Locks))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at Text
Index Locks
key
  case Maybe (TMVar ())
currentLock of
    Just TMVar ()
tv -> TMVar () -> m (TMVar ())
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar ()
tv
    Maybe (TMVar ())
Nothing -> do
      TMVar ()
tv <- () -> m (TMVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (TMVar a)
newTMVarIO ()
      (Locks -> Locks) -> m ()
forall (m :: * -> *). MonadRibo m => (Locks -> Locks) -> m ()
modifyLocks ((Locks -> Locks) -> m ()) -> (Locks -> Locks) -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> TMVar () -> Locks -> Locks
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key TMVar ()
tv
      Text -> m (TMVar ())
forall (m :: * -> *). MonadRibo m => Text -> m (TMVar ())
getOrCreateLock Text
key

lockOrSkip ::
  MonadRibo m =>
  MonadBaseControl IO m =>
  Text ->
  m () ->
  m ()
lockOrSkip :: Text -> m () -> m ()
lockOrSkip Text
key m ()
thunk = do
  TMVar ()
currentLock <- Text -> m (TMVar ())
forall (m :: * -> *). MonadRibo m => Text -> m (TMVar ())
getOrCreateLock Text
key
  Maybe ()
currentState <- STM (Maybe ()) -> m (Maybe ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe ()) -> m (Maybe ())) -> STM (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar ()
currentLock
  case Maybe ()
currentState of
    Just ()
_ -> do
      Text -> m ()
forall a (m :: * -> *). (Loggable a, MonadRibo m) => a -> m ()
Log.debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"locking TMVar `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
      m () -> m Bool -> m ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
finally m ()
thunk (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
currentLock ()
      Text -> m ()
forall a (m :: * -> *). (Loggable a, MonadRibo m) => a -> m ()
Log.debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"unlocking TMVar `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
    Maybe ()
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

lockOrWait ::
  MonadRibo m =>
  MonadBaseControl IO m =>
  Text ->
  m () ->
  m ()
lockOrWait :: Text -> m () -> m ()
lockOrWait Text
key m ()
thunk = do
  TMVar ()
currentLock <- Text -> m (TMVar ())
forall (m :: * -> *). MonadRibo m => Text -> m (TMVar ())
getOrCreateLock Text
key
  STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
currentLock
  Text -> m ()
forall a (m :: * -> *). (Loggable a, MonadRibo m) => a -> m ()
Log.debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"locking TMVar `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
  m () -> m () -> m ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
finally m ()
thunk (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
currentLock ()
  Text -> m ()
forall a (m :: * -> *). (Loggable a, MonadRibo m) => a -> m ()
Log.debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"unlocking TMVar `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"