diff options
| -rw-r--r-- | main/Main.hs | 21 | ||||
| -rw-r--r-- | src/Erebos/Discovery.hs | 25 |
2 files changed, 44 insertions, 2 deletions
diff --git a/main/Main.hs b/main/Main.hs index f3fa0b8..da71e6a 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -204,6 +204,25 @@ options = tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ] return $ \_ _ -> False +debugOptions :: [ OptDescr (Options -> Writer [ String ] Options) ] +debugOptions = + [ Option [] [ "discovery-debug-log" ] + (NoArg (serviceAttr $ \attrs -> return attrs { discoveryDebugLog = True })) + "" + ] + where + updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService + updateService f some@(SomeService proxy attrs) + | Just f' <- cast f = SomeService proxy <$> f' attrs + | otherwise = return some + + serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options + serviceAttr f opts = do + services' <- forM (optServices opts) $ \sopt -> do + service <- updateService f (soptService sopt) + return sopt { soptService = service } + return opts { optServices = services' } + servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ] servicesOptions = concatMap helper $ "all" : map soptName availableServices where @@ -233,7 +252,7 @@ main = do progName <- getProgName hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information." exitFailure - (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case + (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions ++ debugOptions) <$> getArgs) >>= \case (wo, args, []) -> case runWriter (foldM (flip ($)) defaultOptions wo) of ( o, [] ) -> return ( o, args ) diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 11156da..16b67e6 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -67,6 +67,7 @@ data DiscoveryAttributes = DiscoveryAttributes , discoveryTurnPort :: Maybe Word16 , discoveryTurnServer :: Maybe Text , discoveryProvideTunnel :: Peer -> PeerAddress -> Bool + , discoveryDebugLog :: Bool } defaultDiscoveryAttributes :: DiscoveryAttributes @@ -76,6 +77,7 @@ defaultDiscoveryAttributes = DiscoveryAttributes , discoveryTurnPort = Nothing , discoveryTurnServer = Nothing , discoveryProvideTunnel = \_ _ -> False + , discoveryDebugLog = False } data DiscoveryConnection = DiscoveryConnection @@ -248,6 +250,13 @@ instance Service DiscoveryService where peer <- asks svcPeer paddrs <- getPeerAddresses peer + debugLog $ unwords + [ "new peer" + , show [ refDigest $ storedRef $ idData pid, refDigest $ storedRef $ idExtData pid ] + , show $ map (refDigest . storedRef) $ idDataF $ finalOwner pid + , show paddrs + ] + let insertHelper new old | dpPriority new > dpPriority old = new | otherwise = old @@ -288,6 +297,7 @@ instance Service DiscoveryService where } DiscoverySearch edgst -> do + pid <- asks svcPeerIdentity dpeer <- M.lookup (either refDigest id edgst) . dgsPeers <$> svcGetGlobal peer <- asks svcPeer paddr <- asks svcPeerAddress @@ -295,7 +305,11 @@ instance Service DiscoveryService where let offerTunnel | discoveryProvideTunnel attrs peer paddr = (++ [ DiscoveryTunnel ]) | otherwise = id - replyPacket $ DiscoveryResult edgst $ maybe [] (offerTunnel . dpAddress) dpeer + let results = maybe [] (offerTunnel . dpAddress) dpeer + replyPacket $ DiscoveryResult edgst results + debugLog $ "search by " <> show (refDigest $ storedRef $ idData pid) <> + " for " <> show (either refDigest id edgst) <> + " result [" <> T.unpack (T.intercalate "," $ map toText results) <> "]" DiscoveryResult _ [] -> do -- not found @@ -421,6 +435,8 @@ instance Service DiscoveryService where replyPacket $ DiscoveryConnectionResponse rconn | fromSource : _ <- streams -> do void $ liftIO $ forkIO $ runPeerService @DiscoveryService dpeer $ do + debugLog $ "setting up tunnel from " <> show (either refDigest id $ dconnSource conn) <> + " to " <> show (either refDigest id $ dconnTarget conn) toTarget <- openStream svcModify $ \s -> s { dpsRelayedTunnelRequests = ( either refDigest id $ dconnSource conn, ( fromSource, toTarget )) : dpsRelayedTunnelRequests s } @@ -544,6 +560,13 @@ instance Service DiscoveryService where #endif +debugLog :: String -> ServiceHandler DiscoveryService () +debugLog str = do + asks (discoveryDebugLog . svcAttributes) >>= \case + True -> svcPrint $ "discovery: " <> str + False -> return () + + identityDigests :: Foldable f => Identity f -> [ RefDigest ] identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid |