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 "`"