diff options
Diffstat (limited to 'main/Test.hs')
| -rw-r--r-- | main/Test.hs | 384 |
1 files changed, 257 insertions, 127 deletions
diff --git a/main/Test.hs b/main/Test.hs index 0181575..c3dca14 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -26,7 +26,7 @@ import Data.Text qualified as T import Data.Text.Encoding import Data.Text.IO qualified as T import Data.Typeable -import Data.UUID qualified as U +import Data.UUID.Types qualified as U import Network.Socket @@ -36,17 +36,20 @@ import System.IO.Error import Erebos.Attach import Erebos.Chatroom import Erebos.Contact +import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity -import Erebos.Message import Erebos.Network +import Erebos.Object import Erebos.Pairing import Erebos.PubKey import Erebos.Service +import Erebos.Service.Stream import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage -import Erebos.Storage.Internal (unsafeStoreRawBytes) +import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Sync @@ -64,10 +67,17 @@ data TestState = TestState data RunningServer = RunningServer { rsServer :: Server - , rsPeers :: MVar (Int, [(Int, Peer)]) + , rsPeers :: MVar ( Int, [ TestPeer ] ) , rsPeerThread :: ThreadId } +data TestPeer = TestPeer + { tpIndex :: Int + , tpPeer :: Peer + , tpStreamReaders :: MVar [ (Int, StreamReader ) ] + , tpStreamWriters :: MVar [ (Int, StreamWriter ) ] + } + initTestState :: TestState initTestState = TestState { tsHead = Nothing @@ -101,7 +111,7 @@ runTestTool st = do Nothing -> return () runExceptT (evalStateT testLoop initTestState) >>= \case - Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x + Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x) Right () -> return () getLineMb :: MonadIO m => m (Maybe Text) @@ -135,17 +145,20 @@ cmdOut line = do getPeer :: Text -> CommandM Peer -getPeer spidx = do +getPeer spidx = tpPeer <$> getTestPeer spidx + +getTestPeer :: Text -> CommandM TestPeer +getTestPeer spidx = do Just RunningServer {..} <- gets tsServer - Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar rsPeers) + Just peer <- find (((read $ T.unpack spidx) ==) . tpIndex) . snd <$> liftIO (readMVar rsPeers) return peer -getPeerIndex :: MVar (Int, [(Int, Peer)]) -> ServiceHandler (PairingService a) Int +getPeerIndex :: MVar ( Int, [ TestPeer ] ) -> ServiceHandler s Int getPeerIndex pmvar = do peer <- asks svcPeer - maybe 0 fst . find ((==peer) . snd) . snd <$> liftIO (readMVar pmvar) + maybe 0 tpIndex . find ((peer ==) . tpPeer) . snd <$> liftIO (readMVar pmvar) -pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar (Int, [(Int, Peer)]) -> String -> PairingAttributes a +pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar ( Int, [ TestPeer ] ) -> String -> PairingAttributes a pairingAttributes _ out peers prefix = PairingAttributes { pairingHookRequest = return () @@ -173,7 +186,7 @@ pairingAttributes _ out peers prefix = PairingAttributes , pairingHookFailed = \case PairingUserRejected -> failed "user" PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet - PairingFailedOther str -> failed $ "other " ++ str + PairingFailedOther err -> failed $ "other " ++ showErebosError err , pairingHookVerifyFailed = failed "verify" , pairingHookRejected = failed "rejected" } @@ -214,21 +227,28 @@ directMessageAttributes out = DirectMessageAttributes { dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch" } -dmReceivedWatcher :: Output -> Stored DirectMessage -> IO () -dmReceivedWatcher out smsg = do - let msg = fromStored smsg - outLine out $ unwords - [ "dm-received" - , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg - , "text", T.unpack $ msgText msg - ] +discoveryAttributes :: DiscoveryAttributes +discoveryAttributes = (defaultServiceAttributes Proxy) + { discoveryProvideTunnel = \_ _ -> False + } + +dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () +dmThreadWatcher self out prev cur = do + forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do + outLine out $ unwords + [ if sameIdentity self (msgFrom msg) + then "dm-sent" + else "dm-received" + , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg + , "text", T.unpack $ msgText msg + ] -newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String) +newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadRandom CommandM where getRandomBytes = liftIO . getRandomBytes @@ -245,71 +265,85 @@ instance MonadHead LocalState CommandM where type Command = CommandM () -commands :: [(Text, Command)] -commands = map (T.pack *** id) - [ ("store", cmdStore) - , ("load", cmdLoad) - , ("stored-generation", cmdStoredGeneration) - , ("stored-roots", cmdStoredRoots) - , ("stored-set-add", cmdStoredSetAdd) - , ("stored-set-list", cmdStoredSetList) - , ("head-create", cmdHeadCreate) - , ("head-replace", cmdHeadReplace) - , ("head-watch", cmdHeadWatch) - , ("head-unwatch", cmdHeadUnwatch) - , ("create-identity", cmdCreateIdentity) - , ("identity-info", cmdIdentityInfo) - , ("start-server", cmdStartServer) - , ("stop-server", cmdStopServer) - , ("peer-add", cmdPeerAdd) - , ("peer-drop", cmdPeerDrop) - , ("peer-list", cmdPeerList) - , ("test-message-send", cmdTestMessageSend) - , ("local-state-get", cmdLocalStateGet) - , ("local-state-replace", cmdLocalStateReplace) - , ("local-state-wait", cmdLocalStateWait) - , ("shared-state-get", cmdSharedStateGet) - , ("shared-state-wait", cmdSharedStateWait) - , ("watch-local-identity", cmdWatchLocalIdentity) - , ("watch-shared-identity", cmdWatchSharedIdentity) - , ("update-local-identity", cmdUpdateLocalIdentity) - , ("update-shared-identity", cmdUpdateSharedIdentity) - , ("attach-to", cmdAttachTo) - , ("attach-accept", cmdAttachAccept) - , ("attach-reject", cmdAttachReject) - , ("contact-request", cmdContactRequest) - , ("contact-accept", cmdContactAccept) - , ("contact-reject", cmdContactReject) - , ("contact-list", cmdContactList) - , ("contact-set-name", cmdContactSetName) - , ("dm-send-peer", cmdDmSendPeer) - , ("dm-send-contact", cmdDmSendContact) - , ("dm-list-peer", cmdDmListPeer) - , ("dm-list-contact", cmdDmListContact) - , ("chatroom-create", cmdChatroomCreate) - , ("chatroom-delete", cmdChatroomDelete) - , ("chatroom-list-local", cmdChatroomListLocal) - , ("chatroom-watch-local", cmdChatroomWatchLocal) - , ("chatroom-set-name", cmdChatroomSetName) - , ("chatroom-subscribe", cmdChatroomSubscribe) - , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) - , ("chatroom-members", cmdChatroomMembers) - , ("chatroom-join", cmdChatroomJoin) - , ("chatroom-join-as", cmdChatroomJoinAs) - , ("chatroom-leave", cmdChatroomLeave) - , ("chatroom-message-send", cmdChatroomMessageSend) - , ("discovery-connect", cmdDiscoveryConnect) +commands :: [ ( Text, Command ) ] +commands = + [ ( "store", cmdStore ) + , ( "load", cmdLoad ) + , ( "stored-generation", cmdStoredGeneration ) + , ( "stored-roots", cmdStoredRoots ) + , ( "stored-set-add", cmdStoredSetAdd ) + , ( "stored-set-list", cmdStoredSetList ) + , ( "stored-difference", cmdStoredDifference ) + , ( "head-create", cmdHeadCreate ) + , ( "head-replace", cmdHeadReplace ) + , ( "head-watch", cmdHeadWatch ) + , ( "head-unwatch", cmdHeadUnwatch ) + , ( "create-identity", cmdCreateIdentity ) + , ( "identity-info", cmdIdentityInfo ) + , ( "start-server", cmdStartServer ) + , ( "stop-server", cmdStopServer ) + , ( "peer-add", cmdPeerAdd ) + , ( "peer-drop", cmdPeerDrop ) + , ( "peer-list", cmdPeerList ) + , ( "test-message-send", cmdTestMessageSend ) + , ( "test-stream-open", cmdTestStreamOpen ) + , ( "test-stream-close", cmdTestStreamClose ) + , ( "test-stream-send", cmdTestStreamSend ) + , ( "local-state-get", cmdLocalStateGet ) + , ( "local-state-replace", cmdLocalStateReplace ) + , ( "local-state-wait", cmdLocalStateWait ) + , ( "shared-state-get", cmdSharedStateGet ) + , ( "shared-state-wait", cmdSharedStateWait ) + , ( "watch-local-identity", cmdWatchLocalIdentity ) + , ( "watch-shared-identity", cmdWatchSharedIdentity ) + , ( "update-local-identity", cmdUpdateLocalIdentity ) + , ( "update-shared-identity", cmdUpdateSharedIdentity ) + , ( "attach-to", cmdAttachTo ) + , ( "attach-accept", cmdAttachAccept ) + , ( "attach-reject", cmdAttachReject ) + , ( "contact-request", cmdContactRequest ) + , ( "contact-accept", cmdContactAccept ) + , ( "contact-reject", cmdContactReject ) + , ( "contact-list", cmdContactList ) + , ( "contact-set-name", cmdContactSetName ) + , ( "dm-send-peer", cmdDmSendPeer ) + , ( "dm-send-contact", cmdDmSendContact ) + , ( "dm-send-identity", cmdDmSendIdentity ) + , ( "dm-list-peer", cmdDmListPeer ) + , ( "dm-list-contact", cmdDmListContact ) + , ( "chatroom-create", cmdChatroomCreate ) + , ( "chatroom-delete", cmdChatroomDelete ) + , ( "chatroom-list-local", cmdChatroomListLocal ) + , ( "chatroom-watch-local", cmdChatroomWatchLocal ) + , ( "chatroom-set-name", cmdChatroomSetName ) + , ( "chatroom-subscribe", cmdChatroomSubscribe ) + , ( "chatroom-unsubscribe", cmdChatroomUnsubscribe ) + , ( "chatroom-members", cmdChatroomMembers ) + , ( "chatroom-join", cmdChatroomJoin ) + , ( "chatroom-join-as", cmdChatroomJoinAs ) + , ( "chatroom-leave", cmdChatroomLeave ) + , ( "chatroom-message-send", cmdChatroomMessageSend ) + , ( "discovery-connect", cmdDiscoveryConnect ) + , ( "discovery-tunnel", cmdDiscoveryTunnel ) ] cmdStore :: Command cmdStore = do st <- asks tiStorage + pst <- liftIO $ derivePartialStorage st [otype] <- asks tiParams ls <- getLines let cnt = encodeUtf8 $ T.unlines ls - ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] - cmdOut $ "store-done " ++ show (refDigest ref) + full = BL.fromChunks + [ encodeUtf8 otype + , BC.singleton ' ' + , BC.pack (show $ B.length cnt) + , BC.singleton '\n', cnt + ] + liftIO (copyRef st =<< storeRawBytes pst full) >>= \case + Right ref -> cmdOut $ "store-done " ++ show (refDigest ref) + Left _ -> cmdOut $ "store-failed" cmdLoad :: Command cmdLoad = do @@ -344,7 +378,7 @@ cmdStoredSetAdd = do [Just iref, Just sref] -> return (wrappedLoad iref, loadSet @[Stored Object] sref) [Just iref] -> return (wrappedLoad iref, emptySet) _ -> fail "unexpected parameters" - set' <- storeSetAdd st [item] set + set' <- storeSetAdd [ item ] set cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set') cmdStoredSetList :: Command @@ -357,6 +391,19 @@ cmdStoredSetList = do cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item cmdOut $ "stored-set-done" +cmdStoredDifference :: Command +cmdStoredDifference = do + st <- asks tiStorage + ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams + + let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8) + objs1 <- loadObjs trefs1 + objs2 <- loadObjs trefs2 + + forM_ (storedDifference objs1 objs2) $ \item -> do + cmdOut $ "stored-difference-item " ++ (show $ refDigest $ storedRef item) + cmdOut $ "stored-difference-done" + cmdHeadCreate :: Command cmdHeadCreate = do [ ttid, tref ] <- asks tiParams @@ -411,7 +458,8 @@ cmdHeadUnwatch = do initTestHead :: Head LocalState -> Command initTestHead h = do - _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput + let self = finalOwner $ headLocalIdentity h + _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput modify $ \s -> s { tsHead = Just h } loadTestHead :: CommandM (Head LocalState) @@ -434,17 +482,18 @@ cmdCreateIdentity = do st <- asks tiStorage names <- asks tiParams - h <- liftIO $ do + h <- do Just identity <- if null names - then Just <$> createIdentity st Nothing Nothing - else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names + then Just <$> createIdentity Nothing Nothing + else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names shared <- case names of - _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) [] + _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) [] _ -> return [] storeHead st $ LocalState - { lsIdentity = idExtData identity + { lsPrev = Nothing + , lsIdentity = idExtData identity , lsShared = shared , lsOther = [] } @@ -472,42 +521,78 @@ cmdStartServer = do let parseParams = \case (name : value : rest) - | name == "services" -> T.splitOn "," value + | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest) + (name : rest) + | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest) | otherwise -> parseParams rest - _ -> [] - serviceNames <- parseParams <$> asks tiParams + _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] ) + + splitServiceParams svc = + case T.splitOn ":" svc of + name : params -> ( name, params ) + _ -> ( svc, [] ) + + ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) 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" - "discovery" -> return $ someService @DiscoveryService Proxy - "dm" -> return $ someServiceAttr $ directMessageAttributes out - "sync" -> return $ someService @SyncService Proxy - "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) + ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" + ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy + ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" + ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes + { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params + } + ( "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] + outLine out $ unwords [ "test-message-received", otype, len, sref ] + , testStreamsReceived = \streams -> do + pidx <- getPeerIndex rsPeers + liftIO $ do + nums <- mapM getStreamReaderNumber streams + outLine out $ unwords $ "test-stream-open-from" : show pidx : map show nums + forM_ (zip nums streams) $ \( num, stream ) -> void $ forkIO $ do + let go = readStreamPacket stream >>= \case + StreamData seqNum bytes -> do + outLine out $ unwords [ "test-stream-received", show pidx, show num, show seqNum, BC.unpack bytes ] + go + StreamClosed seqNum -> do + outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ] + go } - sname -> throwError $ "unknown service `" <> T.unpack sname <> "'" + ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" - rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services + let logPrint str = do BC.hPutStrLn stdout (BC.pack str) + hFlush stdout + rsServer <- liftIO $ startServer serverOptions h logPrint services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer - let printPeer (idx, p) = do - params <- peerIdentity p >>= return . \case - PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) - _ -> [ "addr", show (peerAddress p) ] - outLine out $ unwords $ [ "peer", show idx ] ++ params - - update (nid, []) = printPeer (nid, peer) >> return (nid + 1, [(nid, peer)]) - update cur@(nid, p:ps) | snd p == peer = printPeer p >> return cur - | otherwise = fmap (p:) <$> update (nid, ps) + let printPeer TestPeer {..} = do + params <- getPeerIdentity tpPeer >>= \case + PeerIdentityFull pid -> do + return $ ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) + _ -> do + paddr <- getPeerAddress tpPeer + return $ [ "addr", show paddr ] + outLine out $ unwords $ [ "peer", show tpIndex ] ++ params + + update ( tpIndex, [] ) = do + tpPeer <- return peer + tpStreamReaders <- newMVar [] + tpStreamWriters <- newMVar [] + let tp = TestPeer {..} + printPeer tp + return ( tpIndex + 1, [ tp ] ) + + update cur@( nid, p : ps ) + | tpPeer p == peer = printPeer p >> return cur + | otherwise = fmap (p :) <$> update ( nid, ps ) modifyMVar_ rsPeers update @@ -544,11 +629,12 @@ cmdPeerList = do peers <- liftIO $ getCurrentPeerList rsServer tpeers <- liftIO $ readMVar rsPeers forM_ peers $ \peer -> do - Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers - mbpid <- peerIdentity peer + Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers + mbpid <- getPeerIdentity peer + paddr <- getPeerAddress peer cmdOut $ unwords $ concat - [ [ "peer-list-item", show n ] - , [ "addr", show (peerAddress peer) ] + [ [ "peer-list-item", show (tpIndex tp) ] + , [ "addr", show paddr ] , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) _ -> [] ] @@ -564,6 +650,40 @@ cmdTestMessageSend = do sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs cmdOut "test-message-send done" +cmdTestStreamOpen :: Command +cmdTestStreamOpen = do + spidx : rest <- asks tiParams + tp <- getTestPeer spidx + count <- case rest of + [] -> return 1 + tcount : _ -> return $ read $ T.unpack tcount + + out <- asks tiOutput + runPeerService (tpPeer tp) $ do + streams <- openTestStreams count + afterCommit $ do + nums <- mapM getStreamWriterNumber streams + modifyMVar_ (tpStreamWriters tp) $ return . (++ zip nums streams) + outLine out $ unwords $ "test-stream-open-done" + : T.unpack spidx + : map show nums + +cmdTestStreamClose :: Command +cmdTestStreamClose = do + [ spidx, sid ] <- asks tiParams + tp <- getTestPeer spidx + Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp)) + liftIO $ closeStream stream + cmdOut $ unwords [ "test-stream-close-done", T.unpack spidx, T.unpack sid ] + +cmdTestStreamSend :: Command +cmdTestStreamSend = do + [ spidx, sid, content ] <- asks tiParams + tp <- getTestPeer spidx + Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp)) + liftIO $ writeStream stream $ encodeUtf8 content + cmdOut $ unwords [ "test-stream-send-done", T.unpack spidx, T.unpack sid ] + cmdLocalStateGet :: Command cmdLocalStateGet = do h <- getHead @@ -636,7 +756,7 @@ cmdWatchSharedIdentity = do cmdUpdateLocalIdentity :: Command cmdUpdateLocalIdentity = do [name] <- asks tiParams - updateLocalHead_ $ \ls -> do + updateLocalState_ $ \ls -> do Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls let public = idKeyIdentity identity @@ -651,8 +771,8 @@ cmdUpdateLocalIdentity = do cmdUpdateSharedIdentity :: Command cmdUpdateSharedIdentity = do [name] <- asks tiParams - updateLocalHead_ $ updateSharedState_ $ \case - Nothing -> throwError "no existing shared identity" + updateLocalState_ $ updateSharedState_ $ \case + Nothing -> throwOtherError "no existing shared identity" Just identity -> do let public = idKeyIdentity identity secret <- loadKey public @@ -721,13 +841,13 @@ cmdContactSetName :: Command cmdContactSetName = do [cid, name] <- asks tiParams contact <- getContact cid - updateLocalHead_ $ updateSharedState_ $ contactSetName contact name + updateLocalState_ $ updateSharedState_ $ contactSetName contact name cmdOut "contact-set-name-done" cmdDmSendPeer :: Command cmdDmSendPeer = do [spidx, msg] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx void $ sendDirectMessage to msg cmdDmSendContact :: Command @@ -736,12 +856,20 @@ cmdDmSendContact = do Just to <- contactIdentity <$> getContact cid void $ sendDirectMessage to msg +cmdDmSendIdentity :: Command +cmdDmSendIdentity = do + st <- asks tiStorage + [ tid, msg ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just to <- return $ validateExtendedIdentity $ wrappedLoad ref + void $ sendDirectMessage to msg + dmList :: Foldable f => Identity f -> Command dmList peer = do - threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead + threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead case find (sameIdentity peer . msgPeer) threads of Just thread -> do - forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item" + forM_ (reverse $ dmThreadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item" <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom) <> " text " <> (T.unpack msgText) Nothing -> return () @@ -750,7 +878,7 @@ dmList peer = do cmdDmListPeer :: Command cmdDmListPeer = do [spidx] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx dmList to cmdDmListContact :: Command @@ -858,8 +986,7 @@ cmdChatroomJoin = do cmdChatroomJoinAs :: Command cmdChatroomJoinAs = do [ cid, name ] <- asks tiParams - st <- asks tiStorage - identity <- liftIO $ createIdentity st (Just name) Nothing + identity <- createIdentity (Just name) Nothing joinChatroomAsByStateData identity =<< getChatroomStateData cid cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ] @@ -877,11 +1004,14 @@ cmdChatroomMessageSend = do cmdDiscoveryConnect :: Command cmdDiscoveryConnect = do - st <- asks tiStorage [ tref ] <- asks tiParams - Just ref <- liftIO $ readRef st $ encodeUtf8 tref - + Just dgst <- return $ readRefDigest $ encodeUtf8 tref Just RunningServer {..} <- gets tsServer - peers <- liftIO $ getCurrentPeerList rsServer - forM_ peers $ \peer -> do - sendToPeer peer $ DiscoverySearch ref + discoverySearch rsServer dgst + +cmdDiscoveryTunnel :: Command +cmdDiscoveryTunnel = do + [ tvia, ttarget ] <- asks tiParams + via <- getPeer tvia + Just target <- return $ readRefDigest $ encodeUtf8 ttarget + liftIO $ discoverySetupTunnel via target |