diff --git a/Bustle/Application/Monad.hs b/Bustle/Application/Monad.hs --- a/Bustle/Application/Monad.hs +++ b/Bustle/Application/Monad.hs @@ -94,7 +94,7 @@ liftIO $ act r makeCallback :: Bustle config state a -> BustleEnv config state -> IO a -makeCallback (B act) x = runReaderT act x +makeCallback (B act) = runReaderT act runB :: config -> state -> Bustle config state a -> IO a runB config s (B act) = do diff --git a/Bustle/Diagram.hs b/Bustle/Diagram.hs --- a/Bustle/Diagram.hs +++ b/Bustle/Diagram.hs @@ -48,8 +48,8 @@ where import Data.List (unzip4) +import Data.List.NonEmpty (NonEmpty(..), toList) import Control.Arrow ((&&&)) -import Control.Applicative ((<$>), (<*>)) import Control.Monad.Reader @@ -60,7 +60,6 @@ import qualified Bustle.Marquee as Marquee import Bustle.Marquee (Marquee) -import Bustle.Util import Bustle.Types (ObjectPath, InterfaceName, MemberName) -- Sorry Mum @@ -131,15 +130,15 @@ -> Bool -- ^ True if this is a return; False if it's a call -> Double -- ^ y-coordinate -> Shape -memberLabel p i m isReturn y = MemberLabel p i m isReturn memberx y +memberLabel p i m isReturn = MemberLabel p i m isReturn memberx timestampLabel :: String -> Double -> Shape -timestampLabel s y = TimestampLabel s timestampx y +timestampLabel s = TimestampLabel s timestampx type Diagram = [Shape] arcControlPoints :: Shape -> (Point, Point) -arcControlPoints (Arc { topx=x1, topy=y1, bottomx=x2, bottomy=y2, arcside=s }) = +arcControlPoints Arc { topx=x1, topy=y1, bottomx=x2, bottomy=y2, arcside=s } = let (+-) = offset s cp1 = (x1 +- 60, y1 + 10) cp2 = (x2 +- 60, y2 - 10) @@ -161,7 +160,7 @@ Arc {} -> s { topx = f (topx s) , bottomx = f (bottomx s) } - ClientLines {} -> s { shapexs = mapNonEmpty f (shapexs s) } + ClientLines {} -> s { shapexs = f <$> shapexs s } _ -> s { shapex = f (shapex s) } mapY f s = case s of @@ -220,7 +219,7 @@ bounds :: Shape -> Rect bounds s = case s of ClientLines {} -> - let xs = nonEmptyToList (shapexs s) + let xs = toList (shapexs s) in (minimum xs, shapey1 s, maximum xs, shapey2 s) Rule {} -> (shapex1 s, shapey s, shapex2 s, shapey s) Arrow {} -> @@ -230,11 +229,11 @@ in (x1, y1, x2, y2) SignalArrow {} -> let (x1, x2) = xMinMax s - (y1, y2) = (subtract 5) &&& (+5) $ shapey s + (y1, y2) = subtract 5 &&& (+5) $ shapey s in (x1, y1, x2, y2) DirectedSignalArrow {} -> let (x1, x2) = minMax (epicentre s, shapex s) - (y1, y2) = (subtract 5) &&& (+5) $ shapey s + (y1, y2) = subtract 5 &&& (+5) $ shapey s in (x1, y1, x2, y2) Arc { topx=x1, bottomx=x2, topy=y1, bottomy=y2 } -> let ((cx, _), (dx, _)) = arcControlPoints s @@ -406,13 +405,13 @@ arc e y 5 0 (2 * pi) stroke - maybeM mleft $ \left -> do + forM_ mleft $ \left -> do moveTo left y arrowHead False lineTo (e - 5) y stroke - maybeM mright $ \right -> do + forM_ mright $ \right -> do moveTo (e + 5) y lineTo right y arrowHead True @@ -504,7 +503,7 @@ drawClientLines :: NonEmpty Double -> Double -> Double -> Render () drawClientLines xs y1 y2 = saved $ do setSourceRGB 0.7 0.7 0.7 - forM_ (nonEmptyToList xs) $ \x -> do + forM_ (toList xs) $ \x -> do moveTo x y1 lineTo x y2 stroke diff --git a/Bustle/Loader.hs b/Bustle/Loader.hs --- a/Bustle/Loader.hs +++ b/Bustle/Loader.hs @@ -26,7 +26,7 @@ where import Control.Monad.Except -import Control.Arrow ((***)) +import Control.Arrow (second) import qualified Bustle.Loader.Pcap as Pcap import Bustle.Types @@ -43,7 +43,7 @@ readLog f = do pcapResult <- io $ Pcap.readPcap f case pcapResult of - Right ms -> return $ (id *** filter (isRelevant . deEvent)) ms + Right ms -> return $ second (filter (isRelevant . deEvent)) ms Left ioe -> throwError $ LoadError f (show ioe) isRelevant :: Event diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs --- a/Bustle/Loader/Pcap.hs +++ b/Bustle/Loader/Pcap.hs @@ -100,7 +100,7 @@ modify $ Map.delete key return call -insertPending :: (MonadState PendingMessages m) +insertPending :: MonadState PendingMessages m => Maybe BusName -> Serial -> MethodCall @@ -118,10 +118,10 @@ names = map fromVariant $ signalBody s looksLikeNOC = - and [ sender == B.dbusName - , signalInterface s == B.dbusInterface - , formatMemberName (signalMember s) == "NameOwnerChanged" - ] + (sender == B.dbusName) && + (signalInterface s == B.dbusInterface) && + (formatMemberName (signalMember s) == "NameOwnerChanged") + isNOC _ _ = Nothing @@ -152,17 +152,17 @@ -- • 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 $ (methodCallBody rawCall !! 0) + ownedName <- fromVariant (head (methodCallBody rawCall)) return $ bustlifyNOC ( ownedName , Nothing - , fromVariant $ (methodReturnBody mr !! 0) + , fromVariant (head (methodReturnBody mr)) ) -bustlify :: Monad m +bustlify :: MonadState PendingMessages m => B.Microseconds -> Int -> ReceivedMessage - -> StateT PendingMessages m B.DetailedEvent + -> m B.DetailedEvent bustlify µs bytes m = do bm <- buildBustledMessage return $ B.Detailed µs bm bytes m @@ -209,30 +209,29 @@ | otherwise -> return $ B.MessageEvent $ B.Signal { B.sender = wrappedSender , B.member = convertMember signalPath (Just . signalInterface) signalMember sig - , B.signalDestination = fmap stupifyBusName - $ signalDestination sig + , B.signalDestination = stupifyBusName <$> signalDestination sig } _ -> error "woah there! someone added a new message type." -convert :: Monad m +convert :: MonadState PendingMessages m => B.Microseconds -> BS.ByteString - -> StateT PendingMessages m (Either String B.DetailedEvent) + -> m (Either String B.DetailedEvent) convert µs body = case unmarshal body of Left e -> return $ Left $ unmarshalErrorMessage e - Right m -> liftM Right $ bustlify µs (BS.length body) m + Right m -> Right <$> bustlify µs (BS.length body) m data Result e a = EOF | Packet (Either e a) deriving Show -readOne :: (Monad m, MonadIO m) +readOne :: (MonadState s m, MonadIO m) => PcapHandle - -> (B.Microseconds -> BS.ByteString -> StateT s m (Either e a)) - -> StateT s m (Result e a) + -> (B.Microseconds -> BS.ByteString -> m (Either e a)) + -> m (Result e a) readOne p f = do (hdr, body) <- liftIO $ nextBS p -- No really, nextBS just returns null packets when you hit the end of the @@ -242,35 +241,36 @@ -- or something? if hdrCaptureLength hdr == 0 then return EOF - else liftM Packet $ f (fromIntegral (hdrTime hdr)) body + else Packet <$> f (fromIntegral (hdrTime hdr)) body -- This shows up as the biggest thing on the heap profile. Which is kind of a -- surprise. It's supposedly the list. -mapBodies :: (Monad m, MonadIO m) +mapBodies :: (MonadState s m, MonadIO m) => PcapHandle - -> (B.Microseconds -> BS.ByteString -> StateT s m (Either e a)) - -> StateT s m [Either e a] + -> (B.Microseconds -> BS.ByteString -> m (Either e a)) + -> m [Either e a] mapBodies p f = do ret <- readOne p f case ret of - EOF -> return $ [] + EOF -> return [] Packet x -> do xs <- mapBodies p f return $ x:xs -readPcap :: FilePath - -> IO (Either IOError ([String], [B.DetailedEvent])) -readPcap path = try $ do +readPcap :: MonadIO m + => FilePath + -> m (Either IOError ([String], [B.DetailedEvent])) +readPcap path = liftIO $ try $ do p_ <- tryJust matchSnaplenBug $ openOffline path p <- either ioError return p_ dlt <- datalink p -- DLT_NULL for extremely old logs. -- DLT_DBUS is missing: https://github.com/bos/pcap/pull/8 - when (not $ elem dlt [DLT_NULL, DLT_UNKNOWN 231]) $ do + unless (dlt `elem` [DLT_NULL, DLT_UNKNOWN 231]) $ do let message = "Incorrect link type " ++ show dlt ioError $ mkIOError userErrorType message Nothing (Just path) - liftM partitionEithers $ evalStateT (mapBodies p convert) Map.empty + partitionEithers <$> evalStateT (mapBodies p convert) Map.empty where snaplenErrorString = "invalid file capture length 134217728, bigger than maximum of 262144" snaplenBugReference = __ "libpcap 1.8.0 and 1.8.1 are incompatible with Bustle. See \ @@ -280,6 +280,6 @@ \Bustle from Flathub, which already includes the necessary \ \patches: https://flathub.org/apps/details/org.freedesktop.Bustle" matchSnaplenBug e = - if isUserError e && (snaplenErrorString `isSuffixOf` (ioeGetErrorString e)) + if isUserError e && (snaplenErrorString `isSuffixOf` ioeGetErrorString e) then Just $ ioeSetErrorString e snaplenBugReference else Nothing diff --git a/Bustle/Marquee.hs b/Bustle/Marquee.hs --- a/Bustle/Marquee.hs +++ b/Bustle/Marquee.hs @@ -23,6 +23,7 @@ , tag , b , i + , small , light , red , a @@ -49,9 +50,11 @@ toPangoMarkup :: Marquee -> String toPangoMarkup = unMarquee +instance Semigroup Marquee where + Marquee x <> Marquee y = Marquee (x <> y) + instance Monoid Marquee where mempty = Marquee "" - mappend x y = Marquee (unMarquee x `mappend` unMarquee y) mconcat = Marquee . mconcat . map unMarquee tag :: String -> Marquee -> Marquee @@ -61,9 +64,10 @@ , "" ] -b, i :: Marquee -> Marquee +b, i, small :: Marquee -> Marquee b = tag "b" i = tag "i" +small = tag "small" a :: String -> String diff --git a/Bustle/Monitor.hs b/Bustle/Monitor.hs --- a/Bustle/Monitor.hs +++ b/Bustle/Monitor.hs @@ -95,7 +95,7 @@ monitorStop :: Monitor -> IO () -monitorStop monitor = do +monitorStop monitor = withForeignPtr (unMonitor monitor) bustle_pcap_monitor_stop messageLoggedHandler :: (Microseconds -> BS.ByteString -> IO ()) diff --git a/Bustle/Noninteractive.hs b/Bustle/Noninteractive.hs --- a/Bustle/Noninteractive.hs +++ b/Bustle/Noninteractive.hs @@ -48,7 +48,7 @@ warn $ printf (__ "Couldn't parse '%s': %s") filepath err exitFailure Right (warnings, log) -> do - mapM warn warnings + mapM_ warn warnings mapM_ (putStrLn . format) $ analyze log formatInterface :: Maybe InterfaceName -> String @@ -82,5 +82,5 @@ | (s, d) <- nub . mapMaybe (methodCall . deEvent) $ log ] - methodCall (MessageEvent (MethodCall {sender = s, destination = d})) = Just (s, d) + methodCall (MessageEvent MethodCall {sender = s, destination = d}) = Just (s, d) methodCall _ = Nothing diff --git a/Bustle/Regions.hs b/Bustle/Regions.hs --- a/Bustle/Regions.hs +++ b/Bustle/Regions.hs @@ -86,15 +86,15 @@ nonOverlapping :: [Stripe] -> Bool nonOverlapping [] = True -nonOverlapping (_:[]) = True +nonOverlapping [_] = True nonOverlapping (s1:s2:ss) = stripeBottom s1 <= stripeTop s2 && nonOverlapping (s2:ss) regionSelectionNew :: Regions a -> RegionSelection a regionSelectionNew rs - | sorted /= map fst rs = error $ "regionSelectionNew: unsorted regions" - | not (nonOverlapping sorted) = error $ "regionSelectionNew: overlapping regions" + | sorted /= map fst rs = error "regionSelectionNew: unsorted regions" + | not (nonOverlapping sorted) = error "regionSelectionNew: overlapping regions" | otherwise = RegionSelection [] 0 Nothing rs where sorted = sort (map fst rs) @@ -169,7 +169,7 @@ regionSelectionFirst :: RegionSelection a -> RegionSelection a regionSelectionFirst rs = - case (reverse (rsBefore rs) ++ maybeToList (rsCurrent rs) ++ rsAfter rs) of + case reverse (rsBefore rs) ++ maybeToList (rsCurrent rs) ++ rsAfter rs of [] -> rs (first:others) -> RegionSelection [] (midpoint (fst first)) diff --git a/Bustle/Renderer.hs b/Bustle/Renderer.hs --- a/Bustle/Renderer.hs +++ b/Bustle/Renderer.hs @@ -35,21 +35,18 @@ ) where -import Prelude hiding (log) - import Bustle.Types import Bustle.Diagram import Bustle.Regions -import Bustle.Util (maybeM, NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Map as Map import Data.Map (Map) -import Control.Applicative (Applicative(..), (<$>), (<*>)) -import Control.Arrow ((***)) -import Control.Monad.Except +import Control.Arrow (first) +import Control.Monad import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer @@ -76,17 +73,19 @@ deriving (Show, Eq) -instance Monoid Participants where - mempty = Participants Map.empty Map.empty - mappend (Participants sess1 sys1) (Participants sess2 sys2) = - Participants (f sess1 sess2) - (f sys1 sys2) +instance Semigroup Participants where + (<>) (Participants sess1 sys1) (Participants sess2 sys2) = + Participants (f sess1 sess2) + (f sys1 sys2) where f = Map.unionWith Set.union +instance Monoid Participants where + mempty = Participants Map.empty Map.empty + sessionParticipants :: Participants -> [(UniqueName, Set OtherName)] -- ^ sorted by column -sessionParticipants = map (snd *** id) . Map.toAscList . pSession +sessionParticipants = map (first snd) . Map.toAscList . pSession data RendererResult apps = RendererResult { rrCentreOffset :: Double @@ -109,9 +108,9 @@ -- -- This is extremely unpleasant but it's a Monday. There's a test case in -- Test/Renderer.hs because I don't trust myself. -instance Monoid apps => Monoid (RendererResult apps) where - mempty = RendererResult 0 0 [] [] mempty [] - mappend rr1 rr2 = RendererResult centreOffset topOffset shapes regions applications warnings + +instance Semigroup apps => Semigroup (RendererResult apps) where + rr1 <> rr2 = RendererResult centreOffset topOffset shapes regions applications warnings where centreOffset = rrCentreOffset rr1 `max` rrCentreOffset rr2 topOffset = rrTopOffset rr1 `max` rrTopOffset rr2 @@ -136,15 +135,19 @@ regions = translatedRegions rr1 ++ translatedRegions rr2 - applications = rrApplications rr1 `mappend` rrApplications rr2 - warnings = rrWarnings rr1 `mappend` rrWarnings rr2 + applications = rrApplications rr1 <> rrApplications rr2 + warnings = rrWarnings rr1 <> rrWarnings rr2 + +instance Monoid apps => Monoid (RendererResult apps) where + mempty = RendererResult 0 0 [] [] mempty [] + processWithFilters :: (Log, Set UniqueName) -> (Log, Set UniqueName) -> RendererResult () processWithFilters (sessionBusLog, sessionFilter) (systemBusLog, systemFilter ) = - fmap (const ()) $ fst $ processSome sessionBusLog systemBusLog rs + void $ fst $ processSome sessionBusLog systemBusLog rs where rs = initialState sessionFilter systemFilter @@ -206,15 +209,12 @@ (StateT RendererState Identity) a) deriving ( Functor + , Applicative , Monad , MonadState RendererState , MonadWriter RendererOutput ) -instance Applicative Renderer where - pure = return - (<*>) = ap - runRenderer :: Renderer () -> RendererState -> ( RendererOutput @@ -229,12 +229,13 @@ deriving (Show) -instance Monoid RendererOutput where - mempty = RendererOutput [] [] [] - mappend (RendererOutput s1 r1 w1) - (RendererOutput s2 r2 w2) = RendererOutput (s1 ++ s2) +instance Semigroup RendererOutput where + (<>) (RendererOutput s1 r1 w1) + (RendererOutput s2 r2 w2) = RendererOutput (s1 ++ s2) (r1 ++ r2) (w1 ++ w2) +instance Monoid RendererOutput where + mempty = RendererOutput [] [] [] data BusState = BusState { apps :: Applications @@ -256,10 +257,10 @@ initialBusState :: Set UniqueName -> Double -> BusState -initialBusState ignore first = +initialBusState ignore x = BusState { apps = Map.empty - , firstColumn = first - , nextColumn = first + , firstColumn = x + , nextColumn = x , columnsInUse = Set.empty , pending = Map.empty , bsIgnoredNames = ignore @@ -450,12 +451,10 @@ addUnique bus n = do let ai = ApplicationInfo NoColumn Set.empty Set.empty existing <- getsApps (Map.lookup n) bus - case existing of - Nothing -> return () - Just _ -> warn $ concat [ "Unique name '" - , unUniqueName n - , "' apparently connected to the bus twice" - ] + forM_ existing $ const $ warn $ concat [ "Unique name '" + , unUniqueName n + , "' apparently connected to the bus twice" + ] modifyApps bus $ Map.insert n ai return ai @@ -466,7 +465,7 @@ ai <- lookupUniqueName bus n let mcolumn = aiCurrentColumn ai modifyApps bus $ Map.insert n (ai { aiColumn = FormerColumn mcolumn }) - maybeM mcolumn $ \x -> + forM_ mcolumn $ \x -> modifyBusState bus $ \bs -> bs { columnsInUse = Set.delete x (columnsInUse bs) } @@ -541,7 +540,7 @@ ] let (height, ss) = headers xs' (current' + 20) tellShapes ss - modify $ \bs -> bs { mostRecentLabels = (current' + height + 10) + modify $ \bs -> bs { mostRecentLabels = current' + height + 10 , row = row bs + height + 10 } current <- gets row @@ -563,7 +562,7 @@ bestNames :: UniqueName -> Set OtherName -> [String] bestNames u os | Set.null os = [unUniqueName u] - | otherwise = reverse . sortBy (comparing length) . map readable $ Set.toList os + | otherwise = (sortBy (flip (comparing length)) . map readable) $ Set.toList os where readable = reverse . takeWhile (/= '.') . reverse . unOtherName edgemostApp :: Bus -> Renderer (Maybe Double) @@ -633,7 +632,7 @@ shape $ Arc { topx = callx, topy = cally , bottomx = currentx, bottomy = currenty - , arcside = if (destinationx > currentx) then L else R + , arcside = if destinationx > currentx then L else R , caption = show (µsToMs duration) ++ "ms" } @@ -687,23 +686,21 @@ where advance = advanceBy eventHeight -- FIXME: use some function of timestamp? returnOrError f = do call <- findCallCoordinates bus (inReplyTo m) - case call of - Nothing -> return () - Just (dm', (x,y)) -> do - advance - relativeTimestamp dm - memberName dm' True - f dm - let duration = deTimestamp dm - deTimestamp dm' - returnArc bus dm x y duration - addMessageRegion dm + forM_ call $ \(dm', (x,y)) -> do + advance + relativeTimestamp dm + memberName dm' True + f dm + let duration = deTimestamp dm - deTimestamp dm' + returnArc bus dm x y duration + addMessageRegion dm processNOC :: Bus -> NOC -> Renderer () processNOC bus noc = case noc of - Connected { actor = u } -> addUnique bus u >> return () + Connected { actor = u } -> void (addUnique bus u) Disconnected { actor = u } -> remUnique bus u NameChanged { changedName = n , change = c @@ -734,7 +731,7 @@ mtarget <- signalDestinationCoordinate bus dm case mtarget of - Just target -> do + Just target -> shape $ DirectedSignalArrow emitter target t Nothing -> do -- fromJust is safe here because we must have an app to have a diff --git a/Bustle/StatisticsPane.hs b/Bustle/StatisticsPane.hs --- a/Bustle/StatisticsPane.hs +++ b/Bustle/StatisticsPane.hs @@ -23,8 +23,7 @@ ) where -import Control.Applicative ((<$>)) -import Control.Monad (forM_) +import Control.Monad (forM_, void) import Text.Printf import Graphics.UI.Gtk import Bustle.Missing (formatSize) @@ -110,13 +109,12 @@ -> String -> (a -> Marquee) -> IO () -addStatColumn view store title f = do +addStatColumn view store title f = void $ do col <- treeViewColumnNew treeViewColumnSetTitle col title renderer <- addTextRenderer col store True f set renderer [ cellXAlign := 1 ] treeViewAppendColumn view col - return () addTextStatColumn :: TreeView -> ListStore a @@ -157,9 +155,9 @@ countBar <- cellRendererProgressNew cellLayoutPackStart countColumn countBar True cellLayoutSetAttributes countColumn countBar countStore $ - \(FrequencyInfo {fiFrequency = count}) -> + \FrequencyInfo {fiFrequency = count} -> [ cellProgressValue :=> do - upperBound <- (maximum . map fiFrequency) <$> + upperBound <- maximum . map fiFrequency <$> listStoreToList countStore -- ensure that we always show *something* return $ 2 + (count * 98 `div` upperBound) diff --git a/Bustle/Stats.hs b/Bustle/Stats.hs --- a/Bustle/Stats.hs +++ b/Bustle/Stats.hs @@ -31,7 +31,7 @@ where import Control.Monad (guard) -import Data.List (sort, sortBy) +import Data.List (sortBy) import Data.Maybe (mapMaybe) import Data.Ord (comparing) @@ -62,9 +62,7 @@ deriving (Show, Eq, Ord) frequencies :: Log -> [FrequencyInfo] -frequencies = reverse - . sort - . map (\((t, i, m), c) -> FrequencyInfo c t i m) +frequencies = sortBy (flip compare) . map (\((t, i, m), c) -> FrequencyInfo c t i m) . Map.toList . foldr (Map.alter alt) Map.empty . mapMaybe repr @@ -86,9 +84,7 @@ methodTimes :: Log -> [TimeInfo] -methodTimes = reverse - . sortBy (comparing tiTotalTime) - . map summarize +methodTimes = sortBy (flip (comparing tiTotalTime)) . map summarize . Map.toList . foldr (\(i, method, time) -> Map.alter (alt time) (i, method)) Map.empty @@ -101,7 +97,7 @@ Just (newtime + total, newtime : times) isReturn :: Message -> Bool - isReturn (MethodReturn {}) = True + isReturn MethodReturn {} = True isReturn _ = False methodReturn :: Detailed Message @@ -109,7 +105,7 @@ methodReturn dm = do let m = deEvent dm guard (isReturn m) - Detailed start (call@(MethodCall {})) _ _ <- inReplyTo m + Detailed start call@MethodCall {} _ _ <- inReplyTo m return ( iface (member call) , membername (member call) , deTimestamp dm - start @@ -120,7 +116,7 @@ , tiMethodName = method , tiTotalTime = fromIntegral total / 1000 , tiCallFrequency = length times - , tiMeanCallTime = (mean $ map fromIntegral times) / 1000 + , tiMeanCallTime = mean (map fromIntegral times) / 1000 } -- FIXME: really? again? @@ -145,7 +141,7 @@ messageSizes :: Log -> [SizeInfo] messageSizes messages = - reverse . sort . map summarize $ Map.assocs sizeTable + sortBy (flip compare) . map summarize $ Map.assocs sizeTable where summarize :: ((SizeType, Maybe InterfaceName, MemberName), [Int]) -> SizeInfo summarize ((t, i, m), sizes) = diff --git a/Bustle/UI.hs b/Bustle/UI.hs --- a/Bustle/UI.hs +++ b/Bustle/UI.hs @@ -23,14 +23,17 @@ ) where +import Control.Monad (void) import Control.Monad.Reader import Control.Monad.State import Control.Monad.Except import Data.IORef +import qualified Data.Map as Map import qualified Data.Set as Set import Data.List (intercalate) import Data.Time +import Data.Tuple (swap) import Data.Monoid (mempty) import Text.Printf @@ -39,7 +42,8 @@ import Bustle.Renderer import Bustle.Types import Bustle.Diagram -import Bustle.Marquee (toString) +import qualified Bustle.Marquee as Marquee +import Bustle.Monitor import Bustle.Util import Bustle.UI.AboutDialog import Bustle.UI.Canvas @@ -48,16 +52,14 @@ import Bustle.UI.OpenTwoDialog (setupOpenTwoDialog) import Bustle.UI.Recorder import Bustle.UI.RecordAddressDialog (showRecordAddressDialog) -import Bustle.UI.Util (displayError) import Bustle.StatisticsPane import Bustle.Translation (__) import Bustle.Loader +import Bustle.Loader.Pcap (convert) import qualified Control.Exception as C import System.Glib.GError (GError(..), failOnGError) -import System.Glib.Properties ( objectSetPropertyString - , objectSetPropertyMaybeString - ) +import System.GIO.Enums (IOErrorEnum(IoErrorCancelled)) import Graphics.UI.Gtk @@ -86,11 +88,19 @@ data WindowInfo = WindowInfo { wiWindow :: Window - , wiHeaderBar :: Widget -- TODO, GtkHeaderBar + , wiTitle :: Label + , wiSubtitle :: Label + , wiSpinner :: Spinner + , wiRecord :: Button + , wiStop :: Button + , wiOpen :: Button , wiSave :: Button , wiExport :: Button , wiViewStatistics :: CheckMenuItem , wiFilterNames :: MenuItem + , wiErrorBar :: InfoBar + , wiErrorBarTitle :: Label + , wiErrorBarDetails :: Label , wiStack :: Stack , wiSidebarHeader :: Widget -- TODO, GtkHeaderBar , wiSidebarStack :: Stack @@ -102,7 +112,7 @@ , wiLogDetails :: IORef (Maybe LogDetails) } -data BConfig = +newtype BConfig = BConfig { debugEnabled :: Bool } @@ -152,8 +162,8 @@ createInitialWindow :: B () createInitialWindow = do - misc <- emptyWindow - modify $ \s -> s { initialWindow = Just misc } + wi <- emptyWindow + putInitialWindow wi consumeInitialWindow :: B WindowInfo consumeInitialWindow = do @@ -164,6 +174,11 @@ modify $ \s -> s { initialWindow = Nothing } return windowInfo +putInitialWindow :: WindowInfo + -> B () +putInitialWindow wi = + modify $ \s -> s { initialWindow = Just wi } + loadInInitialWindow :: LogDetails -> B () loadInInitialWindow = loadLogWith consumeInitialWindow @@ -190,6 +205,8 @@ -> LogDetails -> B () loadLogWith getWindow logDetails = do + windowInfo <- getWindow + ret <- runExceptT $ do ((sessionWarnings, sessionMessages), (systemWarnings, systemMessages)) <- openLog logDetails @@ -198,7 +215,6 @@ let rr = process sessionMessages systemMessages io $ mapM warn $ sessionWarnings ++ systemWarnings ++ rrWarnings rr - windowInfo <- lift getWindow lift $ displayLog windowInfo logDetails sessionMessages @@ -206,28 +222,147 @@ rr case ret of - Left (LoadError f e) -> io $ - displayError Nothing (printf (__ "Could not read '%s'") f) (Just e) - Right () -> return () + Left (LoadError f e) -> do + let title = printf (__ "Could not read '%s'") f + io $ displayError windowInfo title (Just e) + putInitialWindow windowInfo + Right () -> + io $ hideError windowInfo + io $ windowPresent (wiWindow windowInfo) + + +updateRecordingSubtitle :: WindowInfo + -> Int + -> IO () +updateRecordingSubtitle wi j = do + let message = printf (__ "Logged %u messages") j :: String + labelSetMarkup (wiSubtitle wi) message + + +processBatch :: IORef [DetailedEvent] + -> IORef Int + -> WindowInfo + -> IO (IO Bool) +processBatch pendingRef n wi = do + rendererStateRef <- newIORef rendererStateNew + -- FIXME: this is stupid. If we have to manually combine the outputs, it's + -- basically just more state. + rendererResultRef <- newIORef mempty + + return $ do + pending <- readIORef pendingRef + writeIORef pendingRef [] + + unless (null pending) $ do + rr <- atomicModifyIORef' rendererStateRef $ \s -> + swap $ processSome (reverse pending) [] s + + oldRR <- readIORef rendererResultRef + let rr' = oldRR `mappend` rr + writeIORef rendererResultRef rr' + + unless (null (rrShapes rr)) $ do + -- If the renderer produced some visible output, count it as a + -- message from the user's perspective. + modifyIORef' n (+ length pending) + j <- readIORef n + updateRecordingSubtitle wi j + + aChallengerAppears wi rr' + + return True + + +recorderRun :: WindowInfo + -> Either BusType String + -> FilePath + -> BustleEnv BConfig BState + -> IO () +recorderRun wi target filename r = C.handle newFailed $ do + -- TODO: I'm pretty sure the monitor is leaked + monitor <- monitorNew target filename + loaderStateRef <- newIORef Map.empty + pendingRef <- newIORef [] + + let updateLabel µs body = do + s <- readIORef loaderStateRef + (m, s') <- runStateT (convert µs body) s + s' `seq` writeIORef loaderStateRef s' + + case m of + Left e -> warn e + Right message + | isRelevant (deEvent message) -> + modifyIORef' pendingRef (message:) + | otherwise -> return () + + n <- newIORef (0 :: Int) + processor <- processBatch pendingRef n wi + processorId <- timeoutAdd processor 200 + + stopActivatedId <- wiStop wi `on` buttonActivated $ monitorStop monitor + handlerId <- monitor `on` monitorMessageLogged $ updateLabel + void $ monitor `on` monitorStopped $ \domain code message -> do + handleError domain code message + + signalDisconnect stopActivatedId + signalDisconnect handlerId + + -- Flush out any last messages from the queue. + timeoutRemove processorId + processor + + hadOutput <- fmap (/= 0) (readIORef n) + finished hadOutput + where + newFailed (GError domain code message) = do + finished False + handleError domain code message + + finished hadOutput = + makeCallback (finishedRecording wi filename hadOutput) r + + -- Filter out IoErrorCancelled. In theory one should use + -- catchGErrorJust IoErrorCancelled computation (\_ -> return ()) + -- but IOErrorEnum does not have an instance for GError domain. + handleError domain code message = do + gIoErrorQuark <- quarkFromString "g-io-error-quark" + let cancelled = fromEnum IoErrorCancelled + unless (domain == gIoErrorQuark && code == cancelled) $ + displayError wi (Marquee.toString message) Nothing + + startRecording :: Either BusType String -> B () startRecording target = do wi <- consumeInitialWindow - zt <- io $ getZonedTime + zt <- io getZonedTime -- I hate time manipulation let yyyy_mm_dd_hh_mm_ss = takeWhile (/= '.') (show zt) - cacheDir <- io $ getCacheDir + cacheDir <- io getCacheDir let filename = cacheDir yyyy_mm_dd_hh_mm_ss <.> "bustle" + let title = printf (__ "Recording %s…") $ case target of + Left BusTypeNone -> error "whoops, this value shouldn't exist" + Left BusTypeSession -> "session bus" + Left BusTypeSystem -> "system bus" + Right address -> address + + io $ do + hideError wi + widgetHide (wiRecord wi) + widgetHide (wiOpen wi) + widgetShow (wiStop wi) + widgetGrabFocus (wiStop wi) + spinnerStart (wiSpinner wi) + labelSetMarkup (wiTitle wi) (title :: String) + updateRecordingSubtitle wi 0 + setPage wi PleaseHoldPage - let mwindow = Just (wiWindow wi) - progress = aChallengerAppears wi - finished = finishedRecording wi filename - embedIO $ \r -> recorderRun target filename mwindow progress - (\p -> makeCallback (finished p) r) + embedIO $ recorderRun wi target filename aChallengerAppears :: WindowInfo -> RendererResult a @@ -241,16 +376,21 @@ => menuItem -> IO () -> IO (ConnectId menuItem) -onMenuItemActivate mi act = - on mi menuItemActivate act +onMenuItemActivate mi = on mi menuItemActivate finishedRecording :: WindowInfo -> FilePath -> Bool -> B () finishedRecording wi tempFilePath producedOutput = do + io $ do + widgetShow (wiRecord wi) + widgetShow (wiOpen wi) + widgetHide (wiStop wi) + spinnerStop (wiSpinner wi) + if producedOutput - then do + then void $ do -- TODO: There is a noticable lag when reloading big files. It would be -- nice to either make the loading faster, or eliminate the reload. loadLogWith (return wi) (RecordedLog tempFilePath) @@ -260,11 +400,13 @@ io $ do widgetSetSensitivity saveItem True saveItem `on` buttonActivated $ showSaveDialog wi (return ()) - return () else do setPage wi InstructionsPage - modify $ \s -> s { initialWindow = Just wi } + putInitialWindow wi updateDisplayedLog wi (mempty :: RendererResult ()) + io $ do + wiTitle wi `set` [ labelText := "" ] + wiSubtitle wi `set` [ labelText := "" ] showSaveDialog :: WindowInfo -> IO () @@ -278,22 +420,19 @@ let tempFile = fileFromParseName tempFilePath let newFile = fileFromParseName newFilePath - C.catch (fileMove tempFile newFile [FileCopyOverwrite] Nothing Nothing) $ \(GError _ _ msg) -> do - d <- messageDialogNew mwindow [DialogModal] MessageError ButtonsOk (__ "Couldn't save log") - let secondary :: String - secondary = printf - (__ "Error: %s\n\n\ - \You might want to manually recover the log from the temporary file at\n\ - \%s") (toString msg) tempFilePath - messageDialogSetSecondaryMarkup d secondary - widgetShowAll d - d `after` response $ \_ -> do - widgetDestroy d - return () - - widgetSetSensitivity (wiSave wi) False - wiSetLogDetails wi (SingleLog newFilePath) - savedCb + result <- C.try $ fileMove tempFile newFile [FileCopyOverwrite] Nothing Nothing + case result of + Right _ -> do + widgetSetSensitivity (wiSave wi) False + wiSetLogDetails wi (SingleLog newFilePath) + hideError wi + savedCb + Left (GError _ _ msg) -> do + let title = __ "Couldn't save log: " ++ Marquee.toString msg + secondary = printf + (__ "You might want to manually recover the log from the temporary file at \ + \\"%s\".") tempFilePath + displayError wi title (Just secondary) -- | Show a confirmation dialog if the log is unsaved. Suitable for use as a -- 'delete-event' handler. @@ -344,18 +483,32 @@ let getW cast name = io $ builderGetObject builder cast name window <- getW castToWindow "diagramWindow" - header <- getW castToWidget "header" + title <- getW castToLabel "headerTitle" + subtitle <- getW castToLabel "headerSubtitle" + spinner <- getW castToSpinner "headerSpinner" + [openItem, openTwoItem] <- mapM (getW castToMenuItem) ["open", "openTwo"] recordSessionItem <- getW castToMenuItem "recordSession" recordSystemItem <- getW castToMenuItem "recordSystem" recordAddressItem <- getW castToMenuItem "recordAddress" - [headerSave, headerExport] <- mapM (getW castToButton) ["headerSave", "headerExport"] + headerRecord <- getW castToButton "headerRecord" + headerStop <- getW castToButton "headerStop" + headerOpen <- getW castToButton "headerOpen" + headerSave <- getW castToButton "headerSave" + headerExport <- getW castToButton "headerExport" viewStatistics <- getW castToCheckMenuItem "statistics" filterNames <- getW castToMenuItem "filter" aboutItem <- getW castToMenuItem "about" + errorBar <- getW castToInfoBar "errorBar" + errorBarTitle <- getW castToLabel "errorBarTitle" + errorBarDetails <- getW castToLabel "errorBarDetails" + + io $ errorBar `on` infoBarResponse $ \_ -> + widgetHide errorBar + stack <- getW castToStack "diagramOrNot" sidebarHeader <- getW castToWidget "sidebarHeader" sidebarStack <- getW castToStack "sidebarStack" @@ -379,7 +532,7 @@ showRecordAddressDialog window $ \address -> makeCallback (startRecording (Right address)) r - onMenuItemActivate openItem $ makeCallback openDialogue r + onMenuItemActivate openItem $ makeCallback (showOpenDialog window) r onMenuItemActivate openTwoItem $ widgetShowAll openTwoDialog -- TODO: really this wants to live in the application menu, but that entails binding GApplication, @@ -400,11 +553,19 @@ logDetailsRef <- io $ newIORef Nothing let windowInfo = WindowInfo { wiWindow = window - , wiHeaderBar = header + , wiTitle = title + , wiSubtitle = subtitle + , wiSpinner = spinner + , wiRecord = headerRecord + , wiOpen = headerOpen + , wiStop = headerStop , wiSave = headerSave , wiExport = headerExport , wiViewStatistics = viewStatistics , wiFilterNames = filterNames + , wiErrorBar = errorBar + , wiErrorBarTitle = errorBarTitle + , wiErrorBarDetails = errorBarDetails , wiStack = stack , wiSidebarHeader = sidebarHeader , wiSidebarStack = sidebarStack @@ -423,9 +584,9 @@ updateDetailsView :: DetailsView -> Maybe (Detailed Message) -> IO () -updateDetailsView detailsView newMessage = do +updateDetailsView detailsView newMessage = case newMessage of - Nothing -> do + Nothing -> widgetHide $ detailsViewGetTop detailsView Just m -> do detailsViewUpdate detailsView m @@ -451,15 +612,15 @@ (d, f) = splitFileName s logWindowTitle :: LogDetails - -> (String, Maybe String) -logWindowTitle (RecordedLog filepath) = ("*" ++ takeFileName filepath, Nothing) -logWindowTitle (SingleLog filepath) = (name, Just directory) + -> (String, String) +logWindowTitle (RecordedLog filepath) = ("*" ++ takeFileName filepath, "") +logWindowTitle (SingleLog filepath) = (name, directory) where (directory, name) = splitFileName_ filepath logWindowTitle (TwoLogs sessionPath systemPath) = -- TODO: this looks terrible, need a custom widget (sessionName ++ " & " ++ systemName, - Just $ if sessionDirectory == systemDirectory + if sessionDirectory == systemDirectory then sessionDirectory else sessionDirectory ++ " & " ++ systemDirectory) where @@ -480,10 +641,9 @@ wiSetLogDetails wi logDetails = do writeIORef (wiLogDetails wi) (Just logDetails) let (title, subtitle) = logWindowTitle logDetails - (wiWindow wi) `set` [ windowTitle := title ] - -- TODO: add to gtk2hs - objectSetPropertyString "title" (wiHeaderBar wi) title - objectSetPropertyMaybeString "subtitle" (wiHeaderBar wi) subtitle + wiWindow wi `set` [ windowTitle := title ] + wiTitle wi `set` [ labelText := title ] + wiSubtitle wi `set` [ labelText := subtitle ] setPage :: MonadIO io => WindowInfo @@ -497,7 +657,7 @@ -> Log -> RendererResult Participants -> B () -displayLog wi@(WindowInfo { wiWindow = window +displayLog wi@WindowInfo { wiWindow = window , wiExport = exportItem , wiViewStatistics = viewStatistics , wiFilterNames = filterNames @@ -505,12 +665,11 @@ , wiSidebarHeader = sidebarHeader , wiSidebarStack = sidebarStack , wiStatsPane = statsPane - }) + } logDetails sessionMessages systemMessages - rr = do - io $ do + rr = io $ void $ do wiSetLogDetails wi logDetails hiddenRef <- newIORef Set.empty @@ -546,15 +705,15 @@ updateDisplayedLog wi rr' - return () - -openDialogue :: B () -openDialogue = embedIO $ \r -> do - chooser <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen +showOpenDialog :: Window + -> B () +showOpenDialog window = embedIO $ \r -> do + chooser <- fileChooserDialogNew Nothing (Just window) FileChooserActionOpen [ ("gtk-cancel", ResponseCancel) , ("gtk-open", ResponseAccept) ] - chooser `set` [ fileChooserLocalOnly := True + chooser `set` [ windowModal := True + , fileChooserLocalOnly := True ] chooser `after` response $ \resp -> do @@ -590,16 +749,50 @@ RecordedLog _ -> Nothing SingleLog p -> Just $ takeDirectory p TwoLogs p _ -> Just $ takeDirectory p - maybeM mdirectory $ fileChooserSetCurrentFolder chooser + forM_ mdirectory $ fileChooserSetCurrentFolder chooser chooser `after` response $ \resp -> do when (resp == ResponseAccept) $ do Just fn <- io $ fileChooserGetFilename chooser let (width, height) = diagramDimensions shapes - withPDFSurface fn width height $ - \surface -> renderWith surface $ drawDiagram False shapes + + r <- C.try $ withPDFSurface fn width height $ \surface -> + renderWith surface $ drawDiagram False shapes + case r of + Left (e :: C.IOException) -> do + let title = __ "Couldn't export log as PDF: " ++ show e + displayError wi title Nothing + Right () -> + hideError wi + widgetDestroy chooser widgetShowAll chooser + + +displayError :: WindowInfo + -> String + -> Maybe String + -> IO () +displayError wi title mbody = do + labelSetMarkup (wiErrorBarTitle wi) . Marquee.toPangoMarkup + . Marquee.b + $ Marquee.escape title + + let details = wiErrorBarDetails wi + case mbody of + Just body -> do + labelSetMarkup details . Marquee.toPangoMarkup + . Marquee.small + $ Marquee.escape body + widgetShow details + Nothing -> widgetHide details + + widgetShow $ wiErrorBar wi + + +hideError :: WindowInfo + -> IO () +hideError = widgetHide . wiErrorBar -- vim: sw=2 sts=2 diff --git a/Bustle/UI/AboutDialog.hs b/Bustle/UI/AboutDialog.hs --- a/Bustle/UI/AboutDialog.hs +++ b/Bustle/UI/AboutDialog.hs @@ -69,4 +69,5 @@ , "Alex Merry" , "Philip Withnall" , "Jonny Lamb" + , "Daniel Firth" ] diff --git a/Bustle/UI/Canvas.hs b/Bustle/UI/Canvas.hs --- a/Bustle/UI/Canvas.hs +++ b/Bustle/UI/Canvas.hs @@ -32,7 +32,7 @@ import Data.Maybe (isNothing) import Data.IORef -import Control.Monad (when) +import Control.Monad (forM_, when, void) import Graphics.UI.Gtk import Graphics.Rendering.Cairo (Render, translate) @@ -92,7 +92,7 @@ setupCanvas :: Eq a => Canvas a -> IO () -setupCanvas canvas = do +setupCanvas canvas = void $ do let layout = canvasLayout canvas -- Scrolling @@ -133,7 +133,6 @@ _ -> stopEvent layout `on` draw $ canvasDraw canvas - return () canvasInvalidateArea :: Canvas a -> Int @@ -174,12 +173,10 @@ when (isNothing id_) $ do id' <- flip idleAdd priorityDefaultIdle $ do rs <- readIORef $ canvasSelection canvas - case rsCurrent rs of - Nothing -> return () - Just (Stripe top bottom, _) -> do - vadj <- layoutGetVAdjustment $ canvasLayout canvas - let padding = (bottom - top) / 2 - adjustmentClampPage vadj (top - padding) (bottom + padding) + forM_ (rsCurrent rs) $ \(Stripe top bottom, _) -> do + vadj <- layoutGetVAdjustment $ canvasLayout canvas + let padding = (bottom - top) / 2 + adjustmentClampPage vadj (top - padding) (bottom + padding) writeIORef idRef Nothing return False @@ -206,10 +203,10 @@ writeIORef regionSelectionRef rs' when (newMessage /= currentMessage) $ do - maybeM currentMessage $ \(r, _) -> + forM_ currentMessage $ \(r, _) -> canvasInvalidateStripe canvas r - maybeM newMessage $ \(r, _) -> do + forM_ newMessage $ \(r, _) -> do canvasInvalidateStripe canvas r canvasClampAroundSelection canvas @@ -281,8 +278,7 @@ canvasFocus :: Canvas a -> IO () -canvasFocus canvas = do - (canvasLayout canvas) `set` [ widgetIsFocus := True ] +canvasFocus canvas = canvasLayout canvas `set` [ widgetIsFocus := True ] canvasScrollToBottom :: Canvas a -> IO () diff --git a/Bustle/UI/DetailsView.hs b/Bustle/UI/DetailsView.hs --- a/Bustle/UI/DetailsView.hs +++ b/Bustle/UI/DetailsView.hs @@ -36,6 +36,9 @@ data DetailsView = DetailsView { detailsGrid :: Grid , detailsType :: Stack + , detailsSender :: Label + , detailsDestinationCaption :: Label + , detailsDestination :: Label , detailsPath :: Label , detailsMember :: Label , detailsBodyView :: TextView @@ -43,14 +46,15 @@ detailsViewNew :: Builder -> IO DetailsView -detailsViewNew builder = do - grid <- builderGetObject builder castToGrid "detailsGrid" - type_ <- builderGetObject builder castToStack "detailsType" - pathLabel <- builderGetObject builder castToLabel "detailsPath" - memberLabel <- builderGetObject builder castToLabel "detailsMember" - view <- builderGetObject builder castToTextView "detailsArguments" - - return $ DetailsView grid type_ pathLabel memberLabel view +detailsViewNew builder = DetailsView + <$> builderGetObject builder castToGrid "detailsGrid" + <*> builderGetObject builder castToStack "detailsType" + <*> builderGetObject builder castToLabel "detailsSender" + <*> builderGetObject builder castToLabel "detailsDestinationCaption" + <*> builderGetObject builder castToLabel "detailsDestination" + <*> builderGetObject builder castToLabel "detailsPath" + <*> builderGetObject builder castToLabel "detailsMember" + <*> builderGetObject builder castToTextView "detailsArguments" pickType :: Detailed Message -> String pickType (Detailed _ m _ _) = case m of @@ -58,9 +62,7 @@ MethodReturn {} -> "methodReturn" Error {} -> "error" Signal { signalDestination = d } -> - case d of - Nothing -> "signal" - Just _ -> "directedSignal" + maybe "signal" (const "directedSignal") d getMemberMarkup :: Member -> String getMemberMarkup m = @@ -73,8 +75,13 @@ MethodReturn {} -> callMember Error {} -> callMember where - callMember = fmap (member . deEvent) $ inReplyTo m + callMember = member . deEvent <$> inReplyTo m +getDestination :: Detailed Message -> Maybe TaggedBusName +getDestination (Detailed _ m _ _) = case m of + Signal { signalDestination = d } -> d + _ -> Just (destination m) + formatMessage :: Detailed Message -> String formatMessage (Detailed _ _ _ rm) = formatArgs $ D.receivedMessageBody rm @@ -91,6 +98,19 @@ buf <- textViewGetBuffer $ detailsBodyView d let member_ = getMember m stackSetVisibleChildName (detailsType d) (pickType m) + + -- TODO: these would be a lot more useful if we could resolve unique names + -- to/from well-known names and show both + labelSetText (detailsSender d) (unBusName . sender . deEvent $ m) + case getDestination m of + Just n -> do + labelSetText (detailsDestination d) (unBusName n) + widgetShow (detailsDestination d) + widgetShow (detailsDestinationCaption d) + Nothing -> do + widgetHide (detailsDestination d) + widgetHide (detailsDestinationCaption d) + labelSetText (detailsPath d) (maybe unknown (D.formatObjectPath . path) member_) labelSetMarkup (detailsMember d) (maybe unknown getMemberMarkup member_) textBufferSetText buf $ formatMessage m diff --git a/Bustle/UI/FilterDialog.hs b/Bustle/UI/FilterDialog.hs --- a/Bustle/UI/FilterDialog.hs +++ b/Bustle/UI/FilterDialog.hs @@ -23,7 +23,7 @@ ) where -import Data.List (intercalate, groupBy, findIndices) +import Data.List (intercalate, groupBy, elemIndices) import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Function as F @@ -35,7 +35,7 @@ namespace :: String -> (String, String) -namespace name = case reverse (findIndices (== '.') name) of +namespace name = case reverse (elemIndices '.' name) of [] -> ("", name) (i:_) -> splitAt (i + 1) name @@ -51,17 +51,17 @@ groupGroup xs@((ns, _):_) = (ns, map snd xs) formatGroup (ns, [y]) = ns ++ y - formatGroup (ns, ys) = ns ++ "{" ++ (intercalate "," ys) ++ "}" + formatGroup (ns, ys) = ns ++ "{" ++ intercalate "," ys ++ "}" type NameStore = ListStore (Bool, (UniqueName, Set OtherName)) makeStore :: [(UniqueName, Set OtherName)] -> Set UniqueName -> IO NameStore -makeStore names currentlyHidden = do +makeStore names currentlyHidden = listStoreNew $ map toPair names where - toPair (name@(u, _)) = (not (Set.member u currentlyHidden), name) + toPair name@(u, _) = (not (Set.member u currentlyHidden), name) makeView :: NameStore -> IO ScrolledWindow @@ -111,7 +111,7 @@ windowSetDefaultSize d (windowWidth * 7 `div` 8) (windowHeight `div` 2) d `set` [ windowTransientFor := parent ] dialogAddButton d stockClose ResponseClose - vbox <- fmap castToBox $ dialogGetContentArea d + vbox <- castToBox <$> dialogGetContentArea d boxSetSpacing vbox 6 nameStore <- makeStore names currentlyHidden diff --git a/Bustle/UI/OpenTwoDialog.hs b/Bustle/UI/OpenTwoDialog.hs --- a/Bustle/UI/OpenTwoDialog.hs +++ b/Bustle/UI/OpenTwoDialog.hs @@ -23,7 +23,7 @@ where import Data.Maybe (isJust, isNothing, fromJust) -import Control.Monad (when) +import Control.Monad (when, void) import Graphics.UI.Gtk @@ -42,12 +42,8 @@ f1 <- fileChooserGetCurrentFolder d1 f2 <- fileChooserGetCurrentFolder d2 otherFile <- fileChooserGetFilename d2 - when (and [ isNothing otherFile - , f1 /= f2 - , isJust f1 - ]) $ do + when (isNothing otherFile && f1 /= f2 && isJust f1) $ void $ fileChooserSetCurrentFolder d2 (fromJust f1) - return () setupOpenTwoDialog :: Window -> (FilePath -> FilePath -> IO ()) diff --git a/Bustle/UI/Recorder.hs b/Bustle/UI/Recorder.hs --- a/Bustle/UI/Recorder.hs +++ b/Bustle/UI/Recorder.hs @@ -20,160 +20,13 @@ module Bustle.UI.Recorder ( recorderChooseFile - , recorderRun - , BusType(..) ) where -import Control.Monad (when, liftM) -import Control.Concurrent.MVar -import qualified Data.Map as Map -import Data.Maybe (maybeToList) -import Control.Monad.State (runStateT) -import Text.Printf - -import qualified Control.Exception as C -import System.GIO.Enums (IOErrorEnum(IoErrorCancelled)) -import System.Glib.GObject (quarkFromString) -import System.Glib.GError import Graphics.UI.Gtk - -import Bustle.Loader.Pcap (convert) -import Bustle.Loader (isRelevant) -import Bustle.Marquee (toString) -import Bustle.Monitor -import Bustle.Renderer -import Bustle.Translation (__) -import Bustle.Types -import Bustle.UI.Util (displayError) -import Bustle.Util - -type RecorderIncomingCallback = RendererResult Participants - -> IO () -type RecorderFinishedCallback = Bool -- ^ was anything meaningful actually recorded? - -> IO () - -processBatch :: MVar [DetailedEvent] - -> MVar Int - -> Label - -> RecorderIncomingCallback - -> IO (IO Bool) -processBatch pendingRef n label incoming = do - rendererStateRef <- newMVar rendererStateNew - -- FIXME: this is stupid. If we have to manually combine the outputs, it's - -- basically just more state. - rendererResultRef <- newMVar mempty - - return $ do - pending <- takeMVar pendingRef - putMVar pendingRef [] - - when (not (null pending)) $ do - rr <- modifyMVar rendererStateRef $ \s -> do - let (rr, s') = processSome (reverse pending) [] s - return (s', rr) - - oldRR <- takeMVar rendererResultRef - let rr' = oldRR `mappend` rr - putMVar rendererResultRef rr' - - when (not (null (rrShapes rr))) $ do - -- If the renderer produced some visible output, count it as a - -- message from the user's perspective. - i <- takeMVar n - let j = i + (length pending) - labelSetMarkup label $ - (printf (__ "Logged %u messages…") j :: String) - putMVar n j - - incoming rr' - - return True - -recorderRun :: Either BusType String - -> FilePath - -> Maybe Window - -> RecorderIncomingCallback - -> RecorderFinishedCallback - -> IO () -recorderRun target filename mwindow incoming finished = C.handle newFailed $ do - -- TODO: I'm pretty sure the monitor is leaked - monitor <- monitorNew target filename - dialog <- dialogNew - - dialog `set` (map (windowTransientFor :=) (maybeToList mwindow)) - dialog `set` [ windowModal := True - , windowTitle := "" - ] - - label <- labelNew (Nothing :: Maybe String) - labelSetMarkup label $ - (printf (__ "Logged %u messages…") (0 :: Int) :: String) - loaderStateRef <- newMVar Map.empty - pendingRef <- newMVar [] - let updateLabel µs body = do - -- of course, modifyMVar and runStateT have their tuples back to front. - m <- modifyMVar loaderStateRef $ \s -> do - (m, s') <- runStateT (convert µs body) s - return (s', m) - - case m of - Left e -> warn e - Right message - | isRelevant (deEvent message) -> do - modifyMVar_ pendingRef $ \pending -> return (message:pending) - | otherwise -> return () - - n <- newMVar (0 :: Int) - processor <- processBatch pendingRef n label incoming - processorId <- timeoutAdd processor 200 - - spinner <- spinnerNew - spinnerStart spinner - - vbox <- fmap castToBox $ dialogGetContentArea dialog - hbox <- hBoxNew False 8 - boxPackStart hbox spinner PackNatural 0 - boxPackStart hbox label PackGrow 0 - boxPackStart vbox hbox PackGrow 0 - - handlerId <- monitor `on` monitorMessageLogged $ updateLabel - monitor `on` monitorStopped $ \domain code message -> do - handleError domain code message - - signalDisconnect handlerId - - spinnerStop spinner - widgetDestroy dialog - - -- Flush out any last messages from the queue. - timeoutRemove processorId - processor - - hadOutput <- liftM (/= 0) (readMVar n) - finished hadOutput - - dialogAddButton dialog "gtk-media-stop" ResponseClose - - dialog `after` response $ \_ -> do - monitorStop monitor - - widgetShowAll dialog - where - -- Filter out IoErrorCancelled. In theory one should use - -- catchGErrorJust IoErrorCancelled computation (\_ -> return ()) - -- but IOErrorEnum does not have an instance for GError domain. - newFailed (GError domain code message) = do - finished False - handleError domain code message - - handleError domain code message = do - gIoErrorQuark <- quarkFromString "g-io-error-quark" - let cancelled = fromEnum IoErrorCancelled - when (not (domain == gIoErrorQuark && code == cancelled)) $ do - displayError mwindow (toString message) Nothing - +import Control.Monad (when) +-- TODO: shouldn't be here recorderChooseFile :: FilePath -> Maybe Window -> (FilePath -> IO ()) diff --git a/Bustle/UI/Util.hs b/Bustle/UI/Util.hs deleted file mode 100644 --- a/Bustle/UI/Util.hs +++ /dev/null @@ -1,45 +0,0 @@ -{- -Bustle.UI.Util: miscellaneous clickable utility functions -Copyright © 2012 Collabora Ltd. - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 2.1 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA --} -module Bustle.UI.Util - ( - displayError - ) -where - -import Graphics.UI.Gtk - -import Bustle.Util (maybeM) - --- Displays a modal error dialog, with the given strings as title and body --- respectively. -displayError :: Maybe Window - -> String - -> Maybe String - -> IO () -displayError mwindow title mbody = do - dialog <- messageDialogNew mwindow - [DialogModal] - MessageError - ButtonsClose - title - - maybeM mbody $ messageDialogSetSecondaryText dialog - - dialog `after` response $ \_ -> widgetDestroy dialog - widgetShowAll dialog diff --git a/Bustle/Util.hs b/Bustle/Util.hs --- a/Bustle/Util.hs +++ b/Bustle/Util.hs @@ -22,20 +22,15 @@ io , warn - , maybeM - , getCacheDir -- You probably don't actually want to use this function. , traceM - - , NonEmpty(..) - , mapNonEmpty - , nonEmptyToList ) where import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad import Debug.Trace (trace) import System.IO (hPutStrLn, stderr) import Foreign.C.String @@ -45,24 +40,17 @@ -- Escape hatch to log a value from a non-IO monadic context. traceM :: (Show a, Monad m) => a -> m () -traceM x = trace (show x) $ return () +traceM = void . return . trace . show -- Log a warning which isn't worth showing to the user, but which might -- interest someone debugging the application. warn :: String -> IO () -warn = hPutStrLn stderr . ((__ "Warning: ") ++) +warn = hPutStrLn stderr . (__ "Warning: " ++) -- Shorthand for liftIO. io :: MonadIO m => IO a -> m a io = liftIO -maybeM :: Monad m - => Maybe a - -> (a -> m b) - -> m () -maybeM Nothing _ = return () -maybeM (Just x) act = act x >> return () - foreign import ccall "g_get_user_cache_dir" g_get_user_cache_dir :: IO CString @@ -72,15 +60,3 @@ let dir = dotCache "bustle" createDirectoryIfMissing True dir return dir - --- I don't want to depend on 'semigroups' for this. -data NonEmpty a = a :| [a] - deriving (Show, Eq) - -mapNonEmpty :: (a -> b) - -> NonEmpty a - -> NonEmpty b -mapNonEmpty f (x :| xs) = f x :| map f xs - -nonEmptyToList :: NonEmpty a -> [a] -nonEmptyToList (x :| xs) = x:xs diff --git a/Bustle/VariantFormatter.hs b/Bustle/VariantFormatter.hs --- a/Bustle/VariantFormatter.hs +++ b/Bustle/VariantFormatter.hs @@ -39,11 +39,14 @@ format_ByteArray :: Array -> String format_ByteArray ay = - if all (\y -> isPrint (chr (fromIntegral y))) bytes - then show (map (chr . fromIntegral) bytes :: String) + if all isPrintish chars + then 'b':show chars else format_Array ay where bytes = map (fromJust . fromVariant) (arrayItems ay) :: [Word8] + chars = map (chr . fromIntegral) bytes + isPrintish '\0' = True + isPrintish c = isPrint c format_Int16 :: Int16 -> String diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,54 @@ +Want to get involved? Great! +============================ + +Make sure you have an up-to-date Haskell toolchain. I recommend using +[Stack](https://haskellstack.org/) for development. Make sure you run +`stack update` if you install it from a distro package before continuing. + +Grab the latest code from git: + + git clone https://gitlab.freedesktop.org/bustle/bustle.git + cd bustle + +Build it: + + stack build + +Run it: + + stack exec bustle + +Test it: + + stack test + +Please file bugs and merge requests at +. + +In new code, try to follow +. +The author did not follow it in the past but it seems like a good kind of +thing to aim for. + +Releasing Bustle +================ + +* Ideally, automate the steps below +* Write news in `NEWS.md` and `data/org.freedesktop.Bustle.appdata.xml.in` +* Update `po/messages.pot` +* Update version number in `bustle.cabal` + +```sh +# Tag release, build and sign the tarballs +make maintainer-make-release + +# Stick source and binaries on freedesktop.org +mkdir x.y.z +cp dist/bustle-x.y.z* x.y.z/ +scp -r x.y.z annarchy.freedesktop.org:/srv/www.freedesktop.org/www/software/bustle/ + +# Upload source to Hackage +stack upload + +git push origin --tags master +``` diff --git a/GetText.hs b/GetText.hs --- a/GetText.hs +++ b/GetText.hs @@ -73,7 +73,7 @@ -- see https://github.com/fpco/stackage/issues/746 -- -module GetText +module GetText ( -- | /TODO:/ upstream exporting the individual hooks? installPOFiles, @@ -118,18 +118,17 @@ installGetTextHooks :: UserHooks -- ^ initial user hooks -> UserHooks -- ^ patched user hooks installGetTextHooks uh = uh{ - confHook = \a b -> - (confHook uh) a b >>= - return . updateLocalBuildInfo, + confHook = \a b -> + updateLocalBuildInfo <$> confHook uh a b, - postInst = \a b c d -> - (postInst uh) a b c d >> + postInst = \a b c d -> + postInst uh a b c d >> installPOFiles a b c d } updateLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo -updateLocalBuildInfo l = +updateLocalBuildInfo l = let sMap = getCustomFields l [domDef, catDef] = map ($ sMap) [getDomainDefine, getMsgCatalogDefine] dom = getDomainNameDefault sMap (getPackageName l) @@ -138,7 +137,7 @@ in (appendCPPOptions [domMS,catMS] . appendExtension [EnableExtension CPP]) l installPOFiles :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () -installPOFiles _ _ _ l = +installPOFiles _ _ _ l = let sMap = getCustomFields l destDir = targetDataDir l dom = getDomainNameDefault sMap (getPackageName l) @@ -148,43 +147,43 @@ let targetDir = destDir bname "LC_MESSAGES" -- ensure we have directory destDir/{loc}/LC_MESSAGES createDirectoryIfMissing True targetDir - system $ "msgfmt --output-file=" ++ - (targetDir dom <.> "mo") ++ + system $ "msgfmt --output-file=" ++ + (targetDir dom <.> "mo") ++ " " ++ file in do filelist <- getPoFilesDefault sMap -- copy all whose name is in the form of dir/{loc}.po to the -- destDir/{loc}/LC_MESSAGES/dom.mo -- with the 'msgfmt' tool - mapM_ installFile filelist + mapM_ installFile filelist forBuildInfo :: LocalBuildInfo -> (BuildInfo -> BuildInfo) -> LocalBuildInfo -forBuildInfo l f = +forBuildInfo l f = let a = l{localPkgDescr = updPkgDescr (localPkgDescr l)} - updPkgDescr x = x{library = updLibrary (library x), + updPkgDescr x = x{library = updLibrary (library x), executables = updExecs (executables x)} updLibrary Nothing = Nothing updLibrary (Just x) = Just $ x{libBuildInfo = f (libBuildInfo x)} - updExecs x = map updExec x + updExecs = map updExec updExec x = x{buildInfo = f (buildInfo x)} in a appendExtension :: [Extension] -> LocalBuildInfo -> LocalBuildInfo -appendExtension exts l = +appendExtension exts l = forBuildInfo l updBuildInfo where updBuildInfo x = x{defaultExtensions = updExts (defaultExtensions x)} updExts s = nub (s ++ exts) appendCPPOptions :: [String] -> LocalBuildInfo -> LocalBuildInfo -appendCPPOptions opts l = +appendCPPOptions opts l = forBuildInfo l updBuildInfo where updBuildInfo x = x{cppOptions = updOpts (cppOptions x)} updOpts s = nub (s ++ opts) -formatMacro name value = "-D" ++ name ++ "=" ++ (show value) +formatMacro name value = "-D" ++ name ++ "=" ++ show value targetDataDir :: LocalBuildInfo -> FilePath -targetDataDir l = +targetDataDir l = let dirTmpls = installDirTemplates l prefix' = prefix dirTmpls data' = datadir dirTmpls @@ -201,7 +200,7 @@ findInParametersDefault al name def = (fromMaybe def . lookup name) al getDomainNameDefault :: [(String, String)] -> String -> String -getDomainNameDefault al d = findInParametersDefault al "x-gettext-domain-name" d +getDomainNameDefault al = findInParametersDefault al "x-gettext-domain-name" getDomainDefine :: [(String, String)] -> String getDomainDefine al = findInParametersDefault al "x-gettext-domain-def" "__MESSAGE_CATALOG_DOMAIN__" @@ -212,8 +211,8 @@ getPoFilesDefault :: [(String, String)] -> IO [String] getPoFilesDefault al = toFileList $ findInParametersDefault al "x-gettext-po-files" "" where toFileList "" = return [] - toFileList x = liftM concat $ mapM matchFileGlob $ split' x + toFileList x = fmap concat $ mapM matchFileGlob $ split' x -- from Blow your mind (HaskellWiki) -- splits string by newline, space and comma - split' x = concatMap lines $ concatMap words $ unfoldr (\b -> fmap (const . (second $ drop 1) . break (==',') $ b) . listToMaybe $ b) x + split' x = concatMap lines $ concatMap words $ unfoldr (\b -> fmap (const . second (drop 1) . break (==',') $ b) . listToMaybe $ b) x diff --git a/HACKING.md b/HACKING.md deleted file mode 100644 --- a/HACKING.md +++ /dev/null @@ -1,37 +0,0 @@ -Want to get involved? Great! -============================ - -Grab the latest code from git: - - git clone https://gitlab.freedesktop.org/bustle/bustle.git - -and get stuck in! Please file bugs and merge requests at -. - -In new code, try to follow -. -The author did not follow it in the past but it seems like a good kind of -thing to aim for. - -Releasing Bustle -================ - -* Ideally, automate the steps below -* Write news in `NEWS.md` and `data/org.freedesktop.Bustle.appdata.xml.in` -* Update `po/messages.pot` -* Update version number in `bustle.cabal` - -```sh -# Tag release, build and sign the tarballs -make maintainer-make-release - -# Stick source and binaries on freedesktop.org -mkdir x.y.z -cp dist/bustle-x.y.z* x.y.z/ -scp -r x.y.z annarchy.freedesktop.org:/srv/www.freedesktop.org/www/software/bustle/ - -# Upload source to Hackage -cabal upload - -git push origin --tags master -``` diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -106,16 +106,12 @@ # Maintainer stuff maintainer-update-messages-pot: - find Bustle -name '*.hs' -print0 | xargs -0 hgettext -k __ -o po/messages.pot + find Bustle -name '*.hs' -print0 | xargs -0 stack exec -- hgettext -k __ -o po/messages.pot xgettext data/bustle.ui data/org.freedesktop.Bustle.desktop.in \ data/org.freedesktop.Bustle.appdata.xml.in --join-existing -o po/messages.pot maintainer-make-release: bustle.cabal dist/build/autogen/version.txt - cabal test - cabal sdist + stack sdist --test-tarball git tag -s -m 'Bustle '`cat dist/build/autogen/version.txt` \ bustle-`cat dist/build/autogen/version.txt` gpg --detach-sign --armor dist/bustle-`cat dist/build/autogen/version.txt`.tar.gz - -.travis.yml: bustle.cabal make_travis_yml.hs - ./make_travis_yml.hs $< libpcap-dev libgtk-3-dev libcairo2-dev happy-1.19.4 alex-3.1.3 > $@ diff --git a/NEWS.md b/NEWS.md --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,23 @@ +Bustle 0.7.2 (2018-07-24) +------------------------- + +User-facing changes: + +* You can now explore messages while they're being recorded. (Filtering, + statistics and exporting are still only available once you stop + recording.) +* The raw sender and destination for each message is now shown in the + details pane. +* Bytestrings with embedded NULs which are otherwise ASCII are now shown + as ASCII strings. + +Internal changes: + +* New contributor Daniel Firth set up GitLab CI, with a linter, and + provided many patches to clean up and modernize the code. +* Jan Tojnar provided a build fix for Nix (and perhaps other distros). +* GHC 8.4 is now required to build Bustle. + Bustle 0.7.1 (2018-06-15) ------------------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,9 @@ provides statistics like signal frequencies and average method call times. +[![pipeline status](https://gitlab.freedesktop.org/bustle/bustle/badges/master/pipeline.svg)](https://gitlab.freedesktop.org/bustle/bustle/commits/master) + Using Bustle ============ @@ -35,4 +37,4 @@ More information ================ -See . +See . diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -12,7 +12,7 @@ import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName -import qualified GetText as GetText +import qualified GetText main :: IO () main = defaultMainWithHooks $ installBustleHooks simpleUserHooks @@ -46,7 +46,7 @@ let pathsModulePath = autogenPackageModulesDir lbi ModuleName.toFilePath (getTextConstantsModuleName pkg) <.> "hs" - rewriteFile pathsModulePath (generateModule pkg lbi) + rewriteFileEx verbosity pathsModulePath (generateModule pkg lbi) getTextConstantsModuleName :: PackageDescription -> ModuleName getTextConstantsModuleName pkg_descr = diff --git a/Test/DumpMessages.hs b/Test/DumpMessages.hs --- a/Test/DumpMessages.hs +++ b/Test/DumpMessages.hs @@ -10,6 +10,11 @@ let file = case args of x:_ -> x _ -> error "gimme a filename" - (Right (warnings, messages)) <- readPcap file - forM_ (zip [1..] messages) $ \(i, message) -> - putStrLn $ show i ++ ": " ++ show message + r <- readPcap file + case r of + Left e -> print e + Right (warnings, messages) -> do + forM_ warnings putStrLn + putStrLn "" + -- forM_ (zip [1..] messages) $ \(i, message) -> + -- putStrLn $ show i ++ ": " ++ show message diff --git a/Test/PcapCrash.hs b/Test/PcapCrash.hs --- a/Test/PcapCrash.hs +++ b/Test/PcapCrash.hs @@ -17,5 +17,4 @@ exitFailure -- TODO: check there are no warnings (but there are because we don't -- understand 'h', so we just skip it) - Right _ -> do - return () + Right _ -> return () diff --git a/Test/Regions.hs b/Test/Regions.hs --- a/Test/Regions.hs +++ b/Test/Regions.hs @@ -4,7 +4,6 @@ import Data.List (sort, group) import Data.Maybe (isNothing, isJust) -import Control.Applicative ((<$>), (<*>)) import Bustle.Regions @@ -15,7 +14,7 @@ instance Arbitrary NonOverlappingStripes where arbitrary = do -- listOf2 - tops <- sort <$> ((:) <$> arbitrary <*> (listOf1 arbitrary)) + tops <- sort <$> ((:) <$> arbitrary <*> listOf1 arbitrary) -- Generate dense stripes sometimes let g :: Gen Double @@ -37,7 +36,7 @@ values <- vector (length stripes) `suchThat` unique return $ ValidRegions (zip stripes values) where - unique xs = all (== 1) . map length . group $ xs + unique = all (== 1) . map length . group instance (Eq a, Arbitrary a) => Arbitrary (RegionSelection a) where arbitrary = do @@ -46,8 +45,8 @@ prop_NonOverlapping_generator_works (NonOverlappingStripes ss) = nonOverlapping ss -prop_InitiallyUnselected = \rs -> isNothing $ rsCurrent rs -prop_UpDoesNothing = \rs -> isNothing $ rsCurrent $ regionSelectionUp rs +prop_InitiallyUnselected rs = isNothing $ rsCurrent rs +prop_UpDoesNothing rs = isNothing $ rsCurrent $ regionSelectionUp rs prop_DownDoesNothing vr@(ValidRegions regions) = withRegions vr $ \rs -> @@ -130,11 +129,10 @@ ] randomMutations :: Gen (RegionSelection a -> RegionSelection a) -randomMutations = do - fs <- listOf randomMutation - return $ foldr (.) id fs +randomMutations = + foldr (.) id <$> listOf randomMutation -prop_ClickAlwaysInSelection = \rs -> +prop_ClickAlwaysInSelection rs = forAll (fmap Blind randomMutations) $ \(Blind f) -> let rs' = f rs diff --git a/bustle.cabal b/bustle.cabal --- a/bustle.cabal +++ b/bustle.cabal @@ -1,10 +1,10 @@ Name: bustle Category: Network, Desktop -Version: 0.7.1 -Cabal-Version: >= 1.24 -Tested-With: GHC == 8.2.2, GHC == 8.4.3 +Version: 0.7.2 +Cabal-Version: 2.0 +Tested-With: GHC == 8.4.3 Synopsis: Draw sequence diagrams of D-Bus traffic -Description: Draw sequence diagrams of D-Bus traffic +Description: Bustle records and draws sequence diagrams of D-Bus activity, showing signal emissions, method calls and their corresponding returns, with timestamps for each individual event and the duration of each method call. This can help you check for unwanted D-Bus traffic, and pinpoint why your D-Bus-based application isn't performing as well as you like. It also provides statistics like signal frequencies and average method call times. License: OtherLicense License-file: LICENSE Author: Will Thompson @@ -25,7 +25,7 @@ -- Stuff for nerds README.md, NEWS.md, - HACKING.md, + CONTRIBUTING.md, INSTALL.md, run-uninstalled.sh , Test/data/log-with-h.bustle @@ -56,8 +56,8 @@ custom-setup setup-depends: - base >= 4 && < 5, - Cabal >= 1.24, + base >= 4.11 && < 5, + Cabal >= 2.0, filepath, directory, process @@ -102,10 +102,10 @@ , Bustle.UI.OpenTwoDialog , Bustle.UI.RecordAddressDialog , Bustle.UI.Recorder - , Bustle.UI.Util , Bustle.Util , Bustle.VariantFormatter , Paths_bustle + autogen-modules: Paths_bustle default-language: Haskell2010 Ghc-options: -Wall -fno-warn-unused-do-bind @@ -113,8 +113,9 @@ ghc-options: -threaded C-sources: c-sources/pcap-monitor.c cc-options: -fPIC -g - pkgconfig-depends: glib-2.0 >= 2.54 - Build-Depends: base >= 4 && < 5 + pkgconfig-depends: glib-2.0 >= 2.54, + gio-unix-2.0 + Build-Depends: base >= 4.11 && < 5 , bytestring , cairo , containers @@ -133,43 +134,14 @@ if flag(hgettext) Build-Depends: hgettext >= 0.1.5 , setlocale - -- Other-Modules: GetText_bustle + other-modules: GetText_bustle + autogen-modules: GetText_bustle hs-source-dirs: . , src-hgettext else hs-source-dirs: . , src-no-hgettext -Executable test-monitor - if flag(InteractiveTests) - buildable: True - else - buildable: False - - main-is: tests/Monitor.hs - other-modules: Bustle.Monitor - default-language: Haskell2010 - if flag(threaded) - Ghc-options: -threaded - C-sources: c-sources/pcap-monitor.c - cc-options: -fPIC - pkgconfig-depends: glib-2.0 - Build-Depends: base >= 4 && < 5 - , bytestring - , cairo - , containers - , dbus - , directory - , filepath - -- 0.13.6 doesn't compile with GCC 5: https://github.com/gtk2hs/gtk2hs/issues/104 - , gtk3 >= 0.13.7 - , glib - , mtl - , pango - , pcap - , text - - Executable dump-messages if flag(InteractiveTests) buildable: True @@ -186,6 +158,17 @@ , pcap , text + if flag(hgettext) + Build-Depends: hgettext >= 0.1.5 + , setlocale + other-modules: GetText_bustle + autogen-modules: GetText_bustle + hs-source-dirs: . + , src-hgettext + else + hs-source-dirs: . + , src-no-hgettext + Test-suite test-pcap-crash type: exitcode-stdio-1.0 main-is: Test/PcapCrash.hs @@ -203,7 +186,8 @@ if flag(hgettext) Build-Depends: hgettext >= 0.1.5 , setlocale - -- Other-Modules: GetText_bustle + other-modules: GetText_bustle + autogen-modules: GetText_bustle hs-source-dirs: . , src-hgettext else @@ -248,7 +232,8 @@ if flag(hgettext) Build-Depends: hgettext >= 0.1.5 , setlocale - -- Other-Modules: GetText_bustle + other-modules: GetText_bustle + autogen-modules: GetText_bustle hs-source-dirs: . , src-hgettext else diff --git a/c-sources/pcap-monitor.c b/c-sources/pcap-monitor.c --- a/c-sources/pcap-monitor.c +++ b/c-sources/pcap-monitor.c @@ -31,6 +31,9 @@ # define DLT_DBUS 231 #endif +/* Prefix of name claimed by the connection that collects name owners. */ +const char *BUSTLE_MONITOR_NAME_PREFIX = "org.freedesktop.Bustle.Monitor."; + /* * Transitions: * @@ -75,7 +78,9 @@ "STOPPED", }; -struct _BustlePcapMonitorPrivate { +typedef struct _BustlePcapMonitor { + GObject parent; + GBusType bus_type; gchar *address; BustlePcapMonitorState state; @@ -96,7 +101,7 @@ GError *pcap_error; GError *subprocess_error; guint await_both_errors_id; -}; +} BustlePcapMonitor; enum { PROP_BUS_TYPE = 1, @@ -123,11 +128,9 @@ static void bustle_pcap_monitor_init (BustlePcapMonitor *self) { - self->priv = G_TYPE_INSTANCE_GET_PRIVATE (self, BUSTLE_TYPE_PCAP_MONITOR, - BustlePcapMonitorPrivate); - self->priv->bus_type = G_BUS_TYPE_SESSION; - self->priv->state = STATE_NEW; - self->priv->cancellable = g_cancellable_new (); + self->bus_type = G_BUS_TYPE_SESSION; + self->state = STATE_NEW; + self->cancellable = g_cancellable_new (); } static void @@ -138,18 +141,17 @@ GParamSpec *pspec) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (object); - BustlePcapMonitorPrivate *priv = self->priv; switch (property_id) { case PROP_BUS_TYPE: - g_value_set_enum (value, priv->bus_type); + g_value_set_enum (value, self->bus_type); break; case PROP_ADDRESS: - g_value_set_string (value, priv->address); + g_value_set_string (value, self->address); break; case PROP_FILENAME: - g_value_set_string (value, priv->filename); + g_value_set_string (value, self->filename); break; default: G_OBJECT_WARN_INVALID_PROPERTY_ID (object, property_id, pspec); @@ -164,18 +166,17 @@ GParamSpec *pspec) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (object); - BustlePcapMonitorPrivate *priv = self->priv; switch (property_id) { case PROP_BUS_TYPE: - priv->bus_type = g_value_get_enum (value); + self->bus_type = g_value_get_enum (value); break; case PROP_ADDRESS: - priv->address = g_value_dup_string (value); + self->address = g_value_dup_string (value); break; case PROP_FILENAME: - priv->filename = g_value_dup_string (value); + self->filename = g_value_dup_string (value); break; default: G_OBJECT_WARN_INVALID_PROPERTY_ID (object, property_id, pspec); @@ -185,33 +186,30 @@ static void close_dump (BustlePcapMonitor *self) { - BustlePcapMonitorPrivate *priv = self->priv; - - if (priv->dumper != NULL) - pcap_dump_flush (priv->dumper); + if (self->dumper != NULL) + pcap_dump_flush (self->dumper); - g_clear_pointer (&priv->dumper, pcap_dump_close); - g_clear_pointer (&priv->pcap_out, pcap_close); + g_clear_pointer (&self->dumper, pcap_dump_close); + g_clear_pointer (&self->pcap_out, pcap_close); } static void bustle_pcap_monitor_dispose (GObject *object) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (object); - BustlePcapMonitorPrivate *priv = self->priv; GObjectClass *parent_class = bustle_pcap_monitor_parent_class; - if (priv->cancellable_cancelled_id != 0) + if (self->cancellable_cancelled_id != 0) { - g_assert (priv->cancellable != NULL); - g_cancellable_disconnect (priv->cancellable, priv->cancellable_cancelled_id); - priv->cancellable_cancelled_id = 0; + g_assert (self->cancellable != NULL); + g_cancellable_disconnect (self->cancellable, self->cancellable_cancelled_id); + self->cancellable_cancelled_id = 0; } - g_clear_object (&priv->cancellable); - g_clear_pointer (&priv->dbus_monitor_source, g_source_destroy); - g_clear_pointer (&priv->pcap_in, pcap_close); - g_clear_object (&priv->dbus_monitor); + g_clear_object (&self->cancellable); + g_clear_pointer (&self->dbus_monitor_source, g_source_destroy); + g_clear_pointer (&self->pcap_in, pcap_close); + g_clear_object (&self->dbus_monitor); close_dump (self); @@ -223,13 +221,12 @@ bustle_pcap_monitor_finalize (GObject *object) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (object); - BustlePcapMonitorPrivate *priv = self->priv; GObjectClass *parent_class = bustle_pcap_monitor_parent_class; - g_clear_pointer (&priv->address, g_free); - g_clear_pointer (&priv->filename, g_free); - g_clear_error (&priv->pcap_error); - g_clear_error (&priv->subprocess_error); + g_clear_pointer (&self->address, g_free); + g_clear_pointer (&self->filename, g_free); + g_clear_error (&self->pcap_error); + g_clear_error (&self->subprocess_error); if (parent_class->finalize != NULL) parent_class->finalize (object); @@ -246,8 +243,6 @@ object_class->dispose = bustle_pcap_monitor_dispose; object_class->finalize = bustle_pcap_monitor_finalize; - g_type_class_add_private (klass, sizeof (BustlePcapMonitorPrivate)); - #define THRICE(x) x, x, x param_spec = g_param_spec_enum ( @@ -312,45 +307,44 @@ static void handle_error (BustlePcapMonitor *self) { - BustlePcapMonitorPrivate *priv = self->priv; g_autoptr(GError) error = NULL; - g_return_if_fail (priv->pcap_error != NULL || - priv->subprocess_error != NULL); + g_return_if_fail (self->pcap_error != NULL || + self->subprocess_error != NULL); - if (priv->pcap_error != NULL) - g_debug ("%s: pcap_error: %s", G_STRFUNC, priv->pcap_error->message); + if (self->pcap_error != NULL) + g_debug ("%s: pcap_error: %s", G_STRFUNC, self->pcap_error->message); - if (priv->subprocess_error != NULL) + if (self->subprocess_error != NULL) g_debug ("%s: subprocess_error: %s", G_STRFUNC, - priv->subprocess_error->message); + self->subprocess_error->message); - if (priv->state == STATE_STOPPED) + if (self->state == STATE_STOPPED) { g_debug ("%s: already stopped", G_STRFUNC); return; } /* Check for pkexec errors. Signal these in preference to all others. */ - if (priv->subprocess_error != NULL && - priv->bus_type == G_BUS_TYPE_SYSTEM) + if (self->subprocess_error != NULL && + self->bus_type == G_BUS_TYPE_SYSTEM) { - if (g_error_matches (priv->subprocess_error, G_SPAWN_EXIT_ERROR, 126)) + if (g_error_matches (self->subprocess_error, G_SPAWN_EXIT_ERROR, 126)) { /* dialog dismissed */ g_set_error (&error, G_IO_ERROR, G_IO_ERROR_CANCELLED, "User dismissed polkit authorization dialog"); } - else if (g_error_matches (priv->subprocess_error, G_SPAWN_EXIT_ERROR, 127)) + else if (g_error_matches (self->subprocess_error, G_SPAWN_EXIT_ERROR, 127)) { /* not authorized, authorization couldn't be obtained through - * authentication, or an priv->subprocess_error occurred */ + * authentication, or an self->subprocess_error occurred */ g_set_error (&error, G_IO_ERROR, G_IO_ERROR_PERMISSION_DENIED, "Not authorized to monitor system bus"); } } - if (g_error_matches (priv->subprocess_error, G_SPAWN_EXIT_ERROR, 0)) + if (g_error_matches (self->subprocess_error, G_SPAWN_EXIT_ERROR, 0)) { /* I believe clean exit only happens if the bus is shut down. This might * happen if you're using Bustle to monitor a test suite, or perhaps a @@ -358,7 +352,7 @@ * cancellation. */ g_set_error_literal (&error, G_IO_ERROR, G_IO_ERROR_CANCELLED, - priv->subprocess_error->message); + self->subprocess_error->message); } if (error == NULL) @@ -366,21 +360,21 @@ /* If no pkexec errors, prefer potentially more informative errors from * libpcap, including the wonderful snaplen bug. */ - if (priv->pcap_error != NULL) + if (self->pcap_error != NULL) { - error = g_steal_pointer (&priv->pcap_error); + error = g_steal_pointer (&self->pcap_error); } /* Otherwise, the "subprocess didn't work" error will have to do. */ else { - error = g_steal_pointer (&priv->subprocess_error); + error = g_steal_pointer (&self->subprocess_error); - if (priv->state == STATE_STARTING) + if (self->state == STATE_STARTING) g_prefix_error (&error, "Failed to start dbus-monitor: "); } } - priv->state = STATE_STOPPED; + self->state = STATE_STOPPED; close_dump (self); g_debug ("%s: emitting ::stopped(%s, %d, %s)", G_STRFUNC, @@ -388,18 +382,17 @@ g_signal_emit (self, signals[SIG_STOPPED], 0, (guint) error->domain, error->code, error->message); - g_clear_handle_id (&priv->await_both_errors_id, g_source_remove); + g_clear_handle_id (&self->await_both_errors_id, g_source_remove); } static gboolean await_both_errors_cb (gpointer data) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (data); - BustlePcapMonitorPrivate *priv = self->priv; handle_error (self); - priv->await_both_errors_id = 0; + self->await_both_errors_id = 0; return G_SOURCE_REMOVE; } @@ -412,14 +405,12 @@ static void await_both_errors (BustlePcapMonitor *self) { - BustlePcapMonitorPrivate *priv = self->priv; - - if (priv->state == STATE_STOPPED) + if (self->state == STATE_STOPPED) return; - else if (priv->subprocess_error != NULL && priv->pcap_error != NULL) + else if (self->subprocess_error != NULL && self->pcap_error != NULL) handle_error (self); - else if (priv->await_both_errors_id == 0) - priv->await_both_errors_id = + else if (self->await_both_errors_id == 0) + self->await_both_errors_id = g_timeout_add_seconds_full (G_PRIORITY_DEFAULT, 2, await_both_errors_cb, g_object_ref (self), g_object_unref); } @@ -476,17 +467,16 @@ GCancellable *cancellable, GError **error) { - BustlePcapMonitorPrivate *priv = self->priv; g_autofree gchar *address_to_free = NULL; - const gchar *address = priv->address; + const gchar *address = self->address; - if (priv->address != NULL) + if (self->address != NULL) { - address = priv->address; + address = self->address; } else { - address_to_free = g_dbus_address_get_for_bus_sync (priv->bus_type, + address_to_free = g_dbus_address_get_for_bus_sync (self->bus_type, cancellable, error); if (address_to_free == NULL) { @@ -521,9 +511,39 @@ connection = get_connection (self, cancellable, &error); if (connection != NULL) { + const gchar *unique_name = g_dbus_connection_get_unique_name (connection); + + if (unique_name != NULL) + { + g_autofree gchar *mangled = g_strdup (unique_name); + g_autofree gchar *well_known_name = + g_strconcat (BUSTLE_MONITOR_NAME_PREFIX, + /* ":3.14" -> "_3_14", a legal bus name component */ + g_strcanon (mangled, "0123456789", '_'), + NULL); + + g_debug ("%s: attempting to own %s", G_STRFUNC, well_known_name); + /* Ignore returned ID: we'll own it until we disconnect. + * + * Also ignore callbacks: we don't need to be notified, since this + * name is just for the benefit of the viewer. On the system bus we + * won't be able to own this name, but if we're smart we can teach + * the viewer that merely requesting the name is enough to hide this + * connection. + */ + g_bus_own_name_on_connection (connection, + well_known_name, + G_BUS_NAME_OWNER_FLAGS_NONE, + NULL /* acquired */, + NULL /* lost */, + NULL /* user_data */, + NULL /* free_func */); + } + bus = g_dbus_proxy_new_sync (connection, G_DBUS_PROXY_FLAGS_DO_NOT_LOAD_PROPERTIES | - G_DBUS_PROXY_FLAGS_DO_NOT_CONNECT_SIGNALS, + G_DBUS_PROXY_FLAGS_DO_NOT_CONNECT_SIGNALS | + G_DBUS_PROXY_FLAGS_DO_NOT_AUTO_START, NULL, "org.freedesktop.DBus", "/org/freedesktop/DBus", @@ -559,8 +579,7 @@ dump_names_async ( BustlePcapMonitor *self) { - BustlePcapMonitorPrivate *priv = self->priv; - g_autoptr(GTask) task = g_task_new (self, priv->cancellable, dump_names_cb, NULL); + g_autoptr(GTask) task = g_task_new (self, self->cancellable, dump_names_cb, NULL); g_task_run_in_thread (task, dump_names_thread_func); } @@ -570,13 +589,12 @@ BustlePcapMonitor *self, GError **error) { - BustlePcapMonitorPrivate *priv = self->priv; GInputStream *stdout_pipe = NULL; gint stdout_fd = -1; FILE *dbus_monitor_filep = NULL; char errbuf[PCAP_ERRBUF_SIZE] = {0}; - stdout_pipe = g_subprocess_get_stdout_pipe (priv->dbus_monitor); + stdout_pipe = g_subprocess_get_stdout_pipe (self->dbus_monitor); g_return_val_if_fail (stdout_pipe != NULL, FALSE); stdout_fd = g_unix_input_stream_get_fd (G_UNIX_INPUT_STREAM (stdout_pipe)); @@ -595,8 +613,8 @@ * fread(). It's safe to do this on the main thread, since we know the pipe * is readable. On short read, pcap_fopen_offline() fails immediately. */ - priv->pcap_in = pcap_fopen_offline (dbus_monitor_filep, errbuf); - if (priv->pcap_in == NULL) + self->pcap_in = pcap_fopen_offline (dbus_monitor_filep, errbuf); + if (self->pcap_in == NULL) { g_set_error (error, G_IO_ERROR, G_IO_ERROR_FAILED, "Couldn't read messages from dbus-monitor: %s", @@ -608,7 +626,7 @@ /* And try to terminate it immediately. When spawning via pkexec we may * not be able to kill it. */ - g_subprocess_force_exit (priv->dbus_monitor); + g_subprocess_force_exit (self->dbus_monitor); return FALSE; } @@ -616,7 +634,7 @@ /* pcap_close() will call fclose() on the FILE * passed to * pcap_fopen_offline() */ dump_names_async (self); - priv->state = STATE_RUNNING; + self->state = STATE_RUNNING; return TRUE; } @@ -625,12 +643,11 @@ BustlePcapMonitor *self, GError **error) { - BustlePcapMonitorPrivate *priv = self->priv; struct pcap_pkthdr *hdr; const guchar *blob; int ret; - ret = pcap_next_ex (priv->pcap_in, &hdr, &blob); + ret = pcap_next_ex (self->pcap_in, &hdr, &blob); switch (ret) { case 1: @@ -641,7 +658,7 @@ * argument to pcap_loop() * TODO don't block */ - pcap_dump ((u_char *) priv->dumper, hdr, blob); + pcap_dump ((u_char *) self->dumper, hdr, blob); return TRUE; case -2: @@ -653,7 +670,7 @@ default: g_set_error (error, G_IO_ERROR, G_IO_ERROR_FAILED, "Error %i reading dbus-monitor stream: %s", - ret, pcap_geterr (priv->pcap_in)); + ret, pcap_geterr (self->pcap_in)); return FALSE; } } @@ -667,18 +684,17 @@ gpointer user_data) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (user_data); - BustlePcapMonitorPrivate *priv = self->priv; gboolean (*read_func) (BustlePcapMonitor *, GError **); - g_return_val_if_fail (priv->pcap_error == NULL, FALSE); + g_return_val_if_fail (self->pcap_error == NULL, FALSE); - if (g_cancellable_set_error_if_cancelled (priv->cancellable, &priv->pcap_error)) + if (g_cancellable_set_error_if_cancelled (self->cancellable, &self->pcap_error)) { await_both_errors (self); return FALSE; } - switch (priv->state) + switch (self->state) { case STATE_STARTING: read_func = start_pcap; @@ -691,11 +707,11 @@ default: g_critical ("%s in unexpected state %d (%s)", - G_STRFUNC, priv->state, STATES[priv->state]); + G_STRFUNC, self->state, STATES[self->state]); return FALSE; } - if (!read_func (self, &priv->pcap_error)) + if (!read_func (self, &self->pcap_error)) { await_both_errors (self); return FALSE; @@ -711,15 +727,14 @@ gpointer user_data) { g_autoptr(BustlePcapMonitor) self = BUSTLE_PCAP_MONITOR (user_data); - BustlePcapMonitorPrivate *priv = self->priv; GSubprocess *dbus_monitor = G_SUBPROCESS (source); - g_return_if_fail (priv->subprocess_error == NULL); + g_return_if_fail (self->subprocess_error == NULL); if (g_subprocess_wait_check_finish (dbus_monitor, result, - &priv->subprocess_error)) + &self->subprocess_error)) { - g_set_error (&priv->subprocess_error, + g_set_error (&self->subprocess_error, G_SPAWN_EXIT_ERROR, 0, "dbus-monitor exited cleanly"); } @@ -748,19 +763,18 @@ gpointer user_data) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (user_data); - BustlePcapMonitorPrivate *priv = self->priv; /* Closes the stream; should cause dbus-monitor to quit in due course when it * tries to write to the other end of the pipe. */ - g_clear_pointer (&priv->pcap_in, pcap_close); + g_clear_pointer (&self->pcap_in, pcap_close); - if (priv->dbus_monitor != NULL) + if (self->dbus_monitor != NULL) { /* Try to make it stop sooner; this has no effect on a privileged * dbus-monitor. */ - g_subprocess_force_exit (priv->dbus_monitor); + g_subprocess_force_exit (self->dbus_monitor); } } @@ -771,7 +785,6 @@ GError **error) { BustlePcapMonitor *self = BUSTLE_PCAP_MONITOR (initable); - BustlePcapMonitorPrivate *priv = self->priv; gboolean in_flatpak = g_file_test ("/.flatpak-info", G_FILE_TEST_EXISTS); g_autoptr(GPtrArray) dbus_monitor_argv = g_ptr_array_sized_new (8); GInputStream *stdout_pipe = NULL; @@ -782,28 +795,28 @@ g_ptr_array_add (dbus_monitor_argv, "--host"); } - if (priv->bus_type == G_BUS_TYPE_SYSTEM) + if (self->bus_type == G_BUS_TYPE_SYSTEM) g_ptr_array_add (dbus_monitor_argv, "pkexec"); g_ptr_array_add (dbus_monitor_argv, "dbus-monitor"); g_ptr_array_add (dbus_monitor_argv, "--pcap"); - switch (priv->bus_type) + switch (self->bus_type) { case G_BUS_TYPE_SESSION: - g_return_val_if_fail (priv->address == NULL, FALSE); + g_return_val_if_fail (self->address == NULL, FALSE); g_ptr_array_add (dbus_monitor_argv, "--session"); break; case G_BUS_TYPE_SYSTEM: - g_return_val_if_fail (priv->address == NULL, FALSE); + g_return_val_if_fail (self->address == NULL, FALSE); g_ptr_array_add (dbus_monitor_argv, "--system"); break; case G_BUS_TYPE_NONE: - g_return_val_if_fail (priv->address != NULL, FALSE); + g_return_val_if_fail (self->address != NULL, FALSE); g_ptr_array_add (dbus_monitor_argv, "--address"); - g_ptr_array_add (dbus_monitor_argv, priv->address); + g_ptr_array_add (dbus_monitor_argv, self->address); break; default: @@ -814,59 +827,59 @@ g_ptr_array_add (dbus_monitor_argv, NULL); - if (priv->filename == NULL) + if (self->filename == NULL) { g_set_error (error, G_IO_ERROR, G_IO_ERROR_INVALID_ARGUMENT, "You must specify a filename"); return FALSE; } - priv->cancellable_cancelled_id = - g_cancellable_connect (priv->cancellable, + self->cancellable_cancelled_id = + g_cancellable_connect (self->cancellable, G_CALLBACK (cancellable_cancelled_cb), self, NULL); - priv->pcap_out = pcap_open_dead (DLT_DBUS, 1 << 27); - if (priv->pcap_out == NULL) + self->pcap_out = pcap_open_dead (DLT_DBUS, 1 << 27); + if (self->pcap_out == NULL) { g_set_error (error, G_IO_ERROR, G_IO_ERROR_FAILED, "pcap_open_dead failed. wtf"); return FALSE; } - priv->dumper = pcap_dump_open (priv->pcap_out, priv->filename); - if (priv->dumper == NULL) + self->dumper = pcap_dump_open (self->pcap_out, self->filename); + if (self->dumper == NULL) { g_set_error (error, G_IO_ERROR, G_IO_ERROR_FAILED, - "Couldn't open target file %s", pcap_geterr (priv->pcap_out)); + "Couldn't open target file %s", pcap_geterr (self->pcap_out)); return FALSE; } - priv->dbus_monitor = g_subprocess_newv ( + self->dbus_monitor = g_subprocess_newv ( (const gchar * const *) dbus_monitor_argv->pdata, G_SUBPROCESS_FLAGS_STDOUT_PIPE, error); - if (priv->dbus_monitor == NULL) + if (self->dbus_monitor == NULL) { return FALSE; } - stdout_pipe = g_subprocess_get_stdout_pipe (priv->dbus_monitor); + stdout_pipe = g_subprocess_get_stdout_pipe (self->dbus_monitor); g_return_val_if_fail (stdout_pipe != NULL, FALSE); g_return_val_if_fail (G_IS_POLLABLE_INPUT_STREAM (stdout_pipe), FALSE); g_return_val_if_fail (G_IS_UNIX_INPUT_STREAM (stdout_pipe), FALSE); - priv->dbus_monitor_source = g_pollable_input_stream_create_source ( - G_POLLABLE_INPUT_STREAM (stdout_pipe), priv->cancellable); - g_source_set_callback (priv->dbus_monitor_source, + self->dbus_monitor_source = g_pollable_input_stream_create_source ( + G_POLLABLE_INPUT_STREAM (stdout_pipe), self->cancellable); + g_source_set_callback (self->dbus_monitor_source, (GSourceFunc) dbus_monitor_readable, self, NULL); - g_source_attach (priv->dbus_monitor_source, NULL); + g_source_attach (self->dbus_monitor_source, NULL); g_subprocess_wait_check_async ( - priv->dbus_monitor, - priv->cancellable, + self->dbus_monitor, + self->cancellable, wait_check_cb, g_object_ref (self)); - priv->state = STATE_STARTING; + self->state = STATE_STARTING; return TRUE; } @@ -876,18 +889,16 @@ bustle_pcap_monitor_stop ( BustlePcapMonitor *self) { - BustlePcapMonitorPrivate *priv = self->priv; - - if (priv->state == STATE_STOPPED || - priv->state == STATE_STOPPING || - priv->state == STATE_NEW) + if (self->state == STATE_STOPPED || + self->state == STATE_STOPPING || + self->state == STATE_NEW) { - g_debug ("%s: already in state %s", G_STRFUNC, STATES[priv->state]); + g_debug ("%s: already in state %s", G_STRFUNC, STATES[self->state]); return; } - priv->state = STATE_STOPPING; - g_cancellable_cancel (priv->cancellable); + self->state = STATE_STOPPING; + g_cancellable_cancel (self->cancellable); } static void diff --git a/c-sources/pcap-monitor.h b/c-sources/pcap-monitor.h --- a/c-sources/pcap-monitor.h +++ b/c-sources/pcap-monitor.h @@ -18,27 +18,13 @@ * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA */ -#ifndef BUSTLE_PCAP_MONITOR_H -#define BUSTLE_PCAP_MONITOR_H +#pragma once #include #include -typedef struct _BustlePcapMonitor BustlePcapMonitor; -typedef struct _BustlePcapMonitorClass BustlePcapMonitorClass; -typedef struct _BustlePcapMonitorPrivate BustlePcapMonitorPrivate; - -struct _BustlePcapMonitorClass { - GObjectClass parent_class; -}; - -struct _BustlePcapMonitor { - GObject parent; - - BustlePcapMonitorPrivate *priv; -}; - -GType bustle_pcap_monitor_get_type (void); +#define BUSTLE_TYPE_PCAP_MONITOR bustle_pcap_monitor_get_type () +G_DECLARE_FINAL_TYPE (BustlePcapMonitor, bustle_pcap_monitor, BUSTLE, PCAP_MONITOR, GObject) BustlePcapMonitor *bustle_pcap_monitor_new ( GBusType bus_type, @@ -48,22 +34,4 @@ void bustle_pcap_monitor_stop ( BustlePcapMonitor *self); -/* TYPE MACROS */ -#define BUSTLE_TYPE_PCAP_MONITOR \ - (bustle_pcap_monitor_get_type ()) -#define BUSTLE_PCAP_MONITOR(obj) \ - (G_TYPE_CHECK_INSTANCE_CAST((obj), BUSTLE_TYPE_PCAP_MONITOR, BustlePcapMonitor)) -#define BUSTLE_PCAP_MONITOR_CLASS(klass) \ - (G_TYPE_CHECK_CLASS_CAST((klass), BUSTLE_TYPE_PCAP_MONITOR,\ - BustlePcapMonitorClass)) -#define BUSTLE_IS_PCAP_MONITOR(obj) \ - (G_TYPE_CHECK_INSTANCE_TYPE((obj), BUSTLE_TYPE_PCAP_MONITOR)) -#define BUSTLE_IS_PCAP_MONITOR_CLASS(klass) \ - (G_TYPE_CHECK_CLASS_TYPE((klass), BUSTLE_TYPE_PCAP_MONITOR)) -#define BUSTLE_PCAP_MONITOR_GET_CLASS(obj) \ - (G_TYPE_INSTANCE_GET_CLASS ((obj), BUSTLE_TYPE_PCAP_MONITOR, \ - BustlePcapMonitorClass)) - -G_DEFINE_AUTOPTR_CLEANUP_FUNC (BustlePcapMonitor, g_object_unref) - -#endif /* BUSTLE_PCAP_MONITOR_H */ +extern const char *BUSTLE_MONITOR_NAME_PREFIX; diff --git a/data/bustle.ui b/data/bustle.ui --- a/data/bustle.ui +++ b/data/bustle.ui @@ -130,8 +130,10 @@ True + 100 True True + True True Record a new log recordMenu @@ -176,6 +178,21 @@ + + _Stop + 100 + True + True + True + + + + 1 + + + True False @@ -195,9 +212,72 @@ - 1 + -1 + + + True + False + 6 + + + True + False + + + False + True + 0 + + + + + True + False + vertical + + + True + False + end + 5 + True + + + + False + True + 0 + + + + + True + False + end + True + + + + False + True + 1 + + + + + True + True + 1 + + + + True @@ -252,6 +332,7 @@ False False Save + True @@ -283,6 +364,102 @@ False vertical + + False + error + True + + + False + 6 + end + + + + + + + + + + + + False + False + 0 + + + + + False + 16 + + + errorBarTitle + True + False + vertical + 6 + + + True + True + start + <b>Oh no</b> + True + True + True + + + False + True + 0 + + + + + True + True + start + <small>very sad</small> + True + True + True + + + False + True + 1 + + + + + True + True + 0 + + + + + + + + + + + False + False + 0 + + + + + False + True + 0 + + + True True @@ -484,7 +661,7 @@ 0 - 1 + 3 @@ -500,7 +677,7 @@ 1 - 1 + 3 @@ -516,7 +693,7 @@ 0 - 2 + 4 @@ -532,7 +709,7 @@ 1 - 2 + 4 @@ -549,7 +726,7 @@ 0 - 3 + 5 @@ -570,7 +747,7 @@ 1 - 3 + 5 @@ -645,6 +822,70 @@ 1 0 + + + + + True + False + False + Sender + 1 + + + + 0 + 1 + + + + + True + False + False + Destination + 1 + + + + 0 + 2 + + + + + detailsPath + True + False + True + org.example.Thingy + True + start + 0 + + + 1 + 1 + + + + + detailsPath + True + False + True + com.example.Placeholder + True + start + 0 + + + 1 + 2 diff --git a/data/org.freedesktop.Bustle.appdata.xml.in b/data/org.freedesktop.Bustle.appdata.xml.in --- a/data/org.freedesktop.Bustle.appdata.xml.in +++ b/data/org.freedesktop.Bustle.appdata.xml.in @@ -38,6 +38,13 @@ bustle.desktop + + +

You can now explore messages while they're being recorded. (Filtering, statistics and exporting are still only available once you stop recording.)

+

The raw sender and destination for each message is now shown in the details pane.

+

Bytestrings with embedded NULs which are otherwise ASCII are now shown as ASCII strings.

+ +

It's now possible to monitor the system bus (from the user interface and with the bustle-pcap command-line tool), with no need to reconfigure the system bus. It's also possible to monitor an arbitrary bus by address.

diff --git a/po/messages.pot b/po/messages.pot --- a/po/messages.pot +++ b/po/messages.pot @@ -8,7 +8,7 @@ msgstr "" "Project-Id-Version: PACKAGE VERSION\n" "Report-Msgid-Bugs-To: \n" -"POT-Creation-Date: 2018-06-15 09:25+0100\n" +"POT-Creation-Date: 2018-07-24 22:05+0100\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -17,7 +17,7 @@ "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" -#: Bustle/StatisticsPane.hs:191 Bustle/StatisticsPane.hs:194 +#: Bustle/StatisticsPane.hs:189 Bustle/StatisticsPane.hs:192 msgid "%.1f ms" msgstr "" @@ -31,83 +31,83 @@ msgid "Bustle" msgstr "" -#: Bustle/StatisticsPane.hs:192 +#: Bustle/StatisticsPane.hs:190 msgid "Calls" msgstr "" -#: Bustle/UI.hs:317 +#: Bustle/UI.hs:456 msgid "Close _Without Saving" msgstr "" -#: Bustle/UI.hs:210 +#: Bustle/UI.hs:226 msgid "Could not read '%s'" msgstr "" +#: Bustle/UI.hs:763 +msgid "Couldn't export log as PDF: " +msgstr "" + #: Bustle/Noninteractive.hs:48 msgid "Couldn't parse '%s': %s" msgstr "" -#: Bustle/UI.hs:282 -msgid "Couldn't save log" +#: Bustle/UI.hs:431 +msgid "Couldn't save log: " msgstr "" -#: Bustle/StatisticsPane.hs:224 data/bustle.ui:610 +#: Bustle/StatisticsPane.hs:222 data/bustle.ui:787 msgid "Error" msgstr "" -#: Bustle/UI.hs:285 -msgid "" -"Error: %s\n" -"\n" -"You might want to manually recover the log from the temporary file at\n" -"%s" -msgstr "" - -#: Bustle/StatisticsPane.hs:152 +#: Bustle/StatisticsPane.hs:150 msgid "Frequency" msgstr "" -#: Bustle/UI.hs:316 +#: Bustle/UI.hs:455 msgid "If you don't save, this log will be lost forever." msgstr "" -#: Bustle/StatisticsPane.hs:231 +#: Bustle/StatisticsPane.hs:229 msgid "Largest" msgstr "" -#: Bustle/UI/Recorder.hs:86 Bustle/UI/Recorder.hs:111 -msgid "Logged %u messages…" +#: Bustle/UI.hs:239 +msgid "Logged %u messages" msgstr "" -#: Bustle/StatisticsPane.hs:193 Bustle/StatisticsPane.hs:230 +#: Bustle/StatisticsPane.hs:191 Bustle/StatisticsPane.hs:228 msgid "Mean" msgstr "" -#: Bustle/StatisticsPane.hs:137 Bustle/StatisticsPane.hs:215 data/bustle.ui:511 +#: Bustle/StatisticsPane.hs:135 Bustle/StatisticsPane.hs:213 data/bustle.ui:688 msgid "Member" msgstr "" -#: Bustle/StatisticsPane.hs:144 Bustle/StatisticsPane.hs:181 +#: Bustle/StatisticsPane.hs:142 Bustle/StatisticsPane.hs:179 msgid "Method" msgstr "" -#: Bustle/StatisticsPane.hs:222 data/bustle.ui:585 +#: Bustle/StatisticsPane.hs:220 data/bustle.ui:762 msgid "Method call" msgstr "" -#: Bustle/StatisticsPane.hs:223 data/bustle.ui:597 +#: Bustle/StatisticsPane.hs:221 data/bustle.ui:774 msgid "Method return" msgstr "" -#: Bustle/UI.hs:309 +#: Bustle/UI.hs:348 +msgid "Recording %s…" +msgstr "" + +#: Bustle/UI.hs:448 msgid "Save log '%s' before closing?" msgstr "" -#: Bustle/StatisticsPane.hs:145 Bustle/StatisticsPane.hs:225 data/bustle.ui:623 +#: Bustle/StatisticsPane.hs:143 Bustle/StatisticsPane.hs:223 data/bustle.ui:800 msgid "Signal" msgstr "" -#: Bustle/StatisticsPane.hs:229 +#: Bustle/StatisticsPane.hs:227 msgid "Smallest" msgstr "" @@ -115,7 +115,7 @@ msgid "Someone's favourite D-Bus profiler" msgstr "" -#: Bustle/StatisticsPane.hs:190 +#: Bustle/StatisticsPane.hs:188 msgid "Total" msgstr "" @@ -126,10 +126,15 @@ "corresponding returns, and all signals it emits will be hidden." msgstr "" -#: Bustle/Util.hs:53 +#: Bustle/Util.hs:48 msgid "Warning: " msgstr "" +#: Bustle/UI.hs:433 +msgid "" +"You might want to manually recover the log from the temporary file at \"%s\"." +msgstr "" + #: Bustle/Loader/Pcap.hs:276 msgid "" "libpcap 1.8.0 and 1.8.1 are incompatible with Bustle. See https://bugs." @@ -169,66 +174,86 @@ msgid "Record _Address…" msgstr "" -#: data/bustle.ui:136 +#: data/bustle.ui:138 msgid "Record a new log" msgstr "" -#: data/bustle.ui:147 +#: data/bustle.ui:149 msgid "_Record" msgstr "" -#: data/bustle.ui:183 +#: data/bustle.ui:182 +msgid "_Stop" +msgstr "" + +#: data/bustle.ui:200 msgid "Open an existing log" msgstr "" -#: data/bustle.ui:230 +#: data/bustle.ui:310 msgid "Export as PDF" msgstr "" -#: data/bustle.ui:254 +#: data/bustle.ui:334 msgid "Save" msgstr "" -#: data/bustle.ui:316 +#: data/bustle.ui:408 +msgid "Oh no" +msgstr "" + +#: data/bustle.ui:424 +msgid "very sad" +msgstr "" + +#: data/bustle.ui:493 msgid "" "Start recording D-Bus activity with the Record button above\n" " You can also run dbus-monitor --pcap from the command line" msgstr "" -#: data/bustle.ui:335 +#: data/bustle.ui:512 msgid "Welcome to Bustle" msgstr "" -#: data/bustle.ui:360 +#: data/bustle.ui:537 msgid "Waiting for D-Bus traffic; please hold…" msgstr "" -#: data/bustle.ui:387 +#: data/bustle.ui:564 msgid "Frequencies" msgstr "" -#: data/bustle.ui:401 +#: data/bustle.ui:578 msgid "Durations" msgstr "" -#: data/bustle.ui:416 +#: data/bustle.ui:593 msgid "Sizes" msgstr "" -#: data/bustle.ui:463 +#: data/bustle.ui:640 msgid "Type" msgstr "" -#: data/bustle.ui:479 +#: data/bustle.ui:656 msgid "Path" msgstr "" -#: data/bustle.ui:543 +#: data/bustle.ui:720 msgid "Arguments" msgstr "" -#: data/bustle.ui:636 +#: data/bustle.ui:813 msgid "Directed signal" +msgstr "" + +#: data/bustle.ui:832 +msgid "Sender" +msgstr "" + +#: data/bustle.ui:848 +msgid "Destination" msgstr "" #: data/org.freedesktop.Bustle.desktop.in:4 diff --git a/tests/Monitor.hs b/tests/Monitor.hs deleted file mode 100644 --- a/tests/Monitor.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module Main where - -import Bustle.UI.Recorder - -import Graphics.UI.Gtk -import System.Glib.GError -import Control.Concurrent.MVar - -main = do - args <- initGUI - let filename = case args of - x:xs -> x - _ -> error "gimme a filename" - recorderRun filename Nothing (\_ -> return ()) (\_ -> mainQuit) - mainGUI