From 78a353708ea607d241b45ce6b106c7586a9a61ec Mon Sep 17 00:00:00 2001 From: Will Thompson Date: Sun, 8 Jul 2018 12:28:16 +0200 Subject: Handle NameOwnerChanged et al. while rendering This makes it easier to support un-hiding messages to and from the bus daemon. If we want to infer the initial state when the state dump is missing (or if we lose the race) then we need to do this kind of thing later anyway. --- Bustle/Loader.hs | 26 +--------- Bustle/Loader/Pcap.hs | 76 +++------------------------- Bustle/Noninteractive.hs | 2 +- Bustle/Renderer.hs | 127 +++++++++++++++++++++++++++++------------------ Bustle/Stats.hs | 8 +-- Bustle/Types.hs | 40 +++------------ Bustle/UI.hs | 5 +- 7 files changed, 97 insertions(+), 187 deletions(-) diff --git a/Bustle/Loader.hs b/Bustle/Loader.hs index 8fd40c8..8b61274 100644 --- a/Bustle/Loader.hs +++ b/Bustle/Loader.hs @@ -19,14 +19,10 @@ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA module Bustle.Loader ( readLog , LoadError(..) - - -- * This function bothers me, but it's used by the live recorder for now... - , isRelevant ) where import Control.Monad.Except -import Control.Arrow (second) import qualified Bustle.Loader.Pcap as Pcap import Bustle.Types @@ -43,25 +39,5 @@ readLog :: MonadIO io readLog f = do pcapResult <- io $ Pcap.readPcap f case pcapResult of - Right ms -> return $ second (filter (isRelevant . deEvent)) ms + Right ms -> return $ ms Left ioe -> throwError $ LoadError f (show ioe) - -isRelevant :: Event - -> Bool -isRelevant (NOCEvent _) = True -isRelevant (MessageEvent m) = case m of - Signal {} -> not senderIsBus - MethodCall {} -> none3 - MethodReturn {} -> none3 - Error {} -> none3 - where - -- FIXME: really? Maybe we should allow people to be interested in, - -- say, binding to signals? - senderIsBus = sender m == busDriver - destIsBus = destination m == busDriver - busDriver = O (OtherName dbusName) - - none bs = not $ or bs - none3 = none [senderIsBus, destIsBus] - - diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs index bed6f31..62a90fd 100644 --- a/Bustle/Loader/Pcap.hs +++ b/Bustle/Loader/Pcap.hs @@ -49,22 +49,12 @@ import qualified Data.ByteString as BS import qualified Bustle.Types as B import Bustle.Translation (__) --- Conversions from dbus-core's types into Bustle's more stupid types. This --- whole section is pretty upsetting. -stupifyBusName :: BusName - -> B.TaggedBusName -stupifyBusName n - | isUnique n = B.U $ B.UniqueName n - | otherwise = B.O $ B.OtherName n - -isUnique :: BusName -> Bool -isUnique n = head (formatBusName n) == ':' convertBusName :: String -> Maybe BusName -> B.TaggedBusName convertBusName fallback n = - stupifyBusName (fromMaybe fallback_ n) + B.tagBusName (fromMaybe fallback_ n) where fallback_ = busName_ fallback @@ -108,56 +98,6 @@ insertPending :: (MonadState PendingMessages m) -> m () insertPending n s rawCall b = modify $ Map.insert (n, s) (rawCall, b) -isNOC :: Maybe BusName -> Signal -> Maybe (BusName, Maybe BusName, Maybe BusName) -isNOC (Just sender) s | looksLikeNOC = - case names of - [Just n, old, new] -> Just (n, old, new) - _ -> Nothing - where - names :: [Maybe BusName] - names = map fromVariant $ signalBody s - - looksLikeNOC = - (sender == B.dbusName) && - (signalInterface s == B.dbusInterface) && - (formatMemberName (signalMember s) == "NameOwnerChanged") - -isNOC _ _ = Nothing - - -bustlifyNOC :: (BusName, Maybe BusName, Maybe BusName) - -> B.NOC -bustlifyNOC ns@(name, oldOwner, newOwner) - | isUnique name = - case (oldOwner, newOwner) of - (Nothing, Just _) -> B.Connected (uniquify name) - (Just _, Nothing) -> B.Disconnected (uniquify name) - _ -> error $ "wtf: NOC" ++ show ns - | otherwise = B.NameChanged (otherify name) $ - case (oldOwner, newOwner) of - (Just old, Nothing) -> B.Released (uniquify old) - (Just old, Just new) -> B.Stolen (uniquify old) (uniquify new) - (Nothing, Just new) -> B.Claimed (uniquify new) - (Nothing, Nothing) -> error $ "wtf: NOC" ++ show ns - where - uniquify = B.UniqueName - otherify = B.OtherName - -tryBustlifyGetNameOwnerReply :: Maybe (MethodCall, a) - -> MethodReturn - -> Maybe B.NOC -tryBustlifyGetNameOwnerReply maybeCall mr = do - -- FIXME: obviously this should be more robust: - -- • check that the service really is the bus daemon - -- • don't crash if the body of the call or reply doesn't contain one bus name. - (rawCall, _) <- maybeCall - guard (formatMemberName (methodCallMember rawCall) == "GetNameOwner") - ownedName <- fromVariant (head (methodCallBody rawCall)) - return $ bustlifyNOC ( ownedName - , Nothing - , fromVariant (head (methodReturnBody mr)) - ) - bustlify :: Monad m => B.Microseconds -> Int @@ -183,14 +123,12 @@ bustlify µs bytes m = do -- FIXME: we shouldn't need to construct almost the same thing here -- and 10 lines above maybe? insertPending sender serial mc (B.Detailed µs call bytes m) - return $ B.MessageEvent call + return call (ReceivedMethodReturn _serial mr) -> do call <- popMatchingCall (methodReturnDestination mr) (methodReturnSerial mr) - return $ case tryBustlifyGetNameOwnerReply call mr of - Just noc -> B.NOCEvent noc - Nothing -> B.MessageEvent $ B.MethodReturn + return $ B.MethodReturn { B.inReplyTo = fmap snd call , B.sender = wrappedSender , B.destination = convertBusName "method.return.destination" $ methodReturnDestination mr @@ -198,18 +136,16 @@ bustlify µs bytes m = do (ReceivedMethodError _serial e) -> do call <- popMatchingCall (methodErrorDestination e) (methodErrorSerial e) - return $ B.MessageEvent $ B.Error + return $ B.Error { B.inReplyTo = fmap snd call , B.sender = wrappedSender , B.destination = convertBusName "method.error.destination" $ methodErrorDestination e } - (ReceivedSignal _serial sig) - | Just names <- isNOC sender sig -> return $ B.NOCEvent $ bustlifyNOC names - | otherwise -> return $ B.MessageEvent $ + (ReceivedSignal _serial sig) -> return $ B.Signal { B.sender = wrappedSender , B.member = convertMember signalPath (Just . signalInterface) signalMember sig - , B.signalDestination = stupifyBusName <$> signalDestination sig + , B.signalDestination = B.tagBusName <$> signalDestination sig } _ -> error "woah there! someone added a new message type." diff --git a/Bustle/Noninteractive.hs b/Bustle/Noninteractive.hs index 215fc28..e2d4657 100644 --- a/Bustle/Noninteractive.hs +++ b/Bustle/Noninteractive.hs @@ -82,5 +82,5 @@ runDot filepath = process filepath makeDigraph id | (s, d) <- nub . mapMaybe (methodCall . deEvent) $ log ] - methodCall (MessageEvent MethodCall {sender = s, destination = d}) = Just (s, d) + methodCall (MethodCall {sender = s, destination = d}) = Just (s, d) methodCall _ = Nothing diff --git a/Bustle/Renderer.hs b/Bustle/Renderer.hs index 36dd580..d6174e7 100644 --- a/Bustle/Renderer.hs +++ b/Bustle/Renderer.hs @@ -52,9 +52,11 @@ import Control.Monad.State import Control.Monad.Writer import Data.List (sort, sortBy) -import Data.Maybe (fromJust, fromMaybe, catMaybes) +import Data.Maybe (fromJust, fromMaybe, catMaybes, listToMaybe) import Data.Ord (comparing) +import qualified DBus + data Bus = SessionBus | SystemBus deriving (Show, Eq, Ord) @@ -261,7 +263,7 @@ initialBusState :: Set UniqueName -> Double -> BusState initialBusState ignore x = - BusState { apps = Map.empty + BusState { apps = Map.empty -- TODO: org.fd.DBus -> self? , firstColumn = x , nextColumn = x , columnsInUse = Set.empty @@ -342,18 +344,6 @@ getApps bus = apps <$> getBusState bus getsApps :: (Applications -> a) -> Bus -> Renderer a getsApps f = getsBusState (f . apps) -lookupUniqueName :: Bus - -> UniqueName - -> Renderer ApplicationInfo -lookupUniqueName bus u = do - thing <- getsApps (Map.lookup u) bus - case thing of - Just nameInfo -> return nameInfo - -- This happens with pcap logs where we don't (currently) have - -- explicit change notification for unique names in the stream of - -- DetailedEvents. - Nothing -> addUnique bus u - lookupOtherName :: Bus -> OtherName -> Renderer (UniqueName, ApplicationInfo) @@ -438,30 +428,21 @@ appCoordinate bus n = do modifyApps :: Bus -> (Applications -> Applications) -> Renderer () modifyApps bus f = modifyBusState bus $ \bs -> bs { apps = f (apps bs) } --- Updates the current set of applications in response to a well-known name's --- owner changing. -updateApps :: Bus -- ^ bus on which a name's owner has changed - -> OtherName -- name whose owner has changed. - -> Change -- details of the change - -> Renderer () -updateApps bus n c = case c of - Claimed new -> addOther bus n new - Stolen old new -> remOther bus n old >> addOther bus n new - Released old -> remOther bus n old - --- Adds a new unique name -addUnique :: Bus -> UniqueName -> Renderer ApplicationInfo -addUnique bus n = do - let ai = ApplicationInfo NoColumn Set.empty Set.empty +lookupUniqueName :: Bus + -> UniqueName + -> Renderer ApplicationInfo +lookupUniqueName bus n = do existing <- getsApps (Map.lookup n) bus case existing of - Nothing -> return () - Just _ -> warn $ concat [ "Unique name '" - , unUniqueName n - , "' apparently connected to the bus twice" - ] - modifyApps bus $ Map.insert n ai - return ai + Nothing -> do + let ai = ApplicationInfo NoColumn Set.empty Set.empty + modifyApps bus $ Map.insert n ai + return ai + Just ai -> return ai + +-- Ensures a unique name is in the map without returning it +addUnique :: Bus -> UniqueName -> Renderer () +addUnique bus n = void $ lookupUniqueName bus n -- Removes a unique name from the diagram. If we ever try to reuse columns -- we'll have to revisit the FormerColumn concept to include a range of time. @@ -658,11 +639,11 @@ shouldShow bus m = do return $ Set.null (ignored `Set.intersection` Set.fromList names) processOne :: Bus - -> Detailed Event + -> Detailed Message -> Renderer () -processOne bus de = case deEvent de of - NOCEvent n -> processNOC bus n - MessageEvent m -> processMessage bus (fmap (const m) de) +processOne bus de = do + inferNameChanges bus de + processMessage bus de processMessage :: Bus -> Detailed Message @@ -702,16 +683,66 @@ processMessage bus dm@(Detailed _ m _ _) = do returnArc bus dm x y duration addMessageRegion dm + +type NOCArgs = (DBus.BusName, Maybe DBus.BusName, Maybe DBus.BusName) + + +matchNOC :: Detailed Message + -> Maybe NOCArgs +matchNOC m = do + DBus.ReceivedSignal _ s <- return (deReceivedMessage m) + guard (DBus.signalSender s == Just dbusName) + guard (DBus.signalInterface s == dbusInterface) + guard (DBus.signalMember s == DBus.memberName_ "NameOwnerChanged") + case map DBus.fromVariant (DBus.signalBody s) of + [Just n, old, new] -> Just (n, old, new) + _ -> Nothing + + processNOC :: Bus - -> NOC + -> NOCArgs + -> Renderer () +processNOC bus args@(n, old_, new_) = + case tagBusName n of + U u -> case (old_, new_) of + (Just n_, Nothing) | n == n_ -> remUnique bus u + (Nothing, Just n_) | n == n_ -> addUnique bus u + _ -> warn $ "Malformed NameOwnerChanged: " ++ show args + O o -> do + forM_ old_ $ remOther bus o . UniqueName + forM_ new_ $ addOther bus o . UniqueName + + +type GetNameOwnerReply = (OtherName, UniqueName) + +matchGetNameOwnerReply :: Detailed Message + -> Maybe GetNameOwnerReply +matchGetNameOwnerReply de = do + DBus.ReceivedMethodReturn _ reply_ <- return $ deReceivedMessage de + MethodReturn { inReplyTo = Just call } <- return $ deEvent de + DBus.ReceivedMethodCall _ call_ <- return $ deReceivedMessage call + guard (DBus.methodCallDestination call_ == Just dbusName) + guard (DBus.methodCallInterface call_ == Just dbusInterface) + guard (DBus.methodCallMember call_ == DBus.memberName_ "GetNameOwner") + + let oneName :: [DBus.Variant] -> Maybe TaggedBusName + oneName args = do + arg <- listToMaybe args + tagBusName <$> DBus.fromVariant arg + + -- Some people really do call GetNameOwner for unique names + (O owned) <- oneName $ DBus.methodCallBody call_ + (U owner) <- oneName $ DBus.methodReturnBody reply_ + return (owned, owner) + + +inferNameChanges :: Bus + -> Detailed Message -> Renderer () -processNOC bus noc = - case noc of - Connected { actor = u } -> void (addUnique bus u) - Disconnected { actor = u } -> remUnique bus u - NameChanged { changedName = n - , change = c - } -> updateApps bus n c +inferNameChanges bus de = do + forM_ (matchNOC de) $ processNOC bus + forM_ (matchGetNameOwnerReply de) $ uncurry (addOther bus) + -- TODO: assume that reply sender owns name the message was sent to methodCall, methodReturn, errorReturn :: Bus -> Detailed Message diff --git a/Bustle/Stats.hs b/Bustle/Stats.hs index 30fb221..036cfb7 100644 --- a/Bustle/Stats.hs +++ b/Bustle/Stats.hs @@ -46,8 +46,7 @@ data TallyType = TallyMethod | TallySignal repr :: DetailedEvent -> Maybe (TallyType, Maybe InterfaceName, MemberName) -repr (Detailed _ (NOCEvent _) _ _) = Nothing -repr (Detailed _ (MessageEvent msg) _ _) = +repr (Detailed _ msg _ _) = case msg of MethodCall { member = m } -> Just (TallyMethod, iface m, membername m) Signal { member = m } -> Just (TallySignal, iface m, membername m) @@ -89,9 +88,6 @@ methodTimes = sortBy (flip (comparing tiTotalTime)) . map summarize . foldr (\(i, method, time) -> Map.alter (alt time) (i, method)) Map.empty . mapMaybe methodReturn - -- Get rid of NOC messages - . snd - . partitionDetaileds where alt newtime Nothing = Just (newtime, [newtime]) alt newtime (Just (total, times)) = Just (newtime + total, newtime : times) @@ -150,7 +146,7 @@ messageSizes messages = intMean :: [Int] -> Int intMean = ceiling . (mean :: [Double] -> Double) . map fromIntegral - sizeTable = foldr f Map.empty . snd . partitionDetaileds $ messages + sizeTable = foldr f Map.empty messages f :: Detailed Message -> Map (SizeType, Maybe InterfaceName, MemberName) [Int] diff --git a/Bustle/Types.hs b/Bustle/Types.hs index cef8ace..b576057 100644 --- a/Bustle/Types.hs +++ b/Bustle/Types.hs @@ -34,6 +34,7 @@ module Bustle.Types , TaggedBusName(..) , isUnique , isOther + , tagBusName , unUniqueName , unOtherName , unBusName @@ -48,12 +49,8 @@ module Bustle.Types , Member(..) , Message(..) - , NOC(..) - , Event(..) , Detailed(..) , DetailedEvent - , Change(..) - , partitionDetaileds , mentionedNames , Log ) @@ -67,7 +64,6 @@ import DBus ( ObjectPath, formatObjectPath , ReceivedMessage ) import Data.Maybe (maybeToList) -import Data.Either (partitionEithers) type Serial = Word32 @@ -95,6 +91,11 @@ unBusName :: TaggedBusName -> String unBusName (U (UniqueName x)) = formatBusName x unBusName (O (OtherName x)) = formatBusName x +tagBusName :: BusName -> TaggedBusName +tagBusName n = case formatBusName n of + ':':_ -> U (UniqueName n) + _ -> O (OtherName n) + -- These useful constants disappeared from dbus in the grand removing of the -- -core suffix. dbusName :: BusName @@ -122,10 +123,6 @@ data Member = Member { path :: ObjectPath } deriving (Ord, Show, Eq) -data Event = MessageEvent Message - | NOCEvent NOC - deriving (Show, Eq, Ord) - data Message = MethodCall { serial :: Serial , sender :: TaggedBusName , destination :: TaggedBusName @@ -145,15 +142,6 @@ data Message = MethodCall { serial :: Serial } deriving (Show, Eq, Ord) -data NOC = Connected { actor :: UniqueName - } - | Disconnected { actor :: UniqueName - } - | NameChanged { changedName :: OtherName - , change :: Change - } - deriving (Show, Eq, Ord) - type MessageSize = Int data Detailed e = @@ -164,26 +152,12 @@ data Detailed e = } deriving (Show, Eq, Functor) -type DetailedEvent = Detailed Event +type DetailedEvent = Detailed Message instance Ord e => Ord (Detailed e) where compare (Detailed µs x _ _) (Detailed µs' y _ _) = compare (µs, x) (µs', y) -data Change = Claimed UniqueName - | Stolen UniqueName UniqueName - | Released UniqueName - deriving (Show, Eq, Ord) - -partitionDetaileds :: [DetailedEvent] - -> ([Detailed NOC], [Detailed Message]) -partitionDetaileds = partitionEithers . map f - where - f (Detailed µs e size rm) = - case e of - NOCEvent n -> Left $ Detailed µs n size rm - MessageEvent m -> Right $ Detailed µs m size rm - mentionedNames :: Message -> [TaggedBusName] mentionedNames m = sender m:dest where diff --git a/Bustle/UI.hs b/Bustle/UI.hs index 44abafb..b652352 100644 --- a/Bustle/UI.hs +++ b/Bustle/UI.hs @@ -291,10 +291,7 @@ recorderRun wi target filename r = C.handle newFailed $ do case m of Left e -> warn e - Right message - | isRelevant (deEvent message) -> - modifyIORef' pendingRef (message:) - | otherwise -> return () + Right message -> modifyIORef' pendingRef (message:) n <- newIORef (0 :: Int) processor <- processBatch pendingRef n wi -- cgit v1.2.3