Handle NameOwnerChanged et al. while renderingbetter-inference

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.

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