diff options
| -rw-r--r-- | main/Test.hs | 9 | ||||
| -rw-r--r-- | src/Erebos/Network.hs | 15 |
2 files changed, 22 insertions, 2 deletions
diff --git a/main/Test.hs b/main/Test.hs index 84cce1a..da45846 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -675,9 +675,16 @@ cmdStartServer = do } ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" + serviceTracers <- forM (map fst $ filter (("trace" `elem`) . snd) serviceNames) $ \case + sname -> throwOtherError $ "tracer not implemented for ‘" <> T.unpack sname <> "’" + + let serverOptions' = serverOptions + { serverServicePacketTracers = serviceTracers + } + let logPrint str = do BC.hPutStrLn stdout (BC.pack str) hFlush stdout - rsServer <- liftIO $ startServer serverOptions h logPrint services + rsServer <- liftIO $ startServer serverOptions' h logPrint services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer 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 |