git.iko.soy/distributed-process
on master help sign in
Implement centralized logging in the local backend
abcaed4Edsko de Vries
distributed-process/src/Control/Distributed/Process/Backend/Local.hs+27−5
compare with master
unifiedsplit
@@ -10,15 +10,18 @@ import Data.Binary (Binary(get, put), getWord8, putWord8)
10import Data.Accessor (Accessor, accessor, (^:), (^.))
10import Data.Accessor (Accessor, accessor, (^:), (^.))
11import Data.Set (Set)
11import Data.Set (Set)
12import qualified Data.Set as Set (insert, empty, toList)
12import qualified Data.Set as Set (insert, empty, toList)
13+import Data.Foldable (forM_)
13import Control.Applicative ((<$>))
14import Control.Applicative ((<$>))
14import Control.Exception (throw)
15import Control.Exception (throw)
15−import Control.Monad (forM_, forever)
16+import Control.Monad (forever)
17+import Control.Monad.IO.Class (liftIO)
16import Control.Concurrent (forkIO, threadDelay)
18import Control.Concurrent (forkIO, threadDelay)
17import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
19import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
18import Control.Distributed.Process.Internal.Types
20import Control.Distributed.Process.Internal.Types
19 ( LocalNode
21 ( LocalNode
20 , RemoteTable
22 , RemoteTable
21 , NodeId
23 , NodeId
24+ , Process
22 )
25 )
23import qualified Control.Distributed.Process.Node as Node
26import qualified Control.Distributed.Process.Node as Node
24 ( newLocalNode
27 ( newLocalNode
@@ -31,6 +34,7 @@ import qualified Network.Transport.TCP as NT
31import qualified Network.Transport as NT (Transport)
34import qualified Network.Transport as NT (Transport)
32import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
35import qualified Network.Socket as N (HostName, ServiceName, SockAddr)
33import Control.Distributed.Process.Internal.Multicast (initMulticast)
36import Control.Distributed.Process.Internal.Multicast (initMulticast)
37+import Control.Distributed.Process.Internal.Primitives (whereis, registerRemote)
34
38
35-- | Local backend
39-- | Local backend
36data LocalBackend = LocalBackend {
40data LocalBackend = LocalBackend {
@@ -39,6 +43,9 @@ data LocalBackend = LocalBackend {
39 -- | @findPeers t@ sends out a /who's there?/ request, waits 't' msec,
43 -- | @findPeers t@ sends out a /who's there?/ request, waits 't' msec,
40 -- and then collects and returns the answers
44 -- and then collects and returns the answers
41 , findPeers :: Int -> IO [NodeId]
45 , findPeers :: Int -> IO [NodeId]
46+ -- | Make sure that all log messages are printed by the logger on the
47+ -- current node
48+ , redirectLogsHere :: Process ()
42 }
49 }
43
50
44data LocalBackendState = LocalBackendState {
51data LocalBackendState = LocalBackendState {
@@ -58,10 +65,13 @@ initializeBackend host port rtable = do
58 forkIO $ peerDiscoveryDaemon backendState recv send
65 forkIO $ peerDiscoveryDaemon backendState recv send
59 case mTransport of
66 case mTransport of
60 Left err -> throw err
67 Left err -> throw err
61− Right transport -> return LocalBackend {
68+ Right transport ->
69+ let backend = LocalBackend {
62− newLocalNode = apiNewLocalNode transport rtable backendState
70+ newLocalNode = apiNewLocalNode transport rtable backendState
63− , findPeers = apiFindPeers send backendState
71+ , findPeers = apiFindPeers send backendState
72+ , redirectLogsHere = apiRedirectLogsHere backend
64− }
73+ }
74+ in return backend
65
75
66-- | Create a new local node
76-- | Create a new local node
67apiNewLocalNode :: NT.Transport
77apiNewLocalNode :: NT.Transport
@@ -113,6 +123,18 @@ peerDiscoveryDaemon backendState recv send = forever go
113 PeerDiscoveryReply nid ->
123 PeerDiscoveryReply nid ->
114 modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
124 modifyMVar_ backendState $ return . (peers ^: Set.insert nid)
115
125
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+
116--------------------------------------------------------------------------------
138--------------------------------------------------------------------------------
117-- Accessors --
139-- Accessors --
118--------------------------------------------------------------------------------
140--------------------------------------------------------------------------------
distributed-process/tests/TestLocalBackend.hs+4−7
@@ -13,20 +13,17 @@ import Control.Monad.IO.Class (liftIO)
13server :: LocalBackend -> IO ()
13server :: LocalBackend -> IO ()
14server backend = do
14server backend = do
15 node <- newLocalNode backend
15 node <- newLocalNode backend
16− runProcess node $
16+ runProcess node $ do
17+ redirectLogsHere backend
17 say "this is the server"
18 say "this is the server"
18− {-
19− nodes <- findPeers backend 1000000
20− print nodes
21− -}
22 threadDelay 30000000
19 threadDelay 30000000
23
20
24client :: LocalBackend -> IO ()
21client :: LocalBackend -> IO ()
25client backend = do
22client backend = do
26 node <- newLocalNode backend
23 node <- newLocalNode backend
27 forkProcess node . forever $ do
24 forkProcess node . forever $ do
28− say "this is a client node1"
25+ say "this is a client"
29− liftIO $ threadDelay 5000000
26+ liftIO $ threadDelay 2000000
30 threadDelay 30000000
27 threadDelay 30000000
31
28
32main :: IO ()
29main :: IO ()