From 93e369d985d2976dd24380ee7d1476bfe4ace55b Mon Sep 17 00:00:00 2001 From: Daan Rijks Date: Wed, 3 Apr 2024 11:05:37 +0200 Subject: [PATCH 1/3] Add Show instances for TTL and SimpleValueIdentifier --- src/Database/Redis/Schema.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Database/Redis/Schema.hs b/src/Database/Redis/Schema.hs index 26a241a..feb611f 100644 --- a/src/Database/Redis/Schema.hs +++ b/src/Database/Redis/Schema.hs @@ -140,6 +140,7 @@ data RedisException -- | Time-To-Live for Redis values. The Num instance works in (integral) seconds. newtype TTL = TTLSec { ttlToSeconds :: Integer } + deriving stock (Show) deriving newtype (Eq, Ord, Num) run :: MonadIO m => Pool inst -> RedisM inst a -> m a @@ -403,6 +404,7 @@ class Value inst val where data SimpleValueIdentifier = SviTopLevel ByteString -- ^ Stored in a top-level key. | SviHash ByteString ByteString -- ^ Stored in a hash field. + deriving stock (Show) -- | Simple values, like strings, integers or enums, -- that be represented as a single bytestring. From 7937861aad8597e2ea488268a8ebbfb7eac606f7 Mon Sep 17 00:00:00 2001 From: Daan Rijks Date: Wed, 3 Apr 2024 10:58:07 +0200 Subject: [PATCH 2/3] Make LockAcquireTimeout a separate exception type --- src/Database/Redis/Schema.hs | 1 - src/Database/Redis/Schema/Lock.hs | 11 +++++++++-- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Database/Redis/Schema.hs b/src/Database/Redis/Schema.hs index feb611f..edb718a 100644 --- a/src/Database/Redis/Schema.hs +++ b/src/Database/Redis/Schema.hs @@ -133,7 +133,6 @@ data RedisException | TransactionAborted | TransactionError String | CouldNotDecodeValue (Maybe ByteString) - | LockAcquireTimeout | UnexpectedStatus String Hedis.Status | EmptyAlternative -- for 'instance Alternative Tx' deriving (Show, Exception) diff --git a/src/Database/Redis/Schema/Lock.hs b/src/Database/Redis/Schema/Lock.hs index 1bb2b74..2058e71 100644 --- a/src/Database/Redis/Schema/Lock.hs +++ b/src/Database/Redis/Schema/Lock.hs @@ -23,6 +23,7 @@ module Database.Redis.Schema.Lock , defaultMetaParams , ExclusiveLock, withExclusiveLock , ShareableLock, withShareableLock, LockSharing(..) + , LockAcquireTimeout(..) ) where @@ -39,12 +40,18 @@ import qualified Data.ByteString.Char8 as BS import System.Random ( randomIO ) import Control.Concurrent ( threadDelay, myThreadId ) +import Control.Exception ( Exception ) import Control.Monad.Fix ( fix ) import Control.Monad.Catch ( MonadThrow(..), MonadCatch(..), MonadMask(..), throwM, finally ) import Control.Monad.IO.Class ( liftIO, MonadIO ) import qualified Database.Redis.Schema as Redis +data LockAcquireTimeout = LockAcquireTimeout + deriving (Show) + +instance Exception LockAcquireTimeout + data LockParams = LockParams { lpMeanRetryInterval :: NominalDiffTime , lpAcquireTimeout :: NominalDiffTime @@ -93,7 +100,7 @@ withExclusiveLock :: -> m a withExclusiveLock redis lp ref action = do exclusiveLockAcquire redis lp ref >>= \case - Nothing -> throwM Redis.LockAcquireTimeout + Nothing -> throwM LockAcquireTimeout Just ourId -> action `finally` exclusiveLockRelease redis ref ourId -- | Acquire a distributed exclusive lock. @@ -260,7 +267,7 @@ withShareableLock -> m a withShareableLock redis slp lockSharing ref action = shareableLockAcquire redis slp lockSharing ref >>= \case - Nothing -> throwM Redis.LockAcquireTimeout + Nothing -> throwM LockAcquireTimeout Just ourId -> action `finally` shareableLockRelease redis slp ref lockSharing ourId From f0d2c77aab67996b4355316c069ec01044b2e72b Mon Sep 17 00:00:00 2001 From: Daan Rijks Date: Wed, 3 Apr 2024 11:34:19 +0200 Subject: [PATCH 3/3] Throw more informative exceptions when lock acquisition times out --- src/Database/Redis/Schema/Lock.hs | 74 +++++++++++++++++++++++-------- 1 file changed, 56 insertions(+), 18 deletions(-) diff --git a/src/Database/Redis/Schema/Lock.hs b/src/Database/Redis/Schema/Lock.hs index 2058e71..1a2399b 100644 --- a/src/Database/Redis/Schema/Lock.hs +++ b/src/Database/Redis/Schema/Lock.hs @@ -23,7 +23,8 @@ module Database.Redis.Schema.Lock , defaultMetaParams , ExclusiveLock, withExclusiveLock , ShareableLock, withShareableLock, LockSharing(..) - , LockAcquireTimeout(..) + , ExclusiveLockAcquireTimeout(..) + , ShareableLockAcquireTimeout(..) ) where @@ -47,23 +48,42 @@ import Control.Monad.IO.Class ( liftIO, MonadIO ) import qualified Database.Redis.Schema as Redis -data LockAcquireTimeout = LockAcquireTimeout - deriving (Show) +data ExclusiveLockAcquireTimeout = ExclusiveLockAcquireTimeout + { elatRefIdentifier :: Redis.SimpleValueIdentifier + , elatLockParams :: LockParams + , elatOurId :: LockOwnerId + } + deriving stock (Show) + +instance Exception ExclusiveLockAcquireTimeout + +data ShareableLockAcquireTimeout = ShareableLockAcquireTimeout + { slatRefIdentifier :: ByteString + , slatLockParams :: ShareableLockParams + , slatSharing :: LockSharing + , slatOurId :: LockOwnerId + } + deriving stock (Show) -instance Exception LockAcquireTimeout +instance Exception ShareableLockAcquireTimeout data LockParams = LockParams { lpMeanRetryInterval :: NominalDiffTime , lpAcquireTimeout :: NominalDiffTime , lpLockTTL :: Redis.TTL } + deriving stock (Show) -- | ID of the process that owns the Redis lock. newtype LockOwnerId = LockOwnerId { _unLockOwnerId :: ByteString } + deriving stock (Show) deriving newtype (Eq, Ord, Redis.Serializable) instance Redis.Value inst LockOwnerId instance Redis.SimpleValue inst LockOwnerId +data AcquireResult = Acquired | AcquireTimeout + deriving stock (Show) + -------------------- -- Exclusive lock -- -------------------- @@ -89,6 +109,9 @@ instance Redis.SimpleValue inst ExclusiveLock -- -- * For exclusive locks, 'withExclusiveLock' is more efficient. -- +-- This throws 'ExclusiveLockAcquireTimeout' if we fail to acquire the lock before the +-- timeout specified in the 'LockParams'. +-- withExclusiveLock :: ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock @@ -99,9 +122,14 @@ withExclusiveLock :: -> m a -- ^ The action to perform under lock -> m a withExclusiveLock redis lp ref action = do - exclusiveLockAcquire redis lp ref >>= \case - Nothing -> throwM LockAcquireTimeout - Just ourId -> action `finally` exclusiveLockRelease redis ref ourId + (result, ourId) <- exclusiveLockAcquire redis lp ref + case result of + AcquireTimeout -> throwM ExclusiveLockAcquireTimeout + { elatRefIdentifier = Redis.toIdentifier ref + , elatLockParams = lp + , elatOurId = ourId + } + Acquired -> action `finally` exclusiveLockRelease redis ref ourId -- | Acquire a distributed exclusive lock. -- Returns Nothing on timeout. Otherwise it returns the unique client ID used for the lock. @@ -109,7 +137,7 @@ exclusiveLockAcquire :: ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock ) - => Redis.Pool (Redis.RefInstance ref) -> LockParams -> ref -> m (Maybe LockOwnerId) + => Redis.Pool (Redis.RefInstance ref) -> LockParams -> ref -> m (AcquireResult, LockOwnerId) exclusiveLockAcquire redis lp ref = do -- this is unique only if we have only one instance of HConductor running ourId <- LockOwnerId . BS.pack . show <$> liftIO myThreadId -- unique client id @@ -117,13 +145,13 @@ exclusiveLockAcquire redis lp ref = do fix $ \ ~retry -> do -- ~ makes the lambda lazy tsNow <- liftIO getCurrentTime if tsNow >= tsDeadline - then return Nothing -- didn't manage to acquire the lock before timeout + then return (AcquireTimeout, ourId) -- didn't manage to acquire the lock before timeout else do -- set the lock if it does not exist didNotExist <- Redis.run redis $ Redis.setIfNotExistsTTL ref (ExclusiveLock ourId) (lpLockTTL lp) if didNotExist - then return (Just ourId) -- everything went well + then return (Acquired, ourId) -- everything went well else do -- someone got there first; wait a bit and try again fuzzySleep (lpMeanRetryInterval lp) @@ -232,6 +260,7 @@ data ShareableLockParams = ShareableLockParams { slpParams :: LockParams , slpMetaParams :: LockParams } + deriving (Show) defaultMetaParams :: LockParams defaultMetaParams = LockParams @@ -251,6 +280,9 @@ defaultMetaParams = LockParams -- -- * For exclusive locks, withExclusiveLock is more efficient. -- +-- This throws 'ShareableLockAcquireTimeout' if we fail to acquire the lock before the +-- timeout specified in the 'ShareableLockParams'. +-- -- NOTE: the shareable lock seems to have quite a lot of performance overhead. -- Always benchmark first whether the exclusive lock would perform better in your scenario, -- even when a shareable lock would be sufficient in theory. @@ -265,18 +297,24 @@ withShareableLock -> ref -- ^ Lock ref -> m a -- ^ The action to perform under lock -> m a -withShareableLock redis slp lockSharing ref action = - shareableLockAcquire redis slp lockSharing ref >>= \case - Nothing -> throwM LockAcquireTimeout - Just ourId -> action - `finally` shareableLockRelease redis slp ref lockSharing ourId +withShareableLock redis slp lockSharing ref action = do + (result, ourId) <- shareableLockAcquire redis slp lockSharing ref + case result of + AcquireTimeout -> throwM ShareableLockAcquireTimeout + { slatRefIdentifier = Redis.toIdentifier ref + , slatLockParams = slp + , slatSharing = lockSharing + , slatOurId = ourId + } + Acquired -> + action `finally` shareableLockRelease redis slp ref lockSharing ourId shareableLockAcquire :: forall m ref. ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m , Redis.Ref ref, Redis.ValueType ref ~ ShareableLock , Redis.SimpleValue (Redis.RefInstance ref) (MetaLock ref) - ) => Redis.Pool (Redis.RefInstance ref) -> ShareableLockParams -> LockSharing -> ref -> m (Maybe LockOwnerId) + ) => Redis.Pool (Redis.RefInstance ref) -> ShareableLockParams -> LockSharing -> ref -> m (AcquireResult, LockOwnerId) shareableLockAcquire redis slp lockSharing ref = do -- this is unique only if we have only one instance of HConductor running ourId <- LockOwnerId . BS.pack . show <$> liftIO myThreadId -- unique client id @@ -284,7 +322,7 @@ shareableLockAcquire redis slp lockSharing ref = do fix $ \ ~retry -> do -- ~ makes the lambda lazy tsNow <- liftIO getCurrentTime if tsNow >= tsDeadline - then return Nothing -- didn't manage to acquire the lock before timeout + then return (AcquireTimeout, ourId) -- didn't manage to acquire the lock before timeout else do -- acquire the lock if possible, using the meta lock to synchronise access success <- withExclusiveLock redis (slpMetaParams slp) (MetaLock ref) $ @@ -311,7 +349,7 @@ shareableLockAcquire redis slp lockSharing ref = do then do -- everything went well, set ttl and return Redis.run redis $ Redis.setTTL ref (lpLockTTL $ slpParams slp) - return (Just ourId) + return (Acquired, ourId) else do -- someone got there first; wait a bit and try again fuzzySleep $ lpMeanRetryInterval (slpParams slp)