{-# 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

-- import           Util.IOExtra

--------------------------------------------------------------------------------
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
<*>  --  serial
               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
<*>  --  pidId
               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
<*>  --  portId
               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
<*>  --  refId0
               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
<*>  --  refId1
               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
<*>  --  refId2
               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
<*>  --  pid2Mbox
               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
<*>  --  name2MBox
               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      --  name2Conn

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