diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 10 | ||||
| -rw-r--r-- | main/Test.hs | 27 |
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 |