{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Strict #-}
module Foreign.Erlang.NodeState
( NodeState()
, logNodeState
, newNodeState
, new_pid
, new_port
, new_ref
, putMailboxForPid
, getMailboxForPid
, putMailboxForName
, getMailboxForName
, putConnectionForNode
, getConnectionForNode
, removeConnectionForNode
, getConnectedNodes
) where
import Control.Concurrent.STM
import Control.Monad (void, when)
import Util.IOExtra
import qualified Data.Map.Strict as M
import Data.Word
data NodeState p n mb c =
NodeState { NodeState p n mb c -> TVar Word32
serial :: TVar Word32
, NodeState p n mb c -> TVar Word32
pidId :: TVar Word32
, NodeState p n mb c -> TVar Word32
portId :: TVar Word32
, NodeState p n mb c -> TVar Word32
refId0 :: TVar Word32
, NodeState p n mb c -> TVar Word32
refId1 :: TVar Word32
, NodeState p n mb c -> TVar Word32
refId2 :: TVar Word32
, NodeState p n mb c -> TVar (Map p mb)
pid2Mbox :: TVar (M.Map p mb)
, NodeState p n mb c -> TVar (Map n mb)
name2Mbox :: TVar (M.Map n mb)
, NodeState p n mb c -> TVar (Map n c)
node2Conn :: TVar (M.Map n c)
}
instance Show (NodeState p n mb c) where
show :: NodeState p n mb c -> String
show NodeState p n mb c
_ = String
"#NodeState<>"
newNodeState :: IO (NodeState p n mb c)
newNodeState :: IO (NodeState p n mb c)
newNodeState =
TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c
forall p n mb c.
TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c
NodeState (TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
-> IO (TVar Word32)
-> IO
(TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word32 -> IO (TVar Word32)
forall a. a -> IO (TVar a)
newTVarIO Word32
0
IO
(TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
-> IO (TVar Word32)
-> IO
(TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Word32 -> IO (TVar Word32)
forall a. a -> IO (TVar a)
newTVarIO Word32
1
IO
(TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
-> IO (TVar Word32)
-> IO
(TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Word32 -> IO (TVar Word32)
forall a. a -> IO (TVar a)
newTVarIO Word32
1
IO
(TVar Word32
-> TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
-> IO (TVar Word32)
-> IO
(TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Word32 -> IO (TVar Word32)
forall a. a -> IO (TVar a)
newTVarIO Word32
0
IO
(TVar Word32
-> TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
-> IO (TVar Word32)
-> IO
(TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Word32 -> IO (TVar Word32)
forall a. a -> IO (TVar a)
newTVarIO Word32
0
IO
(TVar Word32
-> TVar (Map p mb)
-> TVar (Map n mb)
-> TVar (Map n c)
-> NodeState p n mb c)
-> IO (TVar Word32)
-> IO
(TVar (Map p mb)
-> TVar (Map n mb) -> TVar (Map n c) -> NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Word32 -> IO (TVar Word32)
forall a. a -> IO (TVar a)
newTVarIO Word32
0
IO
(TVar (Map p mb)
-> TVar (Map n mb) -> TVar (Map n c) -> NodeState p n mb c)
-> IO (TVar (Map p mb))
-> IO (TVar (Map n mb) -> TVar (Map n c) -> NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Map p mb -> IO (TVar (Map p mb))
forall a. a -> IO (TVar a)
newTVarIO Map p mb
forall k a. Map k a
M.empty
IO (TVar (Map n mb) -> TVar (Map n c) -> NodeState p n mb c)
-> IO (TVar (Map n mb))
-> IO (TVar (Map n c) -> NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Map n mb -> IO (TVar (Map n mb))
forall a. a -> IO (TVar a)
newTVarIO Map n mb
forall k a. Map k a
M.empty
IO (TVar (Map n c) -> NodeState p n mb c)
-> IO (TVar (Map n c)) -> IO (NodeState p n mb c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Map n c -> IO (TVar (Map n c))
forall a. a -> IO (TVar a)
newTVarIO Map n c
forall k a. Map k a
M.empty
logNodeState :: (Show n, MonadIO m, MonadLogger m) => NodeState p n mb c -> m ()
logNodeState :: NodeState p n mb c -> m ()
logNodeState NodeState{TVar (Map n c)
node2Conn :: TVar (Map n c)
node2Conn :: forall p n mb c. NodeState p n mb c -> TVar (Map n c)
node2Conn} =
do
Map n c
m <- IO (Map n c) -> m (Map n c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar (Map n c) -> IO (Map n c)
forall a. TVar a -> IO a
readTVarIO TVar (Map n c)
node2Conn)
String -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
String -> m ()
logInfoStr (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"known connection keys %s" ([String] -> String
unlines (n -> String
forall a. Show a => a -> String
show (n -> String) -> [n] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map n c -> [n]
forall k a. Map k a -> [k]
M.keys Map n c
m)))
new_pid :: NodeState p n mb c -> IO (Word32, Word32)
new_pid :: NodeState p n mb c -> IO (Word32, Word32)
new_pid NodeState{TVar Word32
serial :: TVar Word32
serial :: forall p n mb c. NodeState p n mb c -> TVar Word32
serial,TVar Word32
pidId :: TVar Word32
pidId :: forall p n mb c. NodeState p n mb c -> TVar Word32
pidId} =
STM (Word32, Word32) -> IO (Word32, Word32)
forall a. STM a -> IO a
atomically (STM (Word32, Word32) -> IO (Word32, Word32))
-> STM (Word32, Word32) -> IO (Word32, Word32)
forall a b. (a -> b) -> a -> b
$ do
let p :: STM (Word32, Word32)
p = (,) (Word32 -> Word32 -> (Word32, Word32))
-> STM Word32 -> STM (Word32 -> (Word32, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
pidId STM (Word32 -> (Word32, Word32))
-> STM Word32 -> STM (Word32, Word32)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
serial
STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TVar Word32 -> Word32 -> STM Bool
inc TVar Word32
pidId Word32
_15bits) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TVar Word32 -> Word32 -> STM Bool
inc TVar Word32
serial Word32
_13bits)
STM (Word32, Word32)
p
new_port :: NodeState p n mb c -> IO Word32
new_port :: NodeState p n mb c -> IO Word32
new_port NodeState{TVar Word32
portId :: TVar Word32
portId :: forall p n mb c. NodeState p n mb c -> TVar Word32
portId} =
STM Word32 -> IO Word32
forall a. STM a -> IO a
atomically (STM Word32 -> IO Word32) -> STM Word32 -> IO Word32
forall a b. (a -> b) -> a -> b
$ do
let p :: STM Word32
p = TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
portId
STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TVar Word32 -> Word32 -> STM Bool
inc TVar Word32
portId Word32
_28bits)
STM Word32
p
new_ref :: NodeState p n mb c -> IO (Word32, Word32, Word32)
new_ref :: NodeState p n mb c -> IO (Word32, Word32, Word32)
new_ref NodeState{TVar Word32
refId0 :: TVar Word32
refId0 :: forall p n mb c. NodeState p n mb c -> TVar Word32
refId0,TVar Word32
refId1 :: TVar Word32
refId1 :: forall p n mb c. NodeState p n mb c -> TVar Word32
refId1,TVar Word32
refId2 :: TVar Word32
refId2 :: forall p n mb c. NodeState p n mb c -> TVar Word32
refId2} =
STM (Word32, Word32, Word32) -> IO (Word32, Word32, Word32)
forall a. STM a -> IO a
atomically (STM (Word32, Word32, Word32) -> IO (Word32, Word32, Word32))
-> STM (Word32, Word32, Word32) -> IO (Word32, Word32, Word32)
forall a b. (a -> b) -> a -> b
$ do
let r :: STM (Word32, Word32, Word32)
r = (,,) (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32))
-> STM Word32 -> STM (Word32 -> Word32 -> (Word32, Word32, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
refId0 STM (Word32 -> Word32 -> (Word32, Word32, Word32))
-> STM Word32 -> STM (Word32 -> (Word32, Word32, Word32))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
refId1 STM (Word32 -> (Word32, Word32, Word32))
-> STM Word32 -> STM (Word32, Word32, Word32)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
refId2
STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TVar Word32 -> Word32 -> STM Bool
inc TVar Word32
refId0 Word32
_18bits) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TVar Word32 -> Word32 -> STM Bool
inc TVar Word32
refId1 Word32
_32bits) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TVar Word32 -> Word32 -> STM Bool
inc TVar Word32
refId2 Word32
_32bits)
STM (Word32, Word32, Word32)
r
putMailboxForPid :: (Ord p) => NodeState p n mb c -> p -> mb -> IO ()
putMailboxForPid :: NodeState p n mb c -> p -> mb -> IO ()
putMailboxForPid NodeState{TVar (Map p mb)
pid2Mbox :: TVar (Map p mb)
pid2Mbox :: forall p n mb c. NodeState p n mb c -> TVar (Map p mb)
pid2Mbox} p
pid mb
mbox =
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map p mb) -> (Map p mb -> Map p mb) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map p mb)
pid2Mbox (p -> mb -> Map p mb -> Map p mb
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert p
pid mb
mbox)
getMailboxForPid :: (Ord p) => NodeState p n mb c -> p -> IO (Maybe mb)
getMailboxForPid :: NodeState p n mb c -> p -> IO (Maybe mb)
getMailboxForPid NodeState{TVar (Map p mb)
pid2Mbox :: TVar (Map p mb)
pid2Mbox :: forall p n mb c. NodeState p n mb c -> TVar (Map p mb)
pid2Mbox} p
pid = p -> Map p mb -> Maybe mb
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup p
pid (Map p mb -> Maybe mb) -> IO (Map p mb) -> IO (Maybe mb)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map p mb) -> IO (Map p mb)
forall a. STM a -> IO a
atomically (TVar (Map p mb) -> STM (Map p mb)
forall a. TVar a -> STM a
readTVar TVar (Map p mb)
pid2Mbox)
putMailboxForName :: (Ord n) => NodeState p n mb c -> n -> mb -> IO ()
putMailboxForName :: NodeState p n mb c -> n -> mb -> IO ()
putMailboxForName NodeState{TVar (Map n mb)
name2Mbox :: TVar (Map n mb)
name2Mbox :: forall p n mb c. NodeState p n mb c -> TVar (Map n mb)
name2Mbox} n
name mb
mbox =
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map n mb) -> (Map n mb -> Map n mb) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map n mb)
name2Mbox (n -> mb -> Map n mb -> Map n mb
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert n
name mb
mbox)
getMailboxForName :: (Ord n) => NodeState p n mb c -> n -> IO (Maybe mb)
getMailboxForName :: NodeState p n mb c -> n -> IO (Maybe mb)
getMailboxForName NodeState{TVar (Map n mb)
name2Mbox :: TVar (Map n mb)
name2Mbox :: forall p n mb c. NodeState p n mb c -> TVar (Map n mb)
name2Mbox} n
name =
n -> Map n mb -> Maybe mb
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup n
name (Map n mb -> Maybe mb) -> IO (Map n mb) -> IO (Maybe mb)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map n mb) -> IO (Map n mb)
forall a. STM a -> IO a
atomically (TVar (Map n mb) -> STM (Map n mb)
forall a. TVar a -> STM a
readTVar TVar (Map n mb)
name2Mbox)
putConnectionForNode :: (Ord n) => NodeState p n mb c -> n -> c -> IO ()
putConnectionForNode :: NodeState p n mb c -> n -> c -> IO ()
putConnectionForNode NodeState{TVar (Map n c)
node2Conn :: TVar (Map n c)
node2Conn :: forall p n mb c. NodeState p n mb c -> TVar (Map n c)
node2Conn} n
name c
conn =
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map n c) -> (Map n c -> Map n c) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map n c)
node2Conn (n -> c -> Map n c -> Map n c
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert n
name c
conn)
getConnectionForNode :: (MonadIO m, Ord n) => NodeState p n mb c -> n -> m (Maybe c)
getConnectionForNode :: NodeState p n mb c -> n -> m (Maybe c)
getConnectionForNode NodeState{TVar (Map n c)
node2Conn :: TVar (Map n c)
node2Conn :: forall p n mb c. NodeState p n mb c -> TVar (Map n c)
node2Conn} n
name =
n -> Map n c -> Maybe c
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup n
name (Map n c -> Maybe c) -> m (Map n c) -> m (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map n c) -> m (Map n c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM (Map n c) -> IO (Map n c)
forall a. STM a -> IO a
atomically (TVar (Map n c) -> STM (Map n c)
forall a. TVar a -> STM a
readTVar TVar (Map n c)
node2Conn))
removeConnectionForNode :: (Ord n) => NodeState p n mb c -> n -> IO ()
removeConnectionForNode :: NodeState p n mb c -> n -> IO ()
removeConnectionForNode NodeState{TVar (Map n c)
node2Conn :: TVar (Map n c)
node2Conn :: forall p n mb c. NodeState p n mb c -> TVar (Map n c)
node2Conn} n
name =
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map n c) -> (Map n c -> Map n c) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map n c)
node2Conn (n -> Map n c -> Map n c
forall k a. Ord k => k -> Map k a -> Map k a
M.delete n
name)
getConnectedNodes :: NodeState p n mb c -> IO [(n, c)]
getConnectedNodes :: NodeState p n mb c -> IO [(n, c)]
getConnectedNodes NodeState{TVar (Map n c)
node2Conn :: TVar (Map n c)
node2Conn :: forall p n mb c. NodeState p n mb c -> TVar (Map n c)
node2Conn} =
Map n c -> [(n, c)]
forall k a. Map k a -> [(k, a)]
M.toList (Map n c -> [(n, c)]) -> IO (Map n c) -> IO [(n, c)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Map n c) -> IO (Map n c)
forall a. STM a -> IO a
atomically (TVar (Map n c) -> STM (Map n c)
forall a. TVar a -> STM a
readTVar TVar (Map n c)
node2Conn)
_13bits, _15bits, _18bits, _28bits, _32bits :: Word32
_13bits :: Word32
_13bits = Word32
0x00001fff
_15bits :: Word32
_15bits = Word32
0x00007fff
_18bits :: Word32
_18bits = Word32
0x0003ffff
_28bits :: Word32
_28bits = Word32
0x0fffffff
_32bits :: Word32
_32bits = Word32
0xffffffff
inc :: TVar Word32 -> Word32 -> STM Bool
inc :: TVar Word32 -> Word32 -> STM Bool
inc TVar Word32
tV Word32
maxV = do
TVar Word32 -> (Word32 -> Word32) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Word32
tV (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1)
Word32
v <- TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
tV
if Word32
v Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
maxV
then do
TVar Word32 -> Word32 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Word32
tV Word32
0
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: m Bool -> m () -> m ()
whenM m Bool
mt m ()
mc = do
Bool
t <- m Bool
mt
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
t m ()
mc