module Foreign.Erlang.Processes (
Self
, createSelf
, MBox
, createMBox
, mboxRef
, mboxSelf
, Pid
, mboxRecv
, mboxRecv'
, mboxSend
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Data.Maybe (fromJust)
import Foreign.Erlang.Network
import Foreign.Erlang.Types
data ErlMessage = ErlRegister (ErlType -> IO ())
| ErlGenRef ErlType
| ErlSend Node ErlType ErlType
| ErlRegSend ErlType Node String ErlType
| ErlLink ErlType Node ErlType
| ErlUnlink ErlType Node ErlType
| ErlExit ErlType Node ErlType ErlType
| ErlExit2 ErlType Node ErlType ErlType
| ErlDispatch ErlType ErlType
| ErlStop
deriving Show
instance Show (a -> b) where
show _ = "<function>"
data Self = Self { send :: ErlMessage -> IO () }
genPid nodename id = ErlPid (ErlAtom nodename) id 0 1
genRef nodename id = ErlNewRef (ErlAtom nodename) 1 . toNetwork 4 . fromIntegral $ id
createSelf :: String -> IO Self
createSelf nodename = do
inbox <- newEmptyMVar
forkIO $ self nodename inbox
return . Self $ putMVar inbox
self :: String -> MVar ErlMessage -> IO ()
self nodename inbox = loop 1 [] []
where
loop id mboxes nodes = do
msg <- takeMVar inbox
case msg of
ErlRegister mbox -> do
let pid = genPid nodename id
mbox pid
loop (id+1) ((pid, mbox) : mboxes) nodes
ErlGenRef pid -> do
let ref = genRef nodename id
maybe (return ()) ($ ref) $ lookup pid mboxes
loop (id+1) mboxes nodes
ErlSend node pid msg -> do
let ctl = toErlang (ErlInt 2, ErlAtom "", pid)
(mnode, nodes') <- findNode node nodes
case mnode of
Just n -> n (Just ctl, Just msg)
Nothing -> return ()
loop id mboxes nodes'
ErlRegSend from node pid msg -> do
let ctl = toErlang (ErlInt 6, from, ErlAtom "", ErlAtom pid)
(mnode, nodes') <- findNode node nodes
case mnode of
Just n -> n (Just ctl, Just msg)
Nothing -> return ()
loop id mboxes nodes'
ErlLink from to pid -> do
let ctl = toErlang (ErlInt 1, from, pid)
(node, nodes') <- findNode to nodes
fromJust node (Just ctl, Nothing)
loop id mboxes nodes'
ErlUnlink from to pid -> do
let ctl = toErlang (ErlInt 4, from, pid)
(node, nodes') <- findNode to nodes
fromJust node (Just ctl, Nothing)
loop id mboxes nodes'
ErlExit from to pid reason -> do
let ctl = toErlang (ErlInt 3, from, to, reason)
(node, nodes') <- findNode to nodes
fromJust node (Just ctl, Nothing)
loop id mboxes nodes'
ErlExit2 from to pid reason -> do
let ctl = toErlang (ErlInt 8, from, to, reason)
(node, nodes') <- findNode to nodes
fromJust node (Just ctl, Nothing)
loop id mboxes nodes'
ErlDispatch ctl msg -> do
case ctl of
ErlTuple [ErlInt 2, _, pid] ->
maybe (return ()) ($ msg) $ lookup pid mboxes
_ -> return ()
loop id mboxes nodes
ErlStop -> return ()
findNode to nodes =
case lookup to nodes of
Just node -> return (Just node, nodes)
Nothing -> do
(send, recv) <- erlConnect nodename to
mvar <- newEmptyMVar
forkIO $ nodeSend mvar send
forkIO $ nodeRecv mvar recv inbox
let node = putMVar mvar
return (Just node, ((to, node) : nodes))
nodeSend mvar send = loop
where
loop = takeMVar mvar >>= send >> loop
nodeRecv mvar recv outbox = loop
where
loop = do
(mctl, mmsg) <- recv
case mctl of
Nothing -> putMVar mvar (Nothing, Nothing)
Just ctl -> putMVar outbox $ ErlDispatch ctl (fromJust mmsg)
loop
data MBox = MBox ErlType (MVar ErlType) Self
type Pid = Either ErlType String
mboxSelf :: MBox -> ErlType
mboxSelf (MBox pid _ _) = pid
mboxRef :: MBox -> IO ErlType
mboxRef mbox@(MBox pid _ self) = send self (ErlGenRef pid) >> mboxRecv mbox
mboxSend :: Erlang a => MBox -> Node -> Pid -> a -> IO ()
mboxSend (MBox _ _ self) node (Left pid) msg = send self $ ErlSend node pid (toErlang msg)
mboxSend (MBox from _ self) node (Right pid) msg = send self $ ErlRegSend from node pid (toErlang msg)
mboxRecv :: MBox -> IO ErlType
mboxRecv (MBox _ inbox _) = takeMVar inbox
mboxRecv' :: MBox -> ErlType -> IO ErlType
mboxRecv' mbox ref = do
msg <- mboxRecv mbox
case msg of
ErlTuple [ref', result] | ref' == ref -> return result
_ -> mboxRecv' mbox ref
createMBox :: Self -> IO MBox
createMBox self = do
inbox <- newEmptyMVar
send self $ ErlRegister (putMVar inbox)
pid <- takeMVar inbox
return $ MBox pid inbox self