diff options
| author | Roman Smrž <roman.smrz@seznam.cz> | 2026-08-22 08:45:55 +0200 |
|---|---|---|
| committer | Roman Smrž <roman.smrz@seznam.cz> | 2026-08-23 22:10:06 +0200 |
| commit | 1256ce3e896b359de0ff95069e3a977cf515dc61 (patch) | |
| tree | c2487cb6b46085043e472a64fffe877e01c81538 /main/Test.hs | |
| parent | a3dc644a30796bf0ed2a19d6693aaec7c9374d4e (diff) | |
Diffstat (limited to 'main/Test.hs')
| -rw-r--r-- | main/Test.hs | 15 |
1 files changed, 15 insertions, 0 deletions
diff --git a/main/Test.hs b/main/Test.hs index da45846..02534fd 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -238,6 +238,20 @@ discoveryAttributes = (defaultServiceAttributes Proxy) { discoveryProvideTunnel = \_ _ -> False } +discoveryTracer :: Output -> Peer -> PeerAddress -> Stored DiscoveryService -> IO () +discoveryTracer out _ paddr spacket = case fromStored spacket of + DiscoverySearch dgst -> do + outLine out $ "discovery-packet " <> show paddr <> " search " <> show (either refDigest id dgst) + DiscoveryResult dgst results via -> do + outLine out $ "discovery-packet " <> show paddr <> " result " <> show (either refDigest id dgst) + forM_ results $ \addr -> do + outLine out $ "discovery-packet-result result " <> T.unpack (toText addr) + forM_ via $ \DiscoveryVia {..} -> do + forM_ viaAddress $ \addr -> do + outLine out $ "discovery-packet-result via " <> show viaIdentity <> " addr " <> T.unpack (toText addr) + outLine out $ "discovery-packet-result done" + _ -> return () + inviteAttributes :: Output -> InviteServiceAttributes inviteAttributes out = (defaultServiceAttributes Proxy) { inviteHookAccepted = \Invite {..} -> do @@ -676,6 +690,7 @@ cmdStartServer = do ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" serviceTracers <- forM (map fst $ filter (("trace" `elem`) . snd) serviceNames) $ \case + "discovery" -> return $ servicePacketTracer $ discoveryTracer out sname -> throwOtherError $ "tracer not implemented for ‘" <> T.unpack sname <> "’" let serverOptions' = serverOptions |