summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--erebos.cabal2
-rw-r--r--main/Main.hs10
-rw-r--r--main/Test.hs27
-rw-r--r--src/Erebos/Discovery.hs51
-rw-r--r--test/attach.test6
-rw-r--r--test/chatroom.test30
-rw-r--r--test/contact.test10
-rw-r--r--test/message.test16
-rw-r--r--test/network.test31
-rw-r--r--test/storage.test6
-rw-r--r--test/sync.test8
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}"
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-12 10:08:11 +0000