{-# LANGUAGE Strict #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Database.Redis.Schema.Lock
  ( LockParams(..), ShareableLockParams(..)
  , defaultMetaParams
  , ExclusiveLock, withExclusiveLock
  , ShareableLock, withShareableLock, LockSharing(..)
  )
  where

import GHC.Generics
import Data.Functor     ( void )
import Data.Kind        ( Type )
import Data.Maybe       ( fromMaybe )
import Data.Time        ( NominalDiffTime, addUTCTime, getCurrentTime )
import Data.Set         ( Set )
import Data.ByteString  ( ByteString )
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS

import System.Random    ( randomIO )

import Control.Concurrent  ( threadDelay, myThreadId )
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 LockParams = LockParams
  { LockParams -> NominalDiffTime
lpMeanRetryInterval :: NominalDiffTime
  , LockParams -> NominalDiffTime
lpAcquireTimeout    :: NominalDiffTime
  , LockParams -> TTL
lpLockTTL           :: Redis.TTL
  }

-- | ID of the process that owns the Redis lock.
newtype LockOwnerId = LockOwnerId { LockOwnerId -> ByteString
_unLockOwnerId :: ByteString }
  deriving newtype (LockOwnerId -> LockOwnerId -> Bool
(LockOwnerId -> LockOwnerId -> Bool)
-> (LockOwnerId -> LockOwnerId -> Bool) -> Eq LockOwnerId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LockOwnerId -> LockOwnerId -> Bool
$c/= :: LockOwnerId -> LockOwnerId -> Bool
== :: LockOwnerId -> LockOwnerId -> Bool
$c== :: LockOwnerId -> LockOwnerId -> Bool
Eq, Eq LockOwnerId
Eq LockOwnerId
-> (LockOwnerId -> LockOwnerId -> Ordering)
-> (LockOwnerId -> LockOwnerId -> Bool)
-> (LockOwnerId -> LockOwnerId -> Bool)
-> (LockOwnerId -> LockOwnerId -> Bool)
-> (LockOwnerId -> LockOwnerId -> Bool)
-> (LockOwnerId -> LockOwnerId -> LockOwnerId)
-> (LockOwnerId -> LockOwnerId -> LockOwnerId)
-> Ord LockOwnerId
LockOwnerId -> LockOwnerId -> Bool
LockOwnerId -> LockOwnerId -> Ordering
LockOwnerId -> LockOwnerId -> LockOwnerId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LockOwnerId -> LockOwnerId -> LockOwnerId
$cmin :: LockOwnerId -> LockOwnerId -> LockOwnerId
max :: LockOwnerId -> LockOwnerId -> LockOwnerId
$cmax :: LockOwnerId -> LockOwnerId -> LockOwnerId
>= :: LockOwnerId -> LockOwnerId -> Bool
$c>= :: LockOwnerId -> LockOwnerId -> Bool
> :: LockOwnerId -> LockOwnerId -> Bool
$c> :: LockOwnerId -> LockOwnerId -> Bool
<= :: LockOwnerId -> LockOwnerId -> Bool
$c<= :: LockOwnerId -> LockOwnerId -> Bool
< :: LockOwnerId -> LockOwnerId -> Bool
$c< :: LockOwnerId -> LockOwnerId -> Bool
compare :: LockOwnerId -> LockOwnerId -> Ordering
$ccompare :: LockOwnerId -> LockOwnerId -> Ordering
$cp1Ord :: Eq LockOwnerId
Ord, ByteString -> Maybe LockOwnerId
LockOwnerId -> ByteString
(ByteString -> Maybe LockOwnerId)
-> (LockOwnerId -> ByteString) -> Serializable LockOwnerId
forall val.
(ByteString -> Maybe val)
-> (val -> ByteString) -> Serializable val
toBS :: LockOwnerId -> ByteString
$ctoBS :: LockOwnerId -> ByteString
fromBS :: ByteString -> Maybe LockOwnerId
$cfromBS :: ByteString -> Maybe LockOwnerId
Redis.Serializable)
instance Redis.Value inst LockOwnerId
instance Redis.SimpleValue inst LockOwnerId

--------------------
-- Exclusive lock --
--------------------

-- | Redis value representing the exclusive lock.
newtype ExclusiveLock = ExclusiveLock
  { ExclusiveLock -> LockOwnerId
_elOwnerId :: LockOwnerId
  }
  deriving newtype (ExclusiveLock -> ExclusiveLock -> Bool
(ExclusiveLock -> ExclusiveLock -> Bool)
-> (ExclusiveLock -> ExclusiveLock -> Bool) -> Eq ExclusiveLock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExclusiveLock -> ExclusiveLock -> Bool
$c/= :: ExclusiveLock -> ExclusiveLock -> Bool
== :: ExclusiveLock -> ExclusiveLock -> Bool
$c== :: ExclusiveLock -> ExclusiveLock -> Bool
Eq, ByteString -> Maybe ExclusiveLock
ExclusiveLock -> ByteString
(ByteString -> Maybe ExclusiveLock)
-> (ExclusiveLock -> ByteString) -> Serializable ExclusiveLock
forall val.
(ByteString -> Maybe val)
-> (val -> ByteString) -> Serializable val
toBS :: ExclusiveLock -> ByteString
$ctoBS :: ExclusiveLock -> ByteString
fromBS :: ByteString -> Maybe ExclusiveLock
$cfromBS :: ByteString -> Maybe ExclusiveLock
Redis.Serializable)
instance Redis.Value inst ExclusiveLock
instance Redis.SimpleValue inst ExclusiveLock

-- | Execute the given action in an exclusively locked context.
--
-- This is useful mainly for operations that need to be atomic
-- while manipulating *both* Redis and database (such as various commit scripts).
--
-- * For Redis-only transactions, use 'Redis.atomically'.
--
-- * For database-only transactions, use database transactions.
--
-- * For shareable locks, use 'withShareableLock'.
--
-- * For exclusive locks, 'withExclusiveLock' is more efficient.
--
withExclusiveLock ::
  ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m
  , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock
  )
  => Redis.Pool (Redis.RefInstance ref)
  -> LockParams  -- ^ Params of the lock, such as timeouts or TTL.
  -> ref         -- ^ Lock ref
  -> m a         -- ^ The action to perform under lock
  -> m a
withExclusiveLock :: Pool (RefInstance ref) -> LockParams -> ref -> m a -> m a
withExclusiveLock Pool (RefInstance ref)
redis LockParams
lp ref
ref m a
action = do
  Pool (RefInstance ref)
-> LockParams -> ref -> m (Maybe LockOwnerId)
forall (m :: * -> *) ref.
(MonadCatch m, MonadThrow m, MonadMask m, MonadIO m, Ref ref,
 ValueType ref ~ ExclusiveLock) =>
Pool (RefInstance ref)
-> LockParams -> ref -> m (Maybe LockOwnerId)
exclusiveLockAcquire Pool (RefInstance ref)
redis LockParams
lp ref
ref m (Maybe LockOwnerId) -> (Maybe LockOwnerId -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe LockOwnerId
Nothing -> RedisException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM RedisException
Redis.LockAcquireTimeout
    Just LockOwnerId
ourId -> m a
action m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` Pool (RefInstance ref) -> ref -> LockOwnerId -> m ()
forall (m :: * -> *) ref.
(MonadCatch m, MonadThrow m, MonadMask m, MonadIO m, Ref ref,
 ValueType ref ~ ExclusiveLock) =>
Pool (RefInstance ref) -> ref -> LockOwnerId -> m ()
exclusiveLockRelease Pool (RefInstance ref)
redis ref
ref LockOwnerId
ourId

-- | Acquire a distributed exclusive lock.
-- Returns Nothing on timeout. Otherwise it returns the unique client ID used for the lock.
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)
exclusiveLockAcquire :: Pool (RefInstance ref)
-> LockParams -> ref -> m (Maybe LockOwnerId)
exclusiveLockAcquire Pool (RefInstance ref)
redis LockParams
lp ref
ref = do
  -- this is unique only if we have only one instance of HConductor running
  LockOwnerId
ourId <- ByteString -> LockOwnerId
LockOwnerId (ByteString -> LockOwnerId)
-> (ThreadId -> ByteString) -> ThreadId -> LockOwnerId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> ByteString)
-> (ThreadId -> String) -> ThreadId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> String
forall a. Show a => a -> String
show (ThreadId -> LockOwnerId) -> m ThreadId -> m LockOwnerId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId  -- unique client id
  UTCTime
tsDeadline <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (LockParams -> NominalDiffTime
lpAcquireTimeout LockParams
lp) (UTCTime -> UTCTime) -> m UTCTime -> m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  (m (Maybe LockOwnerId) -> m (Maybe LockOwnerId))
-> m (Maybe LockOwnerId)
forall a. (a -> a) -> a
fix ((m (Maybe LockOwnerId) -> m (Maybe LockOwnerId))
 -> m (Maybe LockOwnerId))
-> (m (Maybe LockOwnerId) -> m (Maybe LockOwnerId))
-> m (Maybe LockOwnerId)
forall a b. (a -> b) -> a -> b
$ \ ~m (Maybe LockOwnerId)
retry -> do  -- ~ makes the lambda lazy
    UTCTime
tsNow <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    if UTCTime
tsNow UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
tsDeadline
      then Maybe LockOwnerId -> m (Maybe LockOwnerId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LockOwnerId
forall a. Maybe a
Nothing  -- didn't manage to acquire the lock before timeout
      else do
        -- set the lock if it does not exist
        Bool
didNotExist <- Pool (RefInstance ref) -> RedisM (RefInstance ref) Bool -> m Bool
forall k (m :: * -> *) (inst :: k) a.
MonadIO m =>
Pool inst -> RedisM inst a -> m a
Redis.run Pool (RefInstance ref)
redis (RedisM (RefInstance ref) Bool -> m Bool)
-> RedisM (RefInstance ref) Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
          ref -> ValueType ref -> TTL -> RedisM (RefInstance ref) Bool
forall ref.
SimpleRef ref =>
ref -> ValueType ref -> TTL -> RedisM (RefInstance ref) Bool
Redis.setIfNotExistsTTL ref
ref (LockOwnerId -> ExclusiveLock
ExclusiveLock LockOwnerId
ourId) (LockParams -> TTL
lpLockTTL LockParams
lp)
        if Bool
didNotExist
          then Maybe LockOwnerId -> m (Maybe LockOwnerId)
forall (m :: * -> *) a. Monad m => a -> m a
return (LockOwnerId -> Maybe LockOwnerId
forall a. a -> Maybe a
Just LockOwnerId
ourId)  -- everything went well
          else do
            -- someone got there first; wait a bit and try again
            NominalDiffTime -> m ()
forall (m :: * -> *). MonadIO m => NominalDiffTime -> m ()
fuzzySleep (LockParams -> NominalDiffTime
lpMeanRetryInterval LockParams
lp)
            m (Maybe LockOwnerId)
retry

exclusiveLockRelease ::
  ( MonadCatch m, MonadThrow m, MonadMask m, MonadIO m
  , Redis.Ref ref, Redis.ValueType ref ~ ExclusiveLock
  )
  => Redis.Pool (Redis.RefInstance ref) -> ref -> LockOwnerId -> m ()
exclusiveLockRelease :: Pool (RefInstance ref) -> ref -> LockOwnerId -> m ()
exclusiveLockRelease Pool (RefInstance ref)
redis ref
ref LockOwnerId
ourId =
  -- While we were locked, the lock could have expired
  -- and someone else could have acquired the lock in the meantime.
  --
  -- To avoid deleting someone else's lock, we need to check if it's ours.
  m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Pool (RefInstance ref) -> RedisM (RefInstance ref) Bool -> m Bool
forall k (m :: * -> *) (inst :: k) a.
MonadIO m =>
Pool inst -> RedisM inst a -> m a
Redis.run Pool (RefInstance ref)
redis
      (RedisM (RefInstance ref) Bool -> m Bool)
-> RedisM (RefInstance ref) Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ref -> ValueType ref -> RedisM (RefInstance ref) Bool
forall ref.
SimpleRef ref =>
ref -> ValueType ref -> RedisM (RefInstance ref) Bool
Redis.deleteIfEqual ref
ref (LockOwnerId -> ExclusiveLock
ExclusiveLock LockOwnerId
ourId)


--------------------
-- Shareable lock --
--------------------

data LockSharing
  = Shared
  | Exclusive
  deriving (LockSharing -> LockSharing -> Bool
(LockSharing -> LockSharing -> Bool)
-> (LockSharing -> LockSharing -> Bool) -> Eq LockSharing
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LockSharing -> LockSharing -> Bool
$c/= :: LockSharing -> LockSharing -> Bool
== :: LockSharing -> LockSharing -> Bool
$c== :: LockSharing -> LockSharing -> Bool
Eq, Eq LockSharing
Eq LockSharing
-> (LockSharing -> LockSharing -> Ordering)
-> (LockSharing -> LockSharing -> Bool)
-> (LockSharing -> LockSharing -> Bool)
-> (LockSharing -> LockSharing -> Bool)
-> (LockSharing -> LockSharing -> Bool)
-> (LockSharing -> LockSharing -> LockSharing)
-> (LockSharing -> LockSharing -> LockSharing)
-> Ord LockSharing
LockSharing -> LockSharing -> Bool
LockSharing -> LockSharing -> Ordering
LockSharing -> LockSharing -> LockSharing
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LockSharing -> LockSharing -> LockSharing
$cmin :: LockSharing -> LockSharing -> LockSharing
max :: LockSharing -> LockSharing -> LockSharing
$cmax :: LockSharing -> LockSharing -> LockSharing
>= :: LockSharing -> LockSharing -> Bool
$c>= :: LockSharing -> LockSharing -> Bool
> :: LockSharing -> LockSharing -> Bool
$c> :: LockSharing -> LockSharing -> Bool
<= :: LockSharing -> LockSharing -> Bool
$c<= :: LockSharing -> LockSharing -> Bool
< :: LockSharing -> LockSharing -> Bool
$c< :: LockSharing -> LockSharing -> Bool
compare :: LockSharing -> LockSharing -> Ordering
$ccompare :: LockSharing -> LockSharing -> Ordering
$cp1Ord :: Eq LockSharing
Ord, Int -> LockSharing -> ShowS
[LockSharing] -> ShowS
LockSharing -> String
(Int -> LockSharing -> ShowS)
-> (LockSharing -> String)
-> ([LockSharing] -> ShowS)
-> Show LockSharing
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LockSharing] -> ShowS
$cshowList :: [LockSharing] -> ShowS
show :: LockSharing -> String
$cshow :: LockSharing -> String
showsPrec :: Int -> LockSharing -> ShowS
$cshowsPrec :: Int -> LockSharing -> ShowS
Show, ReadPrec [LockSharing]
ReadPrec LockSharing
Int -> ReadS LockSharing
ReadS [LockSharing]
(Int -> ReadS LockSharing)
-> ReadS [LockSharing]
-> ReadPrec LockSharing
-> ReadPrec [LockSharing]
-> Read LockSharing
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LockSharing]
$creadListPrec :: ReadPrec [LockSharing]
readPrec :: ReadPrec LockSharing
$creadPrec :: ReadPrec LockSharing
readList :: ReadS [LockSharing]
$creadList :: ReadS [LockSharing]
readsPrec :: Int -> ReadS LockSharing
$creadsPrec :: Int -> ReadS LockSharing
Read, (forall x. LockSharing -> Rep LockSharing x)
-> (forall x. Rep LockSharing x -> LockSharing)
-> Generic LockSharing
forall x. Rep LockSharing x -> LockSharing
forall x. LockSharing -> Rep LockSharing x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LockSharing x -> LockSharing
$cfrom :: forall x. LockSharing -> Rep LockSharing x
Generic)
instance Redis.Value inst LockSharing
instance Redis.Serializable LockSharing where
  toBS :: LockSharing -> ByteString
toBS LockSharing
Shared = ByteString
"shared"
  toBS LockSharing
Exclusive = ByteString
"exclusive"
  fromBS :: ByteString -> Maybe LockSharing
fromBS ByteString
"shared" = LockSharing -> Maybe LockSharing
forall a. a -> Maybe a
Just LockSharing
Shared
  fromBS ByteString
"exclusive" = LockSharing -> Maybe LockSharing
forall a. a -> Maybe a
Just LockSharing
Exclusive
  fromBS ByteString
_ = Maybe LockSharing
forall a. Maybe a
Nothing
instance Redis.SimpleValue inst LockSharing

data LockFieldName :: Type -> Type where
  LockFieldSharing :: LockFieldName LockSharing
  LockFieldOwners  :: LockFieldName (Set LockOwnerId)

-- Ref that points to the components of a shareable lock.
data LockField :: Type -> Type -> Type where
  LockField :: ByteString -> LockFieldName ty -> LockField inst ty

instance Redis.Value inst ty => Redis.Ref (LockField inst ty) where
  type ValueType (LockField inst ty) = ty
  type RefInstance (LockField inst ty) = inst
  toIdentifier :: LockField inst ty -> Identifier (ValueType (LockField inst ty))
toIdentifier (LockField ByteString
lockSlugBS LockFieldName ty
LockFieldSharing) = ByteString -> SimpleValueIdentifier
Redis.SviTopLevel
    (ByteString -> SimpleValueIdentifier)
-> ByteString -> SimpleValueIdentifier
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
Redis.colonSep [ ByteString
"lock", ByteString
lockSlugBS, ByteString
"sharing"]
  toIdentifier (LockField ByteString
lockSlugBS LockFieldName ty
LockFieldOwners) =
    [ByteString] -> ByteString
Redis.colonSep [ ByteString
"lock", ByteString
lockSlugBS, ByteString
"owners"]

-- Ref that points to the meta lock of the shareable lock.
-- A meta lock is always an exclusive lock
-- and it synchronises the access to the components of the shareable lock.
newtype MetaLock ref = MetaLock ref

instance (Redis.Ref ref, Redis.ValueType ref ~ ShareableLock)
  => Redis.Ref (MetaLock ref) where

  type ValueType (MetaLock ref) = ExclusiveLock
  type RefInstance (MetaLock ref) = Redis.RefInstance ref

  toIdentifier :: MetaLock ref -> Identifier (ValueType (MetaLock ref))
toIdentifier (MetaLock ref
ref) = ByteString -> SimpleValueIdentifier
Redis.SviTopLevel (ByteString -> SimpleValueIdentifier)
-> ByteString -> SimpleValueIdentifier
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
Redis.colonSep
    [ ByteString
"lock"
    , ref -> Identifier (ValueType ref)
forall ref. Ref ref => ref -> Identifier (ValueType ref)
Redis.toIdentifier ref
ref
    , ByteString
"meta"
    ]

data ShareableLock = ShareableLock
  { ShareableLock -> LockSharing
lockSharing :: LockSharing
  , ShareableLock -> Set LockOwnerId
lockOwners  :: Set LockOwnerId
  }

instance Redis.Value inst ShareableLock where
  type Identifier ShareableLock = ByteString

  txValGet :: Identifier ShareableLock -> Tx inst (Maybe ShareableLock)
txValGet Identifier ShareableLock
slugBS = do
    Maybe LockSharing
mbSharing <- LockField inst LockSharing
-> Tx
     (RefInstance (LockField inst LockSharing))
     (Maybe (ValueType (LockField inst LockSharing)))
forall ref.
Ref ref =>
ref -> Tx (RefInstance ref) (Maybe (ValueType ref))
Redis.txGet (ByteString
-> LockFieldName LockSharing -> LockField inst LockSharing
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName LockSharing
LockFieldSharing)
    Maybe (Set LockOwnerId)
mbOwners  <- LockField inst (Set LockOwnerId)
-> Tx
     (RefInstance (LockField inst (Set LockOwnerId)))
     (Maybe (ValueType (LockField inst (Set LockOwnerId))))
forall ref.
Ref ref =>
ref -> Tx (RefInstance ref) (Maybe (ValueType ref))
Redis.txGet (ByteString
-> LockFieldName (Set LockOwnerId)
-> LockField inst (Set LockOwnerId)
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName (Set LockOwnerId)
LockFieldOwners)
    pure $ case Maybe LockSharing
mbSharing of
      Maybe LockSharing
Nothing -> Maybe ShareableLock
forall a. Maybe a
Nothing  -- lock does not exist
      Just LockSharing
lockSharing -> ShareableLock -> Maybe ShareableLock
forall a. a -> Maybe a
Just
        (ShareableLock -> Maybe ShareableLock)
-> ShareableLock -> Maybe ShareableLock
forall a b. (a -> b) -> a -> b
$ LockSharing -> Set LockOwnerId -> ShareableLock
ShareableLock LockSharing
lockSharing (Set LockOwnerId -> Maybe (Set LockOwnerId) -> Set LockOwnerId
forall a. a -> Maybe a -> a
fromMaybe Set LockOwnerId
forall a. Set a
Set.empty Maybe (Set LockOwnerId)
mbOwners)

  txValSet :: Identifier ShareableLock -> ShareableLock -> Tx inst ()
txValSet Identifier ShareableLock
slugBS ShareableLock
lock =
    LockField inst LockSharing
-> ValueType (LockField inst LockSharing)
-> Tx (RefInstance (LockField inst LockSharing)) ()
forall ref.
Ref ref =>
ref -> ValueType ref -> Tx (RefInstance ref) ()
Redis.txSet (ByteString
-> LockFieldName LockSharing -> LockField inst LockSharing
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName LockSharing
LockFieldSharing) (ShareableLock -> LockSharing
lockSharing ShareableLock
lock)
    Tx inst () -> Tx inst () -> Tx inst ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LockField inst (Set LockOwnerId)
-> ValueType (LockField inst (Set LockOwnerId))
-> Tx (RefInstance (LockField inst (Set LockOwnerId))) ()
forall ref.
Ref ref =>
ref -> ValueType ref -> Tx (RefInstance ref) ()
Redis.txSet (ByteString
-> LockFieldName (Set LockOwnerId)
-> LockField inst (Set LockOwnerId)
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName (Set LockOwnerId)
LockFieldOwners) (ShareableLock -> Set LockOwnerId
lockOwners ShareableLock
lock)

  txValDelete :: Identifier ShareableLock -> Tx inst ()
txValDelete Identifier ShareableLock
slugBS =
    LockField inst LockSharing
-> Tx (RefInstance (LockField inst LockSharing)) ()
forall ref. Ref ref => ref -> Tx (RefInstance ref) ()
Redis.txDelete_ (ByteString
-> LockFieldName LockSharing -> LockField inst LockSharing
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName LockSharing
LockFieldSharing)
    Tx inst () -> Tx inst () -> Tx inst ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LockField inst (Set LockOwnerId)
-> Tx (RefInstance (LockField inst (Set LockOwnerId))) ()
forall ref. Ref ref => ref -> Tx (RefInstance ref) ()
Redis.txDelete_ (ByteString
-> LockFieldName (Set LockOwnerId)
-> LockField inst (Set LockOwnerId)
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName (Set LockOwnerId)
LockFieldOwners)

  txValSetTTLIfExists :: Identifier ShareableLock -> TTL -> Tx inst Bool
txValSetTTLIfExists Identifier ShareableLock
slugBS TTL
ttl = Bool -> Bool -> Bool
(||)
    (Bool -> Bool -> Bool) -> Tx inst Bool -> Tx inst (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LockField inst LockSharing
-> TTL -> Tx (RefInstance (LockField inst LockSharing)) Bool
forall ref. Ref ref => ref -> TTL -> Tx (RefInstance ref) Bool
Redis.txSetTTLIfExists (ByteString
-> LockFieldName LockSharing -> LockField inst LockSharing
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName LockSharing
LockFieldSharing) TTL
ttl
    Tx inst (Bool -> Bool) -> Tx inst Bool -> Tx inst Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LockField inst (Set LockOwnerId)
-> TTL -> Tx (RefInstance (LockField inst (Set LockOwnerId))) Bool
forall ref. Ref ref => ref -> TTL -> Tx (RefInstance ref) Bool
Redis.txSetTTLIfExists (ByteString
-> LockFieldName (Set LockOwnerId)
-> LockField inst (Set LockOwnerId)
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField ByteString
Identifier ShareableLock
slugBS LockFieldName (Set LockOwnerId)
LockFieldOwners) TTL
ttl

  valGet :: Identifier ShareableLock -> RedisM inst (Maybe ShareableLock)
valGet Identifier ShareableLock
slugBS = Tx inst (Maybe ShareableLock) -> RedisM inst (Maybe ShareableLock)
forall k (inst :: k) a. Tx inst a -> RedisM inst a
Redis.atomically (Tx inst (Maybe ShareableLock)
 -> RedisM inst (Maybe ShareableLock))
-> Tx inst (Maybe ShareableLock)
-> RedisM inst (Maybe ShareableLock)
forall a b. (a -> b) -> a -> b
$ Identifier ShareableLock -> Tx inst (Maybe ShareableLock)
forall k (inst :: k) val.
Value inst val =>
Identifier val -> Tx inst (Maybe val)
Redis.txValGet Identifier ShareableLock
slugBS
  valSet :: Identifier ShareableLock -> ShareableLock -> RedisM inst ()
valSet Identifier ShareableLock
slugBS ShareableLock
val = Tx inst () -> RedisM inst ()
forall k (inst :: k) a. Tx inst a -> RedisM inst a
Redis.atomically (Tx inst () -> RedisM inst ()) -> Tx inst () -> RedisM inst ()
forall a b. (a -> b) -> a -> b
$ Identifier ShareableLock -> ShareableLock -> Tx inst ()
forall k (inst :: k) val.
Value inst val =>
Identifier val -> val -> Tx inst ()
Redis.txValSet Identifier ShareableLock
slugBS ShareableLock
val
  valDelete :: Identifier ShareableLock -> RedisM inst ()
valDelete Identifier ShareableLock
slugBS = Tx inst () -> RedisM inst ()
forall k (inst :: k) a. Tx inst a -> RedisM inst a
Redis.atomically (Tx inst () -> RedisM inst ()) -> Tx inst () -> RedisM inst ()
forall a b. (a -> b) -> a -> b
$ Identifier ShareableLock -> Tx inst ()
forall k (inst :: k) val.
Value inst val =>
Identifier val -> Tx inst ()
Redis.txValDelete @inst @ShareableLock Identifier ShareableLock
slugBS
  valSetTTLIfExists :: Identifier ShareableLock -> TTL -> RedisM inst Bool
valSetTTLIfExists Identifier ShareableLock
slugBS TTL
ttl = Tx inst Bool -> RedisM inst Bool
forall k (inst :: k) a. Tx inst a -> RedisM inst a
Redis.atomically
    (Tx inst Bool -> RedisM inst Bool)
-> Tx inst Bool -> RedisM inst Bool
forall a b. (a -> b) -> a -> b
$ Identifier ShareableLock -> TTL -> Tx inst Bool
forall k (inst :: k) val.
Value inst val =>
Identifier val -> TTL -> Tx inst Bool
Redis.txValSetTTLIfExists @inst @ShareableLock Identifier ShareableLock
slugBS TTL
ttl

data ShareableLockParams = ShareableLockParams
  { ShareableLockParams -> LockParams
slpParams :: LockParams
  , ShareableLockParams -> LockParams
slpMetaParams :: LockParams
  }

defaultMetaParams :: LockParams
defaultMetaParams :: LockParams
defaultMetaParams = LockParams :: NominalDiffTime -> NominalDiffTime -> TTL -> LockParams
LockParams
  { lpMeanRetryInterval :: NominalDiffTime
lpMeanRetryInterval =  NominalDiffTime
50e-3
  , lpAcquireTimeout :: NominalDiffTime
lpAcquireTimeout    = NominalDiffTime
500e-3
  , lpLockTTL :: TTL
lpLockTTL           = TTL
2 TTL -> TTL -> TTL
forall a. Num a => a -> a -> a
* TTL
Redis.second
  }

-- | Execute the given action in a locked, possibly shared context.
--
-- This is useful mainly for operations that need to be atomic
-- while manipulating *both* Redis and database (such as various commit scripts).
--
-- * For Redis-only transactions, use 'atomically'.
--
-- * For database-only transactions, use database transactions.
--
-- * For exclusive locks, withExclusiveLock is more efficient.
--
-- 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.
withShareableLock
  :: ( 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  -- ^ Params of the lock, such as timeouts or TTL.
  -> LockSharing -- ^ Shared / Exclusive
  -> ref         -- ^ Lock ref
  -> m a         -- ^ The action to perform under lock
  -> m a
withShareableLock :: Pool (RefInstance ref)
-> ShareableLockParams -> LockSharing -> ref -> m a -> m a
withShareableLock Pool (RefInstance ref)
redis ShareableLockParams
slp LockSharing
lockSharing ref
ref m a
action =
  Pool (RefInstance ref)
-> ShareableLockParams
-> LockSharing
-> ref
-> m (Maybe LockOwnerId)
forall (m :: * -> *) ref.
(MonadCatch m, MonadThrow m, MonadMask m, MonadIO m, Ref ref,
 ValueType ref ~ ShareableLock,
 SimpleValue (RefInstance ref) (MetaLock ref)) =>
Pool (RefInstance ref)
-> ShareableLockParams
-> LockSharing
-> ref
-> m (Maybe LockOwnerId)
shareableLockAcquire Pool (RefInstance ref)
redis ShareableLockParams
slp LockSharing
lockSharing ref
ref m (Maybe LockOwnerId) -> (Maybe LockOwnerId -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe LockOwnerId
Nothing -> RedisException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM RedisException
Redis.LockAcquireTimeout
    Just LockOwnerId
ourId -> m a
action
      m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` Pool (RefInstance ref)
-> ShareableLockParams -> ref -> LockSharing -> LockOwnerId -> m ()
forall (m :: * -> *) ref.
(MonadCatch m, MonadThrow m, MonadMask m, MonadIO m, Ref ref,
 ValueType ref ~ ShareableLock,
 SimpleValue (RefInstance ref) (MetaLock ref)) =>
Pool (RefInstance ref)
-> ShareableLockParams -> ref -> LockSharing -> LockOwnerId -> m ()
shareableLockRelease Pool (RefInstance ref)
redis ShareableLockParams
slp ref
ref LockSharing
lockSharing LockOwnerId
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)
shareableLockAcquire :: Pool (RefInstance ref)
-> ShareableLockParams
-> LockSharing
-> ref
-> m (Maybe LockOwnerId)
shareableLockAcquire Pool (RefInstance ref)
redis ShareableLockParams
slp LockSharing
lockSharing ref
ref = do
  -- this is unique only if we have only one instance of HConductor running
  LockOwnerId
ourId <- ByteString -> LockOwnerId
LockOwnerId (ByteString -> LockOwnerId)
-> (ThreadId -> ByteString) -> ThreadId -> LockOwnerId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> ByteString)
-> (ThreadId -> String) -> ThreadId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> String
forall a. Show a => a -> String
show (ThreadId -> LockOwnerId) -> m ThreadId -> m LockOwnerId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId  -- unique client id
  UTCTime
tsDeadline <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (LockParams -> NominalDiffTime
lpAcquireTimeout (LockParams -> NominalDiffTime) -> LockParams -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ShareableLockParams -> LockParams
slpParams ShareableLockParams
slp) (UTCTime -> UTCTime) -> m UTCTime -> m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  (m (Maybe LockOwnerId) -> m (Maybe LockOwnerId))
-> m (Maybe LockOwnerId)
forall a. (a -> a) -> a
fix ((m (Maybe LockOwnerId) -> m (Maybe LockOwnerId))
 -> m (Maybe LockOwnerId))
-> (m (Maybe LockOwnerId) -> m (Maybe LockOwnerId))
-> m (Maybe LockOwnerId)
forall a b. (a -> b) -> a -> b
$ \ ~m (Maybe LockOwnerId)
retry -> do  -- ~ makes the lambda lazy
    UTCTime
tsNow <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    if UTCTime
tsNow UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
tsDeadline
      then Maybe LockOwnerId -> m (Maybe LockOwnerId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LockOwnerId
forall a. Maybe a
Nothing  -- didn't manage to acquire the lock before timeout
      else do
        -- acquire the lock if possible, using the meta lock to synchronise access
        Bool
success <- Pool (RefInstance (MetaLock ref))
-> LockParams -> MetaLock ref -> m Bool -> m Bool
forall (m :: * -> *) ref a.
(MonadCatch m, MonadThrow m, MonadMask m, MonadIO m, Ref ref,
 ValueType ref ~ ExclusiveLock) =>
Pool (RefInstance ref) -> LockParams -> ref -> m a -> m a
withExclusiveLock Pool (RefInstance ref)
Pool (RefInstance (MetaLock ref))
redis (ShareableLockParams -> LockParams
slpMetaParams ShareableLockParams
slp) (ref -> MetaLock ref
forall ref. ref -> MetaLock ref
MetaLock ref
ref) (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
          Pool (RefInstance ref) -> RedisM (RefInstance ref) Bool -> m Bool
forall k (m :: * -> *) (inst :: k) a.
MonadIO m =>
Pool inst -> RedisM inst a -> m a
Redis.run Pool (RefInstance ref)
redis (RedisM (RefInstance ref) Bool -> m Bool)
-> RedisM (RefInstance ref) Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
            -- get just the sharing flag
            -- avoid getting the list of all owners
            LockField (RefInstance ref) LockSharing
-> RedisM
     (RefInstance (LockField (RefInstance ref) LockSharing))
     (Maybe (ValueType (LockField (RefInstance ref) LockSharing)))
forall ref.
Ref ref =>
ref -> RedisM (RefInstance ref) (Maybe (ValueType ref))
Redis.get (LockFieldName LockSharing
-> LockField (RefInstance ref) LockSharing
forall ty. LockFieldName ty -> LockField (RefInstance ref) ty
lockField LockFieldName LockSharing
LockFieldSharing) RedisM (RefInstance ref) (Maybe LockSharing)
-> (Maybe LockSharing -> RedisM (RefInstance ref) Bool)
-> RedisM (RefInstance ref) Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              -- no lock, just acquire it
              Maybe LockSharing
Nothing -> do
                ref -> ValueType ref -> RedisM (RefInstance ref) ()
forall ref.
Ref ref =>
ref -> ValueType ref -> RedisM (RefInstance ref) ()
Redis.set ref
ref (ValueType ref -> RedisM (RefInstance ref) ())
-> ValueType ref -> RedisM (RefInstance ref) ()
forall a b. (a -> b) -> a -> b
$ LockSharing -> Set LockOwnerId -> ShareableLock
ShareableLock LockSharing
lockSharing (LockOwnerId -> Set LockOwnerId
forall a. a -> Set a
Set.singleton LockOwnerId
ourId)
                return Bool
True

              -- lock is shareably acquired
              -- we want to share
              -- so we can acquire
              Just LockSharing
Shared | LockSharing
lockSharing LockSharing -> LockSharing -> Bool
forall a. Eq a => a -> a -> Bool
== LockSharing
Shared -> do
                LockField (RefInstance ref) (Set LockOwnerId)
-> [LockOwnerId]
-> RedisM
     (RefInstance (LockField (RefInstance ref) (Set LockOwnerId))) ()
forall ref a.
(Ref ref, ValueType ref ~ Set a, Serializable a) =>
ref -> [a] -> RedisM (RefInstance ref) ()
Redis.sInsert (LockFieldName (Set LockOwnerId)
-> LockField (RefInstance ref) (Set LockOwnerId)
forall ty. LockFieldName ty -> LockField (RefInstance ref) ty
lockField LockFieldName (Set LockOwnerId)
LockFieldOwners) [LockOwnerId
ourId]
                return Bool
True

              -- can't acquire lock otherwise
              Maybe LockSharing
_ -> Bool -> RedisM (RefInstance ref) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

        if Bool
success
          then do
            -- everything went well, set ttl and return
            Pool (RefInstance ref) -> RedisM (RefInstance ref) () -> m ()
forall k (m :: * -> *) (inst :: k) a.
MonadIO m =>
Pool inst -> RedisM inst a -> m a
Redis.run Pool (RefInstance ref)
redis (RedisM (RefInstance ref) () -> m ())
-> RedisM (RefInstance ref) () -> m ()
forall a b. (a -> b) -> a -> b
$ ref -> TTL -> RedisM (RefInstance ref) ()
forall ref. Ref ref => ref -> TTL -> RedisM (RefInstance ref) ()
Redis.setTTL ref
ref (LockParams -> TTL
lpLockTTL (LockParams -> TTL) -> LockParams -> TTL
forall a b. (a -> b) -> a -> b
$ ShareableLockParams -> LockParams
slpParams ShareableLockParams
slp)
            return (LockOwnerId -> Maybe LockOwnerId
forall a. a -> Maybe a
Just LockOwnerId
ourId)
          else do
            -- someone got there first; wait a bit and try again
            NominalDiffTime -> m ()
forall (m :: * -> *). MonadIO m => NominalDiffTime -> m ()
fuzzySleep (NominalDiffTime -> m ()) -> NominalDiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ LockParams -> NominalDiffTime
lpMeanRetryInterval (ShareableLockParams -> LockParams
slpParams ShareableLockParams
slp)
            m (Maybe LockOwnerId)
retry
  where
    lockField :: LockFieldName ty -> LockField (Redis.RefInstance ref) ty
    lockField :: LockFieldName ty -> LockField (RefInstance ref) ty
lockField = ByteString -> LockFieldName ty -> LockField (RefInstance ref) ty
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField (ref -> Identifier (ValueType ref)
forall ref. Ref ref => ref -> Identifier (ValueType ref)
Redis.toIdentifier ref
ref)

shareableLockRelease ::
  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 -> ref -> LockSharing -> LockOwnerId -> m ()
shareableLockRelease :: Pool (RefInstance ref)
-> ShareableLockParams -> ref -> LockSharing -> LockOwnerId -> m ()
shareableLockRelease Pool (RefInstance ref)
redis ShareableLockParams
slp ref
ref LockSharing
lockSharing LockOwnerId
ourId =
  Pool (RefInstance (MetaLock ref))
-> LockParams -> MetaLock ref -> m () -> m ()
forall (m :: * -> *) ref a.
(MonadCatch m, MonadThrow m, MonadMask m, MonadIO m, Ref ref,
 ValueType ref ~ ExclusiveLock) =>
Pool (RefInstance ref) -> LockParams -> ref -> m a -> m a
withExclusiveLock Pool (RefInstance ref)
Pool (RefInstance (MetaLock ref))
redis (ShareableLockParams -> LockParams
slpMetaParams ShareableLockParams
slp) (ref -> MetaLock ref
forall ref. ref -> MetaLock ref
MetaLock ref
ref) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Pool (RefInstance ref) -> RedisM (RefInstance ref) () -> m ()
forall k (m :: * -> *) (inst :: k) a.
MonadIO m =>
Pool inst -> RedisM inst a -> m a
Redis.run Pool (RefInstance ref)
redis (RedisM (RefInstance ref) () -> m ())
-> RedisM (RefInstance ref) () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- While we were locked, the lock could have expired
    -- and someone else could have acquired the lock in the meantime.
    --
    -- To avoid deleting someone else's lock, we need to check if it's ours.
    LockField (RefInstance ref) (Set LockOwnerId)
-> LockOwnerId
-> RedisM
     (RefInstance (LockField (RefInstance ref) (Set LockOwnerId))) Bool
forall ref a.
(Ref ref, ValueType ref ~ Set a, Serializable a) =>
ref -> a -> RedisM (RefInstance ref) Bool
Redis.sContains (LockFieldName (Set LockOwnerId)
-> LockField (RefInstance ref) (Set LockOwnerId)
forall ty. LockFieldName ty -> LockField (RefInstance ref) ty
lockField LockFieldName (Set LockOwnerId)
LockFieldOwners) LockOwnerId
ourId RedisM (RefInstance ref) Bool
-> (Bool -> RedisM (RefInstance ref) ())
-> RedisM (RefInstance ref) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> () -> RedisM (RefInstance ref) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()  -- lock is not ours, nothing to do here
      Bool
True -> case LockSharing
lockSharing of
        -- we can delete the lock without further exchange with Redis
        LockSharing
Exclusive -> ref -> RedisM (RefInstance ref) ()
forall ref. Ref ref => ref -> RedisM (RefInstance ref) ()
Redis.delete_ ref
ref

        -- we need to check if we're the last owner
        LockSharing
Shared -> do
          -- (the set item could expire here so size could be zero)
          Integer
size <- LockField (RefInstance ref) (Set LockOwnerId)
-> RedisM
     (RefInstance (LockField (RefInstance ref) (Set LockOwnerId)))
     Integer
forall ref a.
(Ref ref, ValueType ref ~ Set a) =>
ref -> RedisM (RefInstance ref) Integer
Redis.sSize (LockFieldName (Set LockOwnerId)
-> LockField (RefInstance ref) (Set LockOwnerId)
forall ty. LockFieldName ty -> LockField (RefInstance ref) ty
lockField LockFieldName (Set LockOwnerId)
LockFieldOwners)
          if Integer
size Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
1
            -- delete the whole lock
            then ref -> RedisM (RefInstance ref) ()
forall ref. Ref ref => ref -> RedisM (RefInstance ref) ()
Redis.delete_ ref
ref
            -- just remove ourselves from the list of owners
            else LockField (RefInstance ref) (Set LockOwnerId)
-> [LockOwnerId]
-> RedisM
     (RefInstance (LockField (RefInstance ref) (Set LockOwnerId))) ()
forall ref a.
(Ref ref, ValueType ref ~ Set a, Serializable a) =>
ref -> [a] -> RedisM (RefInstance ref) ()
Redis.sDelete (LockFieldName (Set LockOwnerId)
-> LockField (RefInstance ref) (Set LockOwnerId)
forall ty. LockFieldName ty -> LockField (RefInstance ref) ty
lockField LockFieldName (Set LockOwnerId)
LockFieldOwners) [LockOwnerId
ourId]
  where
    lockField :: LockFieldName ty -> LockField (Redis.RefInstance ref) ty
    lockField :: LockFieldName ty -> LockField (RefInstance ref) ty
lockField = ByteString -> LockFieldName ty -> LockField (RefInstance ref) ty
forall ty inst. ByteString -> LockFieldName ty -> LockField inst ty
LockField (ref -> Identifier (ValueType ref)
forall ref. Ref ref => ref -> Identifier (ValueType ref)
Redis.toIdentifier ref
ref)

-- | Sleep between 0.75 and 1.25 times the given time, uniformly randomly.
fuzzySleep :: MonadIO m => NominalDiffTime -> m ()
fuzzySleep :: NominalDiffTime -> m ()
fuzzySleep NominalDiffTime
interval = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- randomise wait time slightly
    Double
r <- IO Double
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Double  -- r is between 0.0 and 1.0
    let q :: Double
q = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.5) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2   -- q is between 0.75 and 1.25
    -- NominalDiffTime behaves like seconds; threadDelay takes microseconds
    Int -> IO ()
threadDelay (NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
1e6 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
q NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
interval)