{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StaticPointers      #-}

module Hyperion.LockMap
  ( LockMap,
    withLock,
    withLocks,
    newLockMap,
    registerLockMap
  )
where

import qualified Control.Concurrent.STM                   as STM
import           Control.Distributed.Process              (DiedReason (..),
                                                           Process, ProcessId,
                                                           ProcessLinkException (..),
                                                           RemoteTable, call,
                                                           closure, getSelfPid,
                                                           liftIO, link,
                                                           spawnLocal, unStatic)
import           Control.Distributed.Process.Serializable (SerializableDict (..))
import           Control.Distributed.Static               (Static,
                                                           registerStatic,
                                                           staticLabel,
                                                           staticPtr)
import           Control.Monad                            (void)
import           Control.Monad.Catch                      (catch, bracket)
import           Control.Monad.Extra                      (unless)
import           Data.Binary                              (Binary, decode,
                                                           encode)
import           Data.ByteString.Lazy                     (ByteString)
import qualified Data.Map.Strict                          as Map
import           Data.Rank1Dynamic                        (toDynamic)
import           Data.Typeable                            (Typeable, typeOf)
import qualified Hyperion.Log                             as Log
import           Hyperion.Remote                          (getMasterNodeId)

-- Presence of a pid value indicates that the lock is locked by the process with the given ProcessId
type Lock = STM.TMVar ProcessId

newtype Key a = Key { Key a -> a
unKey :: a }

--newLockedLock :: ProcessId -> STM.STM Lock
--newLockedLock = STM.newTMVar
--
--newUnlockedLock :: STM.STM Lock
--newUnlockedLock = STM.newEmptyTMVar

isLocked :: Lock -> STM.STM Bool
isLocked :: Lock -> STM Bool
isLocked Lock
l = Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lock -> STM Bool
forall a. TMVar a -> STM Bool
STM.isEmptyTMVar Lock
l

isUnlocked ::  Lock -> STM.STM Bool
isUnlocked :: Lock -> STM Bool
isUnlocked Lock
l = Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lock -> STM Bool
isLocked Lock
l

-- Blocks
lock :: ProcessId -> Lock -> STM.STM ()
lock :: ProcessId -> Lock -> STM ()
lock = (Lock -> ProcessId -> STM ()) -> ProcessId -> Lock -> STM ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Lock -> ProcessId -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar

-- Doesn't block
unlock :: Lock -> STM.STM ()
unlock :: Lock -> STM ()
unlock = STM (Maybe ProcessId) -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM (Maybe ProcessId) -> STM ())
-> (Lock -> STM (Maybe ProcessId)) -> Lock -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lock -> STM (Maybe ProcessId)
forall a. TMVar a -> STM (Maybe a)
STM.tryTakeTMVar

--wait :: Lock -> STM.STM ()
--wait l = STM.isEmptyTMVar l >>= \case
--  True -> return ()
--  False -> STM.retry

-- By default, all locks are open
type LockMap = STM.TVar (Map.Map ByteString Lock)

lockMapLabel :: String
lockMapLabel :: String
lockMapLabel = String
"lockMapLabel"

lockMapStatic :: Static LockMap
lockMapStatic :: Static LockMap
lockMapStatic = String -> Static LockMap
forall a. String -> Static a
staticLabel String
lockMapLabel

getLockMap :: Process LockMap
getLockMap :: Process LockMap
getLockMap = Static LockMap -> Process LockMap
forall a. Typeable a => Static a -> Process a
unStatic Static LockMap
lockMapStatic

newLockMap :: IO LockMap
newLockMap :: IO LockMap
newLockMap = Map ByteString Lock -> IO LockMap
forall a. a -> IO (TVar a)
STM.newTVarIO Map ByteString Lock
forall k a. Map k a
Map.empty

registerLockMap :: LockMap -> RemoteTable -> RemoteTable
registerLockMap :: LockMap -> RemoteTable -> RemoteTable
registerLockMap LockMap
var = String -> Dynamic -> RemoteTable -> RemoteTable
registerStatic String
lockMapLabel (LockMap -> Dynamic
forall a. Typeable a => a -> Dynamic
toDynamic LockMap
var)

lockRemote_ :: ByteString -> Process ()
lockRemote_ :: ByteString -> Process ()
lockRemote_ ByteString
bs' = do
  Process (Maybe NodeId)
getMasterNodeId Process (Maybe NodeId)
-> (Maybe NodeId -> Process ()) -> Process ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe NodeId
Nothing -> do
      let
        (ProcessId
pid, [ByteString]
bss) = ByteString -> (ProcessId, [ByteString])
forall a. Binary a => ByteString -> a
decode ByteString
bs'
      -- Make sure there is a cleanup process linked to the original caller
      -- Create a signal TMVar for receiving a green light from the cleanup process
      TMVar ()
sig  <- IO (TMVar ()) -> Process (TMVar ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar ()) -> Process (TMVar ()))
-> (STM (TMVar ()) -> IO (TMVar ()))
-> STM (TMVar ())
-> Process (TMVar ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (TMVar ()) -> IO (TMVar ())
forall a. STM a -> IO a
STM.atomically (STM (TMVar ()) -> Process (TMVar ()))
-> STM (TMVar ()) -> Process (TMVar ())
forall a b. (a -> b) -> a -> b
$ STM (TMVar ())
forall a. STM (TMVar a)
STM.newEmptyTMVar
      -- TMVar that lets the cleanup process know what to clean up
      TMVar [Lock]
lvar <- IO (TMVar [Lock]) -> Process (TMVar [Lock])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar [Lock]) -> Process (TMVar [Lock]))
-> (STM (TMVar [Lock]) -> IO (TMVar [Lock]))
-> STM (TMVar [Lock])
-> Process (TMVar [Lock])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (TMVar [Lock]) -> IO (TMVar [Lock])
forall a. STM a -> IO a
STM.atomically (STM (TMVar [Lock]) -> Process (TMVar [Lock]))
-> STM (TMVar [Lock]) -> Process (TMVar [Lock])
forall a b. (a -> b) -> a -> b
$ STM (TMVar [Lock])
forall a. STM (TMVar a)
STM.newEmptyTMVar
      -- Start the cleanup process
      ProcessId
_    <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ ProcessId -> TMVar [Lock] -> TMVar () -> Process ()
cleanup ProcessId
pid TMVar [Lock]
lvar TMVar ()
sig
      -- Receive the signal from cleanup process that it is linked to the caller
      -- We can now safely acquire the locks
      ()   <- IO () -> Process ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (STM () -> IO ()) -> STM () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> Process ()) -> STM () -> Process ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
STM.takeTMVar TMVar ()
sig

      LockMap
lmapvar <- Process LockMap
getLockMap
      -- We perform a transaction where we lookup the locks by keys, create new locks if needed.
      -- We then peform a second transaction where
      --  If all locks are open, we lock them all with caller pid and send them to cleanup proc
      --  if at least one is closed, the transaction is retried (no changes to memory are recorded).
      -- We can use a single transaction, but it would be restarted each time someone accesses the lock map
      -- or our locks, rather than just our locks, which is a bit silly.
      [Lock]
locks <- IO [Lock] -> Process [Lock]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Lock] -> Process [Lock])
-> (STM [Lock] -> IO [Lock]) -> STM [Lock] -> Process [Lock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM [Lock] -> IO [Lock]
forall a. STM a -> IO a
STM.atomically (STM [Lock] -> Process [Lock]) -> STM [Lock] -> Process [Lock]
forall a b. (a -> b) -> a -> b
$ LockMap -> [ByteString] -> STM [Lock]
getLocks LockMap
lmapvar [ByteString]
bss
      IO () -> Process ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (STM () -> IO ()) -> STM () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> Process ()) -> STM () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
        [Bool]
unlocked <- (Lock -> STM Bool) -> [Lock] -> STM [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Lock -> STM Bool
isUnlocked [Lock]
locks
        if (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id [Bool]
unlocked then do
          (Lock -> STM ()) -> [Lock] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ProcessId -> Lock -> STM ()
lock ProcessId
pid) [Lock]
locks
          TMVar [Lock] -> [Lock] -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar [Lock]
lvar [Lock]
locks
        else STM ()
forall a. STM a
STM.retry
      () -> Process ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just NodeId
nid ->
      Static (SerializableDict ())
-> NodeId -> Closure (Process ()) -> Process ()
forall a.
Serializable a =>
Static (SerializableDict a)
-> NodeId -> Closure (Process a) -> Process a
call (StaticPtr (SerializableDict ()) -> Static (SerializableDict ())
forall a. Typeable a => StaticPtr a -> Static a
staticPtr (static SerializableDict ()
forall a. Serializable a => SerializableDict a
SerializableDict)) NodeId
nid (Closure (Process ()) -> Process ())
-> Closure (Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$
        Static (ByteString -> Process ())
-> ByteString -> Closure (Process ())
forall a. Static (ByteString -> a) -> ByteString -> Closure a
closure (StaticPtr (ByteString -> Process ())
-> Static (ByteString -> Process ())
forall a. Typeable a => StaticPtr a -> Static a
staticPtr (static ByteString -> Process ()
lockRemote_)) ByteString
bs'
  where
    getLocks :: LockMap -> [ByteString] -> STM.STM [Lock]
    getLocks :: LockMap -> [ByteString] -> STM [Lock]
getLocks LockMap
lmapvar [ByteString]
bss = do
      (ByteString -> STM Lock) -> [ByteString] -> STM [Lock]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ByteString -> STM Lock
lookupOrNew [ByteString]
bss
      where
        lookupOrNew :: ByteString -> STM.STM Lock
        lookupOrNew :: ByteString -> STM Lock
lookupOrNew ByteString
bs = do
          Map ByteString Lock
lmap <- LockMap -> STM (Map ByteString Lock)
forall a. TVar a -> STM a
STM.readTVar LockMap
lmapvar
          let
            mlock :: Maybe Lock
mlock = ByteString -> Map ByteString Lock -> Maybe Lock
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
bs Map ByteString Lock
lmap
            new :: STM Lock
new = do
                Lock
l <- STM Lock
forall a. STM (TMVar a)
STM.newEmptyTMVar
                LockMap -> Map ByteString Lock -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar LockMap
lmapvar (Map ByteString Lock -> STM ()) -> Map ByteString Lock -> STM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Lock -> Map ByteString Lock -> Map ByteString Lock
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
bs Lock
l Map ByteString Lock
lmap
                Lock -> STM Lock
forall (m :: * -> *) a. Monad m => a -> m a
return Lock
l
          STM Lock -> (Lock -> STM Lock) -> Maybe Lock -> STM Lock
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM Lock
new Lock -> STM Lock
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Lock
mlock

    cleanup :: ProcessId -> STM.TMVar [Lock] -> STM.TMVar () -> Process ()
    cleanup :: ProcessId -> TMVar [Lock] -> TMVar () -> Process ()
cleanup ProcessId
pid TMVar [Lock]
lvar TMVar ()
sig =
      Process () -> (ProcessLinkException -> Process ()) -> Process ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch -- We catch the exceptions raised due to link to pid
        ( do
            ProcessId -> Process ()
link ProcessId
pid -- Link to pid
            IO () -> Process ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (STM () -> IO ()) -> STM () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> Process ()) -> STM () -> Process ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar ()
sig () -- Inform master process that we have linked
            IO () -> Process ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (STM () -> IO ()) -> STM () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> Process ()) -> STM () -> Process ()
forall a b. (a -> b) -> a -> b
$ TMVar [Lock] -> STM [Lock]
forall a. TMVar a -> STM a
STM.readTMVar TMVar [Lock]
lvar STM [Lock] -> ([Lock] -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Lock -> STM ()) -> [Lock] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lock -> STM ()
wait -- Wait for the locks locked by our caller's pid
        )
        ( \(ProcessLinkException ProcessId
_ DiedReason
reason) ->
            -- We do not clean up if the caller died normally. It is the caller's responsibility to clean things up.
            -- This of course includes handled exceptions in the caller. In this case we clean up using 'bracket' in the
            -- caller.
            Bool -> Process () -> Process ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DiedReason
reason DiedReason -> DiedReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiedReason
DiedNormal) (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
              Bool
pidReleasedLock <- IO Bool -> Process Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Process Bool)
-> (STM Bool -> IO Bool) -> STM Bool -> Process Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Bool -> IO Bool
forall a. STM a -> IO a
STM.atomically (STM Bool -> Process Bool) -> STM Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ do
                Maybe [Lock]
mlocks <- TMVar [Lock] -> STM (Maybe [Lock])
forall a. TMVar a -> STM (Maybe a)
STM.tryReadTMVar TMVar [Lock]
lvar
                case Maybe [Lock]
mlocks of
                  Just [Lock]
locks -> do
                    [Bool]
releases <- ((Lock -> STM Bool) -> [Lock] -> STM [Bool])
-> [Lock] -> (Lock -> STM Bool) -> STM [Bool]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Lock -> STM Bool) -> [Lock] -> STM [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Lock]
locks ((Lock -> STM Bool) -> STM [Bool])
-> (Lock -> STM Bool) -> STM [Bool]
forall a b. (a -> b) -> a -> b
$ \Lock
l -> do
                      Lock -> STM (Maybe ProcessId)
forall a. TMVar a -> STM (Maybe a)
STM.tryReadTMVar Lock
l STM (Maybe ProcessId) -> (Maybe ProcessId -> STM Bool) -> STM Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Just ProcessId
pid' -> if ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid' then do
                          Lock -> STM ()
unlock Lock
l
                          Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                          else Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        Maybe ProcessId
Nothing   -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                    Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Bool -> Bool
forall a. a -> a
id [Bool]
releases)
                  Maybe [Lock]
Nothing -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
              Bool -> Process () -> Process ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pidReleasedLock (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ Text -> ProcessId -> Process ()
forall a (m :: * -> *). (Show a, MonadIO m) => Text -> a -> m ()
Log.warn Text
"Process holding a lock died, released the locks it held" ProcessId
pid
        )
      where
        wait :: Lock -> STM.STM ()
        wait :: Lock -> STM ()
wait Lock
l = Lock -> STM (Maybe ProcessId)
forall a. TMVar a -> STM (Maybe a)
STM.tryReadTMVar Lock
l STM (Maybe ProcessId) -> (Maybe ProcessId -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just ProcessId
pid' -> if ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid' then STM ()
forall a. STM a
STM.retry
                                      else () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Maybe ProcessId
Nothing   -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

unlockRemote_ :: ByteString -> Process ()
unlockRemote_ :: ByteString -> Process ()
unlockRemote_ ByteString
bss' =
  Process (Maybe NodeId)
getMasterNodeId Process (Maybe NodeId)
-> (Maybe NodeId -> Process ()) -> Process ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe NodeId
Nothing -> do
      LockMap
lvar <- Process LockMap
getLockMap
      IO () -> Process ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (STM () -> IO ()) -> STM () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> Process ()) -> STM () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
        Map ByteString Lock
lmap <- LockMap -> STM (Map ByteString Lock)
forall a. TVar a -> STM a
STM.readTVar LockMap
lvar
        let
          unlock' :: ByteString -> STM ()
unlock' ByteString
bs = STM () -> (Lock -> STM ()) -> Maybe Lock -> STM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Lock -> STM ()
unlock (ByteString -> Map ByteString Lock -> Maybe Lock
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
bs Map ByteString Lock
lmap)
        (ByteString -> STM ()) -> [ByteString] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> STM ()
unlock' [ByteString]
bss
    Just NodeId
nid ->
      Static (SerializableDict ())
-> NodeId -> Closure (Process ()) -> Process ()
forall a.
Serializable a =>
Static (SerializableDict a)
-> NodeId -> Closure (Process a) -> Process a
call (StaticPtr (SerializableDict ()) -> Static (SerializableDict ())
forall a. Typeable a => StaticPtr a -> Static a
staticPtr (static SerializableDict ()
forall a. Serializable a => SerializableDict a
SerializableDict)) NodeId
nid (Closure (Process ()) -> Process ())
-> Closure (Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$
        Static (ByteString -> Process ())
-> ByteString -> Closure (Process ())
forall a. Static (ByteString -> a) -> ByteString -> Closure a
closure (StaticPtr (ByteString -> Process ())
-> Static (ByteString -> Process ())
forall a. Typeable a => StaticPtr a -> Static a
staticPtr (static ByteString -> Process ()
unlockRemote_)) ByteString
bss'
  where
    bss :: [ByteString]
    bss :: [ByteString]
bss = ByteString -> [ByteString]
forall a. Binary a => ByteString -> a
decode ByteString
bss'

--isLockedRemote_ :: ByteString -> Process Bool
--isLockedRemote_ bs = do
--  getMasterNodeId >>= \case
--    Nothing -> do
--      lvar <- getLockMap
--      liftIO . STM.atomically $ do
--        lmap <- STM.readTVar lvar
--        let mlock = Map.lookup bs lmap
--        maybe (return False) isLocked mlock
--    Just nid ->
--      call (staticPtr (static SerializableDict)) nid $
--        closure (staticPtr (static isLockedRemote_)) bs

serialize :: (Typeable a, Binary a) => a -> ByteString
serialize :: a -> ByteString
serialize a
a = (TypeRep, a) -> ByteString
forall a. Binary a => a -> ByteString
encode (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a, a
a)

lockRemote :: (Typeable a, Binary a) => [a] -> Process [Key a]
lockRemote :: [a] -> Process [Key a]
lockRemote [a]
a = do
  ProcessId
pid <- Process ProcessId
getSelfPid
  ByteString -> Process ()
lockRemote_ (ByteString -> Process ()) -> ByteString -> Process ()
forall a b. (a -> b) -> a -> b
$ (ProcessId, [ByteString]) -> ByteString
forall a. Binary a => a -> ByteString
encode (ProcessId
pid, (a -> ByteString) -> [a] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map a -> ByteString
forall a. (Typeable a, Binary a) => a -> ByteString
serialize [a]
a)
  [Key a] -> Process [Key a]
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> Key a) -> [a] -> [Key a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Key a
forall a. a -> Key a
Key [a]
a)

unlockRemote :: (Typeable a, Binary a) => [Key a] -> Process ()
unlockRemote :: [Key a] -> Process ()
unlockRemote [Key a]
a = ByteString -> Process ()
unlockRemote_ (ByteString -> Process ()) -> ByteString -> Process ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Binary a => a -> ByteString
encode ((Key a -> ByteString) -> [Key a] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (a -> ByteString
forall a. (Typeable a, Binary a) => a -> ByteString
serialize (a -> ByteString) -> (Key a -> a) -> Key a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key a -> a
forall a. Key a -> a
unKey) [Key a]
a)

--isLockedRemote :: (Typeable a, Binary a) => a -> Process Bool
--isLockedRemote = isLockedRemote_ . serialize

withLocks :: (Typeable a, Binary a) => [a] -> Process r -> Process r
withLocks :: [a] -> Process r -> Process r
withLocks [a]
obj = Process [Key a]
-> ([Key a] -> Process ()) -> ([Key a] -> Process r) -> Process r
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket ([a] -> Process [Key a]
forall a. (Typeable a, Binary a) => [a] -> Process [Key a]
lockRemote [a]
obj) [Key a] -> Process ()
forall a. (Typeable a, Binary a) => [Key a] -> Process ()
unlockRemote (([Key a] -> Process r) -> Process r)
-> (Process r -> [Key a] -> Process r) -> Process r -> Process r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Process r -> [Key a] -> Process r
forall a b. a -> b -> a
const

withLock :: (Typeable a, Binary a) => a -> Process r -> Process r
withLock :: a -> Process r -> Process r
withLock a
a = [a] -> Process r -> Process r
forall a r. (Typeable a, Binary a) => [a] -> Process r -> Process r
withLocks [a
a]