From af251f41daac5593bae8986112c672e7efc08290 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 29 Apr 2017 15:33:34 -0400 Subject: fix server to not relay developer messages back to self This fixes chat message echoing consistency too. --- ControlWindow.hs | 32 +++++++++++++++++++++----------- Role/Developer.hs | 2 ++ Server.hs | 30 +++++++++++++++--------------- TODO | 2 -- 4 files changed, 38 insertions(+), 28 deletions(-) diff --git a/ControlWindow.hs b/ControlWindow.hs index 3bd0e58..74514be 100644 --- a/ControlWindow.hs +++ b/ControlWindow.hs @@ -84,13 +84,19 @@ collectOutput ochan promptchan responsechan = do myusername <- fromString <$> getLoginName withLines stdin $ mapM_ $ processline myusername where - processline myusername l = atomically $ do - -- Is any particular input being prompted for now? - mp <- tryReadTChan promptchan - case mp of - Just _ -> writeTChan responsechan $ L.toStrict l - Nothing -> writeTMChan ochan $ ControlOutputAction $ - ChatMessage (Val myusername) (Val $ L.toStrict l) + processline myusername l = do + mc <- atomically $ do + -- Is any particular input being prompted for now? + mp <- tryReadTChan promptchan + case mp of + Just _ -> do + writeTChan responsechan $ L.toStrict l + return Nothing + Nothing -> do + let c = ChatMessage (Val myusername) (Val $ L.toStrict l) + writeTMChan ochan $ ControlOutputAction c + return (Just c) + maybe (return ()) displayChatMessage mc displayInput :: TMChan ControlOutput -> TMChan ControlInput -> PromptChan -> ResponseChan -> IO () displayInput ochan ichan promptchan responsechan = loop @@ -103,13 +109,17 @@ displayInput ochan ichan promptchan responsechan = loop go (Just (ControlInputAction (SessionKey k))) = do askToAllow ochan promptchan responsechan k loop - go (Just (ControlInputAction (ChatMessage username msg))) = do - B.putStr $ "<" <> val username <> "> " <> val msg - putStr "\n" - hFlush stdout + go (Just (ControlInputAction m@(ChatMessage {}))) = do + displayChatMessage m loop go _ = loop +displayChatMessage :: ControlAction -> IO () +displayChatMessage (ChatMessage username msg) = do + B.putStr $ "<" <> val username <> "> " <> val msg <> "\n" + hFlush stdout +displayChatMessage _ = return () + askToAllow :: TMChan ControlOutput -> PromptChan -> ResponseChan -> PerhapsSigned PublicKey -> IO () askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $ ControlOutputAction $ SessionKeyRejected pk diff --git a/Role/Developer.hs b/Role/Developer.hs index efe476a..d05710e 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -410,6 +410,8 @@ processSessionStart sk ochan logger dsv = do User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _)) | verifySigned sigverifier act -> (hash act, TtyOutput b) + | otherwise -> + error "Bad signature on startup message" _ -> error $ "Unexpected startup message: " ++ show startmsg atomically $ modifyTVar' st $ \ds -> ds { lastSeen = starthash diff --git a/Server.hs b/Server.hs index f8e8588..b9f46dd 100644 --- a/Server.hs +++ b/Server.hs @@ -56,13 +56,12 @@ listenSession (Session bchan _ _) = dupTMChan bchan -- | While writing a log to the session the LogLock is drained until -- the write has reached the log file. This prevents concurrent writes -- to the file, and allows writes to be blocked while reading the log file. -writeSession :: Session -> Log -> IO () -writeSession (Session bchan loghv loglock) l = do +writeSession :: Weak ThreadId -> Session -> Log -> IO () +writeSession tid (Session bchan loghv loglock) l = do (ll, logh) <- atomically $ (,) <$> takeTMVar loglock <*> readTVar loghv writeLogHandle l logh - tid <- mkWeakThreadId =<< myThreadId atomically $ do putTMVar loglock ll writeTMChan bchan (Broadcast l tid) @@ -135,9 +134,10 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do modifyTVar' ssv $ M.delete sid go session = do + mytid <- mkWeakThreadId =<< myThreadId userchan <- atomically $ listenSession session _ <- relaytouser userchan - `race` relayfromuser session + `race` relayfromuser mytid session return () -- Relay all messages from the user's websocket to the @@ -145,9 +145,9 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do -- (The user is allowed to send Developer messages too.. perhaps -- they got them from a developer connected to them some other -- way.) - relayfromuser session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do + relayfromuser mytid session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do l <- mkLog msg <$> getPOSIXTime - writeSession session l + writeSession mytid session l -- Relay Developer messages from the channel to the user's websocket. relaytouser userchan = do @@ -177,18 +177,18 @@ developer o ssv sid conn = bracket setup cleanup go go (Just session) = do sendBinaryData conn (Ready ServerSends sid) devchan <- replayBacklogAndListen o sid session conn - mytid <- myThreadId - _ <- relayfromdeveloper session + mytid <- mkWeakThreadId =<< myThreadId + _ <- relayfromdeveloper mytid session `concurrently` relaytodeveloper mytid devchan return () -- Relay all Developer amessages from the developer's websocket -- to the broadcast channel. - relayfromdeveloper session = relayFromSocket conn noRecentActivity (return ()) + relayfromdeveloper mytid session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> case msg of Developer _ -> do l <- mkLog msg <$> getPOSIXTime - writeSession session l + writeSession mytid session l -- developer cannot send User messages User _ -> return () @@ -206,11 +206,11 @@ developer o ssv sid conn = bracket setup cleanup go -- developers, without looping -- back the developer's own messages. Developer _ -> do - mtid <- deRefWeak from - case mtid of - Just tid | tid == mytid -> - return () - _ -> sendit + rfrom <- deRefWeak from + rmy <- deRefWeak mytid + if rfrom == rmy + then return () + else sendit relaytodeveloper mytid devchan Nothing -> do sendBinaryData conn Done diff --git a/TODO b/TODO index bbb2091..050ff21 100644 --- a/TODO +++ b/TODO @@ -7,8 +7,6 @@ * Multiple --downloads at the same time or close together fail with "thread blocked indefinitely in an STM transaction" Also see it occasionally with --debug. -* For some reason, user chat does not echo back to them, but developer - chat does echo back to the developer. * The current rules for when an Activity Entered is accepted allow it to refer to an older activity than the last one. If echoing is disabled, two Activity Entered could be sent, each pointing at the most recent -- cgit v1.2.3