From 9a401324f20334ca06c77ea09ab005f9ab7e80dc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Mon, 30 Dec 2024 22:40:39 +0100
Subject: Build discovery service without requiring ICE support

Changelog: Discovery service without requiring ICE support
---
 main/Main.hs | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

(limited to 'main')

diff --git a/main/Main.hs b/main/Main.hs
index 73def51..000bbf9 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -40,8 +40,8 @@ import Erebos.Attach
 import Erebos.Contact
 import Erebos.Chatroom
 import Erebos.Conversation
-#ifdef ENABLE_ICE_SUPPORT
 import Erebos.Discovery
+#ifdef ENABLE_ICE_SUPPORT
 import Erebos.ICE
 #endif
 import Erebos.Identity
@@ -102,10 +102,8 @@ availableServices =
         True "create contacts with network peers"
     , ServiceOption "dm" (someService @DirectMessage Proxy)
         True "direct messages"
-#ifdef ENABLE_ICE_SUPPORT
     , ServiceOption "discovery" (someService @DiscoveryService Proxy)
         True "peer discovery"
-#endif
     ]
 
 options :: [OptDescr (Options -> Options)]
@@ -492,9 +490,9 @@ commands =
     , ("contact-reject", cmdContactReject)
     , ("conversations", cmdConversations)
     , ("details", cmdDetails)
-#ifdef ENABLE_ICE_SUPPORT
     , ("discovery-init", cmdDiscoveryInit)
     , ("discovery", cmdDiscovery)
+#ifdef ENABLE_ICE_SUPPORT
     , ("ice-create", cmdIceCreate)
     , ("ice-destroy", cmdIceDestroy)
     , ("ice-show", cmdIceShow)
@@ -838,8 +836,6 @@ cmdDetails = do
                 , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid
                 ]
 
-#ifdef ENABLE_ICE_SUPPORT
-
 cmdDiscoveryInit :: Command
 cmdDiscoveryInit = void $ do
     server <- asks ciServer
@@ -867,6 +863,8 @@ cmdDiscovery = void $ do
                  Right _ -> return ()
                  Left err -> eprint err
 
+#ifdef ENABLE_ICE_SUPPORT
+
 cmdIceCreate :: Command
 cmdIceCreate = do
     role <- asks ciLine >>= return . \case
-- 
cgit v1.2.3


From 0f83948e7f5cad486cb8c8e18b39ebbbfbfa8d98 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 3 Jan 2025 17:20:51 +0100
Subject: Test: explicit list of services for start-server

---
 main/Test.hs | 27 +++++++++++++++++++--------
 1 file changed, 19 insertions(+), 8 deletions(-)

(limited to 'main')

diff --git a/main/Test.hs b/main/Test.hs
index 1b156ae..4314852 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Test (
     runTestTool,
 ) where
@@ -448,21 +450,30 @@ cmdStartServer :: Command
 cmdStartServer = do
     out <- asks tiOutput
 
+    let parseParams = \case
+            (name : value : rest)
+                | name == "services" -> T.splitOn "," value
+                | otherwise -> parseParams rest
+            _ -> []
+    serviceNames <- parseParams <$> asks tiParams
+
     h <- getOrLoadHead
     rsPeers <- liftIO $ newMVar (1, [])
-    rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack)
-        [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
-        , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
-        , someServiceAttr $ directMessageAttributes out
-        , someService @SyncService Proxy
-        , someService @ChatroomService Proxy
-        , someServiceAttr $ (defaultServiceAttributes Proxy)
+    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"
+        "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
                     outLine out $ unwords ["test-message-received", otype, len, sref]
             }
-        ]
+        sname -> throwError $ "unknown service `" <> T.unpack sname <> "'"
+
+    rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
 
     rsPeerThread <- liftIO $ forkIO $ void $ forever $ do
         peer <- getNextPeerChange rsServer
-- 
cgit v1.2.3