Merge branch 'release-0.1'HEADmaster

1 files changed, 31 insertions, 0 deletions

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