diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 2 | ||||
| -rw-r--r-- | main/Test.hs | 31 |
2 files changed, 32 insertions, 1 deletions
diff --git a/main/Main.hs b/main/Main.hs index 528b8c2..6e96c14 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -849,7 +849,7 @@ cmdDiscoveryInit = void $ do [] -> ("discovery.erebosprotocol.net", show discoveryPort) addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) peer <- liftIO $ serverPeer server (addrAddress addr) - sendToPeer peer $ DiscoverySelf (T.pack "ICE") 0 + sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing modify $ \s -> s { csIcePeer = Just peer } cmdDiscovery :: Command diff --git a/main/Test.hs b/main/Test.hs index 35cc982..550e47f 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -37,6 +37,7 @@ import Erebos.Attach import Erebos.Chatroom import Erebos.Contact import Erebos.DirectMessage +import Erebos.Discovery import Erebos.Identity import Erebos.Network import Erebos.Object @@ -259,6 +260,7 @@ commands = map (T.pack *** id) , ("head-watch", cmdHeadWatch) , ("head-unwatch", cmdHeadUnwatch) , ("create-identity", cmdCreateIdentity) + , ("identity-info", cmdIdentityInfo) , ("start-server", cmdStartServer) , ("stop-server", cmdStopServer) , ("peer-add", cmdPeerAdd) @@ -297,6 +299,7 @@ commands = map (T.pack *** id) , ("chatroom-join-as", cmdChatroomJoinAs) , ("chatroom-leave", cmdChatroomLeave) , ("chatroom-message-send", cmdChatroomMessageSend) + , ("discovery-connect", cmdDiscoveryConnect) ] cmdStore :: Command @@ -455,6 +458,22 @@ cmdCreateIdentity = do , lsOther = [] } initTestHead h + cmdOut $ unwords [ "create-identity-done", "ref", show $ refDigest $ storedRef $ lsIdentity $ headObject h ] + +cmdIdentityInfo :: Command +cmdIdentityInfo = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let sidata = wrappedLoad ref + idata = fromSigned sidata + cmdOut $ unwords $ concat + [ [ "identity-info" ] + , [ "ref", T.unpack tref ] + , [ "base", show $ refDigest $ storedRef $ eiddStoredBase sidata ] + , maybe [] (\owner -> [ "owner", show $ refDigest $ storedRef owner ]) $ eiddOwner idata + , maybe [] (\name -> [ "name", T.unpack name ]) $ eiddName idata + ] cmdStartServer :: Command cmdStartServer = do @@ -473,6 +492,7 @@ cmdStartServer = do "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" "chatroom" -> return $ someService @ChatroomService Proxy "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" + "discovery" -> return $ someService @DiscoveryService Proxy "dm" -> return $ someServiceAttr $ directMessageAttributes out "sync" -> return $ someService @SyncService Proxy "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) @@ -856,3 +876,14 @@ cmdChatroomMessageSend = do [cid, msg] <- asks tiParams to <- getChatroomStateData cid void $ sendChatroomMessageByStateData to msg + +cmdDiscoveryConnect :: Command +cmdDiscoveryConnect = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + + Just RunningServer {..} <- gets tsServer + peers <- liftIO $ getCurrentPeerList rsServer + forM_ peers $ \peer -> do + sendToPeer peer $ DiscoverySearch ref |