Merge branch 'release-0.1'HEADmasterdevel

11 files changed, 139 insertions, 58 deletions

diff --git a/erebos.cabal b/erebos.cabal
index e610d94..ccf1e42 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -98,6 +98,7 @@ library
         Erebos.Contact
         Erebos.Conversation
         Erebos.DirectMessage
+        Erebos.Discovery
         Erebos.Identity
         Erebos.Network
         Erebos.Network.Channel
@@ -132,7 +133,6 @@ library
 
     if flag(ice)
         exposed-modules:
-            Erebos.Discovery
             Erebos.ICE
         c-sources:
             src/Erebos/ICE/pjproject.c
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
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index 459af71..8003141 100644
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Erebos.Discovery (
     DiscoveryService(..),
     DiscoveryConnection(..)
@@ -16,7 +18,9 @@ import qualified Data.Text as T
 
 import Network.Socket
 
+#ifdef ENABLE_ICE_SUPPORT
 import Erebos.ICE
+#endif
 import Erebos.Identity
 import Erebos.Network
 import Erebos.Object
@@ -39,11 +43,18 @@ data DiscoveryConnection = DiscoveryConnection
     { dconnSource :: Ref
     , dconnTarget :: Ref
     , dconnAddress :: Maybe Text
+#ifdef ENABLE_ICE_SUPPORT
     , dconnIceSession :: Maybe IceRemoteInfo
+#endif
     }
 
 emptyConnection :: Ref -> Ref -> DiscoveryConnection
-emptyConnection source target = DiscoveryConnection source target Nothing Nothing
+emptyConnection dconnSource dconnTarget = DiscoveryConnection {..}
+  where
+    dconnAddress = Nothing
+#ifdef ENABLE_ICE_SUPPORT
+    dconnIceSession = Nothing
+#endif
 
 instance Storable DiscoveryService where
     store' x = storeRec $ do
@@ -65,7 +76,9 @@ instance Storable DiscoveryService where
                   storeRawRef "source" $ dconnSource conn
                   storeRawRef "target" $ dconnTarget conn
                   storeMbText "address" $ dconnAddress conn
+#ifdef ENABLE_ICE_SUPPORT
                   storeMbRef "ice-session" $ dconnIceSession conn
+#endif
 
     load' = loadRec $ msum
             [ DiscoverySelf
@@ -87,13 +100,17 @@ instance Storable DiscoveryService where
                       <$> loadRawRef "source"
                       <*> loadRawRef "target"
                       <*> loadMbText "address"
+#ifdef ENABLE_ICE_SUPPORT
                       <*> loadMbRef "ice-session"
+#endif
 
 data DiscoveryPeer = DiscoveryPeer
     { dpPriority :: Int
     , dpPeer :: Maybe Peer
     , dpAddress :: Maybe Text
+#ifdef ENABLE_ICE_SUPPORT
     , dpIceSession :: Maybe IceSession
+#endif
     }
 
 instance Service DiscoveryService where
@@ -116,8 +133,14 @@ instance Service DiscoveryService where
                                 else Nothing
                 _ -> return Nothing
             forM_ (idDataF =<< unfoldOwners pid) $ \s ->
-                svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) $
-                    DiscoveryPeer priority (Just peer) mbaddr Nothing
+                svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) DiscoveryPeer
+                    { dpPriority = priority
+                    , dpPeer = Just peer
+                    , dpAddress = mbaddr
+#ifdef ENABLE_ICE_SUPPORT
+                    , dpIceSession = Nothing
+#endif
+                    }
             replyPacket $ DiscoveryAcknowledged $ fromMaybe (T.pack "ICE") mbaddr
 
         DiscoveryAcknowledged addr -> do
@@ -143,6 +166,7 @@ instance Service DiscoveryService where
             server <- asks svcServer
             if addr == T.pack "ICE"
                then do
+#ifdef ENABLE_ICE_SUPPORT
                     self <- svcSelf
                     peer <- asks svcPeer
                     ice <- liftIO $ iceCreate PjIceSessRoleControlling $ \ice -> do
@@ -155,18 +179,28 @@ instance Service DiscoveryService where
 
                     svcModifyGlobal $ M.insert (refDigest ref) $
                         DiscoveryPeer 0 Nothing Nothing (Just ice)
+#else
+                    return ()
+#endif
                else do
                     case words (T.unpack addr) of
                         [ipaddr, port] -> do
                             saddr <- liftIO $ head <$>
                                 getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port)
                             peer <- liftIO $ serverPeer server (addrAddress saddr)
-                            svcModifyGlobal $ M.insert (refDigest ref) $
-                                DiscoveryPeer 0 (Just peer) Nothing Nothing
+                            svcModifyGlobal $ M.insert (refDigest ref) DiscoveryPeer
+                                { dpPriority = 0
+                                , dpPeer = Just peer
+                                , dpAddress = Nothing
+#ifdef ENABLE_ICE_SUPPORT
+                                , dpIceSession = Nothing
+#endif
+                                }
 
                         _ -> svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr
 
         DiscoveryConnectionRequest conn -> do
+#ifdef ENABLE_ICE_SUPPORT
             self <- svcSelf
             let rconn = emptyConnection (dconnSource conn) (dconnTarget conn)
             if refDigest (dconnTarget conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self)
@@ -194,8 +228,12 @@ instance Service DiscoveryService where
                                 | Just dpeer <- dpPeer dp -> do
                                     sendToPeer dpeer $ DiscoveryConnectionRequest conn
                                 | otherwise -> svcPrint $ "Discovery: failed to relay connection request"
+#else
+            return ()
+#endif
 
         DiscoveryConnectionResponse conn -> do
+#ifdef ENABLE_ICE_SUPPORT
             self <- svcSelf
             dpeers <- svcGetGlobal
             if refDigest (dconnSource conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self)
@@ -222,3 +260,6 @@ instance Service DiscoveryService where
                         Just dp | Just dpeer <- dpPeer dp -> do
                             sendToPeer dpeer $ DiscoveryConnectionResponse conn
                         _ -> svcPrint $ "Discovery: failed to relay connection response"
+#else
+            return ()
+#endif
diff --git a/test/attach.test b/test/attach.test
index 33a1483..afbdd0e 100644
--- a/test/attach.test
+++ b/test/attach.test
@@ -1,12 +1,14 @@
 test:
+	let services = "attach,sync"
+
 	spawn as p1
 	spawn as p2
 	send "create-identity Device1 Owner" to p1
 	send "create-identity Device2" to p2
 	send "watch-local-identity" to p1
 	send "watch-local-identity" to p2
-	send "start-server" to p1
-	send "start-server" to p2
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
 	expect from p1:
 		/local-identity Device1 Owner/
 		/peer 1 addr ${p2.node.ip} 29665/
diff --git a/test/chatroom.test b/test/chatroom.test
index 4dda21e..862087d 100644
--- a/test/chatroom.test
+++ b/test/chatroom.test
@@ -1,4 +1,6 @@
 test ChatroomSetup:
+	let services = "chatroom"
+
 	# Local chatrooms
 
 	spawn as p1
@@ -30,7 +32,7 @@ test ChatroomSetup:
 	for p in [ p1, p2, p3 ]:
 		with p:
 			send "chatroom-watch-local"
-			send "start-server"
+			send "start-server services $services"
 
 	for p in [ p2, p3 ]:
 		with p:
@@ -97,6 +99,8 @@ test ChatroomSetup:
 
 
 test ChatroomMessages:
+	let services = "chatroom"
+
 	spawn as p1
 	spawn as p2
 
@@ -106,7 +110,7 @@ test ChatroomMessages:
 	for p in [ p1, p2 ]:
 		with p:
 			send "chatroom-watch-local"
-			send "start-server"
+			send "start-server services $services"
 
 	send "chatroom-create first_room" to p1
 	expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1
@@ -159,7 +163,7 @@ test ChatroomMessages:
 	spawn as p3
 	send "create-identity Device3 Owner3" to p3
 	send "chatroom-watch-local" to p3
-	send "start-server" to p3
+	send "start-server services $services" to p3
 	expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/  from p3 capture room1_p3
 	expect /chatroom-watched-added ([a-z0-9#]+) second_room sub false/ from p3 capture room2_p3
 	expect /chatroom-watched-added ([a-z0-9#]+) third_room sub false/  from p3 capture room3_p3
@@ -242,6 +246,8 @@ test ChatroomMessages:
 
 
 test ChatroomSubscribedBeforeStart:
+	let services = "chatroom"
+
 	spawn as p1
 	spawn as p2
 
@@ -251,7 +257,7 @@ test ChatroomSubscribedBeforeStart:
 	for p in [ p1, p2 ]:
 		with p:
 			send "chatroom-watch-local"
-			send "start-server"
+			send "start-server services $services"
 
 	send "chatroom-create first_room" to p1
 	expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1
@@ -271,7 +277,7 @@ test ChatroomSubscribedBeforeStart:
 			expect /stop-server-done/
 	for p in [p1, p2]:
 		with p:
-			send "start-server"
+			send "start-server services $services"
 
 	send "chatroom-message-send $room1_p1 message1" to p1
 	expect /chatroom-message-new $room1_p1 room first_room from Owner1 text message1/ from p1
@@ -283,6 +289,8 @@ test ChatroomSubscribedBeforeStart:
 
 
 test ParallelThreads:
+	let services = "chatroom"
+
 	spawn as p1
 	spawn as p2
 
@@ -292,7 +300,7 @@ test ParallelThreads:
 	for p in [ p1, p2 ]:
 		with p:
 			send "chatroom-watch-local"
-			send "start-server"
+			send "start-server services $services"
 
 	send "chatroom-create first_room" to p1
 	expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1
@@ -330,7 +338,7 @@ test ParallelThreads:
 
 	for p in [p1, p2]:
 		with p:
-			send "start-server"
+			send "start-server services $services"
 
 	with p1:
 		expect /chatroom-message-new $room1_p1 room first_room from Owner. text message(..)/ capture msg
@@ -347,6 +355,8 @@ test ParallelThreads:
 
 
 test ChatroomMembers:
+	let services = "chatroom"
+
 	spawn as p1
 	spawn as p2
 	spawn as p3
@@ -358,7 +368,7 @@ test ChatroomMembers:
 	for p in [ p1, p2, p3 ]:
 		with p:
 			send "chatroom-watch-local"
-			send "start-server"
+			send "start-server services $services"
 
 	send "chatroom-create first_room" to p1
 	expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1
@@ -432,6 +442,8 @@ test ChatroomMembers:
 
 
 test ChatroomIdentity:
+	let services = "chatroom"
+
 	spawn as p1
 	spawn as p2
 
@@ -441,7 +453,7 @@ test ChatroomIdentity:
 	for p in [ p1, p2 ]:
 		with p:
 			send "chatroom-watch-local"
-			send "start-server"
+			send "start-server services $services"
 
 	send "chatroom-create first_room" to p1
 	expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1
diff --git a/test/contact.test b/test/contact.test
index 438aa1f..978f8a6 100644
--- a/test/contact.test
+++ b/test/contact.test
@@ -1,4 +1,6 @@
 test Contact:
+	let services = "attach,contact,sync"
+	
 	spawn as p1
 	spawn as p2
 	spawn as p3
@@ -9,10 +11,10 @@ test Contact:
 	send "create-identity Device3 Owner3" to p3
 	send "create-identity Device4"        to p4
 
-	send "start-server" to p1
-	send "start-server" to p2
-	send "start-server" to p3
-	send "start-server" to p4
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
+	send "start-server services $services" to p3
+	send "start-server services $services" to p4
 
 	expect from p1:
 		/peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2
diff --git a/test/message.test b/test/message.test
index 307f11a..c0e251b 100644
--- a/test/message.test
+++ b/test/message.test
@@ -1,10 +1,12 @@
 test DirectMessage:
+	let services = "contact,dm"
+
 	spawn as p1
 	spawn as p2
 	send "create-identity Device1 Owner1" to p1
 	send "create-identity Device2 Owner2" to p2
-	send "start-server" to p1
-	send "start-server" to p2
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
 
 	expect from p1:
 		/peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2
@@ -96,7 +98,7 @@ test DirectMessage:
 			expect /stop-server-done/
 	for p in [p1, p2]:
 		with p:
-			send "start-server"
+			send "start-server services $services"
 
 	with p1:
 		send "contact-list"
@@ -126,10 +128,10 @@ test DirectMessage:
 	for p in [p1, p2]:
 		with p:
 			expect /stop-server-done/
-	send "start-server" to p2
+	send "start-server services $services" to p2
 
 	send "dm-send-contact $c1_2 while_offline" to p1
-	send "start-server" to p1
+	send "start-server services $services" to p1
 
 	expect /dm-received from Owner1 text while_offline/ from p2
 
@@ -139,11 +141,11 @@ test DirectMessage:
 	for p in [p1, p2]:
 		with p:
 			expect /stop-server-done/
-	send "start-server" to p1
+	send "start-server services $services" to p1
 
 	send "dm-send-contact $c1_2 while_peer_offline" to p1
 	# TODO: sync from p1 on peer p2 discovery not ensured without addition wait
 	#wait
-	send "start-server" to p2
+	send "start-server services $services" to p2
 
 	expect /dm-received from Owner1 text while_peer_offline/ from p2
diff --git a/test/network.test b/test/network.test
index 40190f4..52fcbee 100644
--- a/test/network.test
+++ b/test/network.test
@@ -120,12 +120,14 @@ test Discovery:
 
 
 test LargeData:
+	let services = "test"
+
 	spawn as p1
 	spawn as p2
 	send "create-identity Device1" to p1
 	send "create-identity Device2" to p2
-	send "start-server" to p1
-	send "start-server" to p2
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
 	expect from p1:
 		/peer 1 addr ${p2.node.ip} 29665/
 		/peer 1 id Device2/
@@ -149,12 +151,14 @@ test LargeData:
 
 
 test ManyStreams:
+	let services = "test"
+
 	spawn as p1
 	spawn as p2
 	send "create-identity Device1" to p1
 	send "create-identity Device2" to p2
-	send "start-server" to p1
-	send "start-server" to p2
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
 	expect from p1:
 		/peer 1 addr ${p2.node.ip} 29665/
 		/peer 1 id Device2/
@@ -179,12 +183,14 @@ test ManyStreams:
 
 
 test MultipleServiceRefs:
+	let services = "test"
+
 	spawn as p1
 	spawn as p2
 	send "create-identity Device1" to p1
 	send "create-identity Device2" to p2
-	send "start-server" to p1
-	send "start-server" to p2
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
 	expect from p1:
 		/peer 1 addr ${p2.node.ip} 29665/
 		/peer 1 id Device2/
@@ -235,16 +241,18 @@ test MultipleServiceRefs:
 
 
 test Reconnection:
+	let services = "test"
+
 	spawn as p1
 	with p1:
 		send "create-identity Device1"
-		send "start-server"
+		send "start-server services $services"
 
 	node n
 	local:
 		spawn as p2 on n
 		send "create-identity Device2" to p2
-		send "start-server" to p2
+		send "start-server services $services" to p2
 
 		expect from p1:
 			/peer 1 addr ${p2.node.ip} 29665/
@@ -272,7 +280,7 @@ test Reconnection:
 	# Restart process on node 'n'
 	local:
 		spawn as p2 on n
-		send "start-server" to p2
+		send "start-server services $services" to p2
 		send "peer-add ${p1.node.ip}" to p2
 
 		expect from p2:
@@ -383,6 +391,7 @@ test Reconnection:
 
 
 test SendUnknownObjectType:
+	let services = "test"
 	let refpat = /blake2#[0-9a-f]*/
 
 	spawn as p1
@@ -390,10 +399,10 @@ test SendUnknownObjectType:
 
 	with p1:
 		send "create-identity Device1"
-		send "start-server"
+		send "start-server services $services"
 	with p2:
 		send "create-identity Device2"
-		send "start-server"
+		send "start-server services $services"
 
 	expect from p1:
 		/peer 1 addr ${p2.node.ip} 29665/
diff --git a/test/storage.test b/test/storage.test
index db9e0a1..a5cca7f 100644
--- a/test/storage.test
+++ b/test/storage.test
@@ -381,14 +381,16 @@ test StorageWatcher:
 
 
 test SharedStateWatcher:
+	let services = "attach,sync"
+
 	spawn as p1
 	spawn as p2
 	send "create-identity Device1 Owner" to p1
 	send "create-identity Device2" to p2
 	send "watch-local-identity" to p1
 	send "watch-local-identity" to p2
-	send "start-server" to p1
-	send "start-server" to p2
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
 	expect from p1:
 		/local-identity Device1 Owner/
 		/peer 1 addr ${p2.node.ip} 29665/
diff --git a/test/sync.test b/test/sync.test
index ea9595d..d465b11 100644
--- a/test/sync.test
+++ b/test/sync.test
@@ -1,4 +1,6 @@
 test:
+	let services = "attach,sync"
+
 	spawn as p1
 	spawn as p2
 	send "create-identity Device1 Owner" to p1
@@ -7,8 +9,8 @@ test:
 	send "watch-local-identity" to p2
 	send "watch-shared-identity" to p1
 	send "watch-shared-identity" to p2
-	send "start-server" to p1
-	send "start-server" to p2
+	send "start-server services $services" to p1
+	send "start-server services $services" to p2
 	expect from p1:
 		/local-identity Device1 Owner/
 		/shared-identity Owner/
@@ -57,7 +59,7 @@ test:
 		send "create-identity Device3"
 		send "watch-local-identity"
 		send "watch-shared-identity"
-		send "start-server"
+		send "start-server services $services"
 
 		send "peer-add ${p1.node.ip}"