Merge branch 'release-0.1'HEADmasterdevel

2 files changed, 23 insertions, 14 deletions

diff --git a/main/Main.hs b/main/Main.hs
index 7f9250b..fa2b4c1 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -41,8 +41,8 @@ import Erebos.Contact
 import Erebos.Chatroom
 import Erebos.Conversation
 import Erebos.DirectMessage
-#ifdef ENABLE_ICE_SUPPORT
 import Erebos.Discovery
+#ifdef ENABLE_ICE_SUPPORT
 import Erebos.ICE
 #endif
 import Erebos.Identity
@@ -104,10 +104,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)]
@@ -494,9 +492,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)
@@ -840,8 +838,6 @@ cmdDetails = do
                 , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid
                 ]
 
-#ifdef ENABLE_ICE_SUPPORT
-
 cmdDiscoveryInit :: Command
 cmdDiscoveryInit = void $ do
     server <- asks ciServer
@@ -869,6 +865,8 @@ cmdDiscovery = void $ do
                  Right _ -> return ()
                  Left err -> eprint err
 
+#ifdef ENABLE_ICE_SUPPORT
+
 cmdIceCreate :: Command
 cmdIceCreate = do
     role <- asks ciLine >>= return . \case
diff --git a/main/Test.hs b/main/Test.hs
index 3db50bd..35cc982 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Test (
     runTestTool,
 ) where
@@ -458,21 +460,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