summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2025-07-13 16:59:25 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2025-07-13 17:07:56 +0200
commit4382df549583ea2823580891461e588091d42044 (patch)
tree9d715f36285c19c9baa66c1348442b4c74f79f92
parent5667e01bfbdacbd6619e75172f1c6201b15d3647 (diff)
Test: service parameter to enable discovery tunnelHEADmaster
-rw-r--r--main/Test.hs28
-rw-r--r--test/discovery.test2
2 files changed, 19 insertions, 11 deletions
diff --git a/main/Test.hs b/main/Test.hs
index b07bd87..c978a6a 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -229,7 +229,7 @@ directMessageAttributes out = DirectMessageAttributes
discoveryAttributes :: DiscoveryAttributes
discoveryAttributes = (defaultServiceAttributes Proxy)
- { discoveryProvideTunnel = const True
+ { discoveryProvideTunnel = const False
}
dmReceivedWatcher :: Output -> Stored DirectMessage -> IO ()
@@ -507,18 +507,26 @@ cmdStartServer = do
| name == "services" -> T.splitOn "," value
| otherwise -> parseParams rest
_ -> []
- serviceNames <- parseParams <$> asks tiParams
+
+ splitServiceParams svc =
+ case T.splitOn ":" svc of
+ name : params -> ( name, params )
+ _ -> ( svc, [] )
+
+ serviceNames <- map splitServiceParams . parseParams <$> asks tiParams
h <- getOrLoadHead
rsPeers <- liftIO $ newMVar (1, [])
services <- forM serviceNames $ \case
- "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
- "chatroom" -> return $ someService @ChatroomService Proxy
- "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
- "discovery" -> return $ someServiceAttr $ discoveryAttributes
- "dm" -> return $ someServiceAttr $ directMessageAttributes out
- "sync" -> return $ someService @SyncService Proxy
- "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)
+ ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
+ ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy
+ ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
+ ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes
+ { discoveryProvideTunnel = const $ "tunnel" `elem` params
+ }
+ ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out
+ ( "sync", _ ) -> return $ someService @SyncService Proxy
+ ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)
{ testMessageReceived = \obj otype len sref -> do
liftIO $ do
void $ store (headStorage h) obj
@@ -537,7 +545,7 @@ cmdStartServer = do
outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ]
go
}
- sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
+ ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
diff --git a/test/discovery.test b/test/discovery.test
index 9453e65..4b48d8b 100644
--- a/test/discovery.test
+++ b/test/discovery.test
@@ -93,7 +93,7 @@ test ManualDiscovery:
test DiscoveryTunnel:
- let services = "discovery"
+ let services = "discovery:tunnel"
subnet sd
subnet s1