@@ -10,15 +10,18 @@ import Data.Binary (Binary(get, put), getWord8, putWord8)
1010import Data.Accessor (Accessor, accessor, (^:), (^.))
1111import Data.Set (Set)
1212import qualified Data.Set as Set (insert, empty, toList)
13+import Data.Foldable (forM_)
1314import Control.Applicative ((<$>))
1415import Control.Exception (throw)
15−import Control.Monad (forM_, forever)
16+import Control.Monad (forever)
17+import Control.Monad.IO.Class (liftIO)
1618import Control.Concurrent (forkIO, threadDelay)
1719import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
1820import Control.Distributed.Process.Internal.Types
1921 ( LocalNode
2022 , RemoteTable
2123 , NodeId
24+ , Process
2225 )
2326import qualified Control.Distributed.Process.Node as Node
2427 ( newLocalNode
@@ -31,6 +34,7 @@ import qualified Network.Transport.TCP as NT
3134import qualified Network.Transport as NT (Transport)
3235import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
3336import Control.Distributed.Process.Internal.Multicast (initMulticast)
37+import Control.Distributed.Process.Internal.Primitives (whereis, registerRemote)
3438
3539-- | Local backend
3640data LocalBackend = LocalBackend {
@@ -39,6 +43,9 @@ data LocalBackend = LocalBackend {
3943 -- | @findPeers t@ sends out a /who's there?/ request, waits 't' msec,
4044 -- and then collects and returns the answers
4145 , findPeers :: Int -> IO [NodeId]
46+ -- | Make sure that all log messages are printed by the logger on the
47+ -- current node
48+ , redirectLogsHere :: Process ()
4249 }
4350
4451data LocalBackendState = LocalBackendState {
@@ -58,10 +65,13 @@ initializeBackend host port rtable = do
5865 forkIO $ peerDiscoveryDaemon backendState recv send
5966 case mTransport of
6067 Left err -> throw err
61− Right transport -> return LocalBackend {
62− newLocalNode = apiNewLocalNode transport rtable backendState
63− , findPeers = apiFindPeers send backendState
64− }
68+ Right transport ->
69+ let backend = LocalBackend {
70+ newLocalNode = apiNewLocalNode transport rtable backendState
71+ , findPeers = apiFindPeers send backendState
72+ , redirectLogsHere = apiRedirectLogsHere backend
73+ }
74+ in return backend
6575
6676-- | Create a new local node
6777apiNewLocalNode :: NT.Transport
@@ -113,6 +123,18 @@ peerDiscoveryDaemon backendState recv send = forever go
113123 PeerDiscoveryReply nid ->
114124 modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
115125
126+--------------------------------------------------------------------------------
127+-- Back-end specific primitives --
128+--------------------------------------------------------------------------------
129+
130+-- | Make sure that all log messages are printed by the logger on this node
131+apiRedirectLogsHere :: LocalBackend -> Process ()
132+apiRedirectLogsHere backend = do
133+ mLogger <- whereis "logger"
134+ forM_ mLogger $ \logger -> do
135+ nids <- liftIO $ findPeers backend 1000000
136+ forM_ nids $ \nid -> registerRemote nid "logger" logger
137+
116138--------------------------------------------------------------------------------
117139-- Accessors --
118140--------------------------------------------------------------------------------