diff options
Diffstat (limited to 'src/Erebos')
| -rw-r--r-- | src/Erebos/Network.hs | 15 |
1 files changed, 14 insertions, 1 deletions
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index 609bb4c..2f3b278 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -7,6 +7,7 @@ module Erebos.Network ( getNextPeerChangeChan, getServerAddresses, ServerOptions(..), serverIdentity, defaultServerOptions, + ServicePacketTracer, servicePacketTracer, Peer, peerServer, peerStorage, PeerAddress(..), getPeerAddress, getPeerAddresses, @@ -131,6 +132,7 @@ data ServerOptions = ServerOptions , serverLocalDiscovery :: Bool , serverErrorPrefix :: String , serverTestLog :: Bool + , serverServicePacketTracers :: [ ServicePacketTracer ] } defaultServerOptions :: ServerOptions @@ -140,8 +142,14 @@ defaultServerOptions = ServerOptions , serverLocalDiscovery = True , serverErrorPrefix = "" , serverTestLog = False + , serverServicePacketTracers = [] } +data ServicePacketTracer = forall s. Service s => ServicePacketTracer (Peer -> PeerAddress -> Stored s -> IO ()) + +servicePacketTracer :: forall s. Service s => (Peer -> PeerAddress -> Stored s -> IO ()) -> ServicePacketTracer +servicePacketTracer = ServicePacketTracer + data Peer = Peer { peerAddress :: PeerAddress @@ -467,7 +475,12 @@ startServer serverOptions serverOrigHead logd' serverServices = do forkServerThread server "service-handler" $ forever $ do ( peer, paddr, svc, ref, streams ) <- atomically $ readTQueue chanSvc case find ((svc ==) . someServiceID) serverServices of - Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just ( service, attr )) streams paddr peer (serviceHandler $ wrappedLoad @s ref) + Just service@(SomeService (_ :: Proxy s) attr) -> do + let packet = wrappedLoad @s ref + forM_ (serverServicePacketTracers serverOptions) $ \case + ServicePacketTracer t | Just (t' :: Peer -> PeerAddress -> Stored s -> IO ()) <- cast t -> t' peer paddr packet + _ -> return () + runPeerServiceOn (Just ( service, attr )) streams paddr peer (serviceHandler packet) _ -> atomically $ logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" return server |