diff options
Diffstat (limited to 'main/Test.hs')
| -rw-r--r-- | main/Test.hs | 30 |
1 files changed, 27 insertions, 3 deletions
diff --git a/main/Test.hs b/main/Test.hs index 97eaee7..c6448b8 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -97,7 +97,7 @@ runTestTool st = do Nothing -> return () runExceptT (evalStateT testLoop initTestState) >>= \case - Left x -> hPutStrLn stderr x + Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x Right () -> return () getLineMb :: MonadIO m => m (Maybe Text) @@ -121,7 +121,7 @@ outLine :: Output -> String -> IO () outLine mvar line = do evaluate $ foldl' (flip seq) () line withMVar mvar $ \() -> do - putStrLn line + B.putStr $ (`BC.snoc` '\n') $ BC.pack line hFlush stdout cmdOut :: String -> Command @@ -283,6 +283,9 @@ commands = map (T.pack *** id) , ("chatroom-set-name", cmdChatroomSetName) , ("chatroom-subscribe", cmdChatroomSubscribe) , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) + , ("chatroom-members", cmdChatroomMembers) + , ("chatroom-join", cmdChatroomJoin) + , ("chatroom-leave", cmdChatroomLeave) , ("chatroom-message-send", cmdChatroomMessageSend) ] @@ -428,7 +431,7 @@ cmdStartServer = do h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) - rsServer <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr) + 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 @@ -732,6 +735,7 @@ cmdChatroomWatchLocal = do , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ] , [ "room", maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg ] , [ "from", maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg ] + , if cmsgLeave msg then [ "leave" ] else [] , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg ] @@ -754,6 +758,26 @@ cmdChatroomUnsubscribe = do to <- getChatroomStateData cid void $ chatroomSetSubscribe to False +cmdChatroomMembers :: Command +cmdChatroomMembers = do + [ cid ] <- asks tiParams + Just chatroom <- findChatroomByStateData =<< getChatroomStateData cid + forM_ (chatroomMembers chatroom) $ \user -> do + cmdOut $ unwords [ "chatroom-members-item", maybe "<unnamed>" T.unpack $ idName user ] + cmdOut "chatroom-members-done" + +cmdChatroomJoin :: Command +cmdChatroomJoin = do + [ cid ] <- asks tiParams + joinChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-join-done" + +cmdChatroomLeave :: Command +cmdChatroomLeave = do + [ cid ] <- asks tiParams + leaveChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-leave-done" + cmdChatroomMessageSend :: Command cmdChatroomMessageSend = do [cid, msg] <- asks tiParams |