Processes.hs

-- |
-- Module      : Foreign.Erlang.OTP
-- Copyright   : (c) Eric Sessoms, 2008
--               (c) Artúr Poór, 2015
-- License     : GPL3
-- 
-- Maintainer  : gombocarti@gmail.com
-- Stability   : experimental
-- Portability : portable
--

module Foreign.Erlang.Processes (
  -- * Low-level communication
  -- ** Representation of a Haskell node (program)
    Self
  , createSelf
  -- ** Representation of a Haskell process (thread)
  , MBox
  , createMBox
  , mboxRef
  , mboxSelf
  -- ** Representation of Erlang nodes and processes
  , Pid
  -- ** Communication to and from Erlang
  , 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>"

-- | Represents a Haskell node.  There should be one of these per process.
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

-- | Instantiate a Haskell node.  This initializes the FFI.
-- Node name should be a \'long name\' e.g. @\"haskell\@localhost\"@.
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))

-- | A `nodeSend` thread is responsible for communication to an Erlang
-- process.  It receives messages in an `MVar` and forwards them across
-- the network.

nodeSend mvar send = loop
  where
    loop = takeMVar mvar >>= send >> loop

-- | A `nodeRecv` thread is responsible for communication from an Erlang
-- process.  It receives messages from the network and dispatches them as
-- appropriate.

nodeRecv mvar recv outbox = loop
  where
    loop = do
        (mctl, mmsg) <- recv
        case mctl of
            -- Nothing is a keepalive.  All we want to do is echo it.
            Nothing  -> putMVar mvar (Nothing, Nothing)
            -- A real message goes to self to be dispatched.
            Just ctl -> putMVar outbox $ ErlDispatch ctl (fromJust mmsg)
        loop

-- | Haskell threads don't natively have Erlang process IDs.  Instead, we
-- use a mailbox abstraction that we can assign PIDs to for communication
-- with Erlang.

data MBox = MBox ErlType (MVar ErlType) Self

-- | Represents a foreign (Erlang) process.  A process can be identified
-- either by its low-level ID (Left pid) or by its registered name (Right name).
  
type Pid  = Either ErlType String

-- | Return the PID of the given mailbox.

mboxSelf                :: MBox -> ErlType
mboxSelf (MBox pid _ _) = pid

-- | Return a new unique object reference.

mboxRef                        :: MBox -> IO ErlType
mboxRef mbox@(MBox pid _ self) = send self (ErlGenRef pid) >> mboxRecv mbox

-- | Send an arbitrary message to the specified node and process. It is equivalent in Erlang to
--
-- > {Node, Pid} ! Msg.

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)

-- | Receive the next message addressed to this mailbox.

mboxRecv                  :: MBox -> IO ErlType
mboxRecv (MBox _ inbox _) = takeMVar inbox

-- | Receive a reply message.  That is, looks for the next message
-- identified by the given reference.
  
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

-- | Create a new process on the Haskell side.  Usually corresponds
-- to a thread but doesn't need to.
          
createMBox      :: Self -> IO MBox
createMBox self = do
    inbox <- newEmptyMVar
    send self $ ErlRegister (putMVar inbox)
    pid <- takeMVar inbox
    return $ MBox pid inbox self