bustle 0.4.8 → 0.5.0
raw patch · 20 files changed
+532/−412 lines, 20 filesdep +giodep +gtk3dep −gtk
Dependencies added: gio, gtk3
Dependencies removed: gtk
Files
- Bustle/Application/Monad.hs +2/−1
- Bustle/Gtk.hs +54/−0
- Bustle/Loader.hs +2/−4
- Bustle/Loader/OldSkool.hs +2/−10
- Bustle/Noninteractive.hs +2/−2
- Bustle/Renderer.hs +1/−1
- Bustle/UI.hs +86/−62
- Bustle/UI/AboutDialog.hs +4/−4
- Bustle/UI/Canvas.hs +16/−19
- Bustle/UI/FilterDialog.hs +22/−5
- Bustle/UI/OpenTwoDialog.hs +10/−7
- Bustle/UI/Recorder.hs +16/−10
- Bustle/UI/Util.hs +1/−1
- Bustle/VariantFormatter.hs +2/−0
- Makefile +2/−2
- NEWS.md +9/−0
- Test/Regions.hs +3/−0
- bustle.cabal +8/−4
- data/OpenTwoDialog.ui +133/−0
- data/bustle.ui +157/−280
Bustle/Application/Monad.hs view
@@ -31,6 +31,7 @@ ) where +import Control.Applicative import Control.Monad.Reader import Control.Monad.State @@ -55,7 +56,7 @@ - embedIO $ onDance x . makeCallback dancedCB -} newtype Bustle config state a = B (ReaderT (BustleEnv config state) IO a)- deriving (Functor, Monad, MonadIO)+ deriving (Functor, Applicative, Monad, MonadIO) newtype BustleEnv config state = BustleEnv { unBustleEnv :: (config, IORef state) }
+ Bustle/Gtk.hs view
@@ -0,0 +1,54 @@+{-+Bustle.Gtk: Stuff missing from the Gtk binding+Copyright © 2015 Will Thompson++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+-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Bustle.Gtk+ ( b_windowSetTitlebar+ , b_headerBarSetSubtitle+ )+where++import Foreign.Ptr+import Foreign.ForeignPtr++import qualified System.Glib.GObject as GO+import System.Glib.Properties (objectSetPropertyMaybeString)+import Graphics.UI.Gtk+++foreign import ccall "gtk_window_set_titlebar"+ gtk_window_set_titlebar :: Ptr GObject+ -> Ptr GObject+ -> IO ()+++b_windowSetTitlebar :: (WindowClass window,+ WidgetClass widget)+ => window+ -> widget+ -> IO ()+b_windowSetTitlebar window titlebar =+ withForeignPtr (GO.unGObject (GO.toGObject window)) $ \pWindow ->+ withForeignPtr (GO.unGObject (GO.toGObject titlebar)) $ \pTitlebar ->+ gtk_window_set_titlebar pWindow pTitlebar++b_headerBarSetSubtitle :: WidgetClass headerBar -- BZZT+ => headerBar+ -> Maybe String+ -> IO ()+b_headerBarSetSubtitle = objectSetPropertyMaybeString "subtitle"
Bustle/Loader.hs view
@@ -26,7 +26,7 @@ where import Control.Exception-import Control.Monad.Error+import Control.Monad.Except import Control.Arrow ((***)) import Text.Printf@@ -39,15 +39,13 @@ import Bustle.Util (io) data LoadError = LoadError FilePath String-instance Error LoadError where- strMsg = LoadError "" -- this nested case stuff is ugly, but it's less ugly than it looked with -- combinators to turn IO (Either a b) into ErrorT LoadError IO b using various -- a -> LoadError functions. readLog :: MonadIO io => FilePath- -> ErrorT LoadError io ([String], Log)+ -> ExceptT LoadError io ([String], Log) readLog f = do pcapResult <- io $ Pcap.readPcap f liftM (id *** filter (isRelevant . deEvent)) $ case pcapResult of
Bustle/Loader/OldSkool.hs view
@@ -29,16 +29,8 @@ import Data.Map (Map) import Data.Maybe (isJust) import qualified Data.Map as Map-import Control.Monad (ap, when, guard)-import Control.Applicative ((<$>))--infixl 4 <*-(<*) :: Monad m => m a -> m b -> m a-m <* n = do ret <- m; n; return ret--infixl 4 <*>-(<*>) :: Monad m => m (a -> b) -> m a -> m b-(<*>) = ap+import Control.Monad (when, guard)+import Control.Applicative ((<$>), (<*>), (<*)) type Parser a = GenParser Char (Map (TaggedBusName, Serial) (Detailed Message)) a
Bustle/Noninteractive.hs view
@@ -29,7 +29,7 @@ import System.IO (hPutStrLn, stderr) import Data.Maybe (mapMaybe) import Data.List (nub)-import Control.Monad.Error+import Control.Monad.Except import Text.Printf import Bustle.Loader@@ -42,7 +42,7 @@ process :: FilePath -> (Log -> [a]) -> (a -> String) -> IO () process filepath analyze format = do- ret <- runErrorT $ readLog filepath+ ret <- runExceptT $ readLog filepath case ret of Left (LoadError _ err) -> do warn $ printf (__ "Couldn't parse '%s': %s") filepath err
Bustle/Renderer.hs view
@@ -50,7 +50,7 @@ import Control.Applicative (Applicative(..), (<$>), (<*>)) import Control.Arrow ((***))-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer
Bustle/UI.hs view
@@ -24,7 +24,7 @@ import Control.Monad.Reader import Control.Monad.State-import Control.Monad.Error+import Control.Monad.Except import Data.IORef import qualified Data.Set as Set@@ -38,6 +38,7 @@ import Bustle.Renderer import Bustle.Types import Bustle.Diagram+import Bustle.Gtk (b_windowSetTitlebar, b_headerBarSetSubtitle) import Bustle.Marquee (toString) import Bustle.Util import Bustle.UI.AboutDialog@@ -62,7 +63,7 @@ , dropExtension, dropTrailingPathSeparator , (</>), (<.>) )-import System.Directory (renameFile)+import System.GIO.File.File (fileFromParseName, fileMove, FileCopyFlags(..)) type B a = Bustle BConfig BState a @@ -80,8 +81,9 @@ data WindowInfo = WindowInfo { wiWindow :: Window- , wiSave :: ImageMenuItem- , wiExport :: MenuItem+ , wiHeaderBar :: Widget -- TODO+ , wiSave :: Button+ , wiExport :: Button , wiViewStatistics :: CheckMenuItem , wiFilterNames :: MenuItem , wiNotebook :: Notebook@@ -171,9 +173,9 @@ openLog :: MonadIO io => LogDetails- -> ErrorT LoadError io ( ([String], [DetailedEvent])- , ([String], [DetailedEvent])- )+ -> ExceptT LoadError io ( ([String], [DetailedEvent])+ , ([String], [DetailedEvent])+ ) openLog (RecordedLog filepath) = do result <- readLog filepath return (result, ([], []))@@ -189,7 +191,7 @@ -> LogDetails -> B () loadLogWith getWindow logDetails = do- ret <- runErrorT $ do+ ret <- runExceptT $ do ((sessionWarnings, sessionMessages), (systemWarnings, systemMessages)) <- openLog logDetails @@ -235,6 +237,13 @@ canvasScrollToBottom (wiCanvas wi) setPage wi CanvasPage +onMenuItemActivate :: MenuItemClass menuItem+ => menuItem+ -> IO ()+ -> IO (ConnectId menuItem)+onMenuItemActivate mi act =+ on mi menuItemActivate act+ finishedRecording :: WindowInfo -> FilePath -> Bool@@ -250,7 +259,7 @@ io $ do widgetSetSensitivity saveItem True- onActivateLeaf saveItem $ showSaveDialog wi (return ())+ saveItem `on` buttonActivated $ showSaveDialog wi (return ()) return () else do setPage wi InstructionsPage@@ -266,7 +275,22 @@ tempFileName = takeFileName tempFilePath recorderChooseFile tempFileName mwindow $ \newFilePath -> do- renameFile tempFilePath newFilePath+ 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: <i>%s</i>\n\n\+ \You might want to manually recover the log from the temporary file at\n\+ \<tt>%s</tt>") (toString msg) tempFilePath+ messageDialogSetSecondaryMarkup d secondary+ widgetShowAll d+ d `after` response $ \_ -> do+ widgetDestroy d+ return ()+ widgetSetSensitivity (wiSave wi) False wiSetLogDetails wi (SingleLog newFilePath) savedCb@@ -295,7 +319,7 @@ dialogAddButton prompt stockSave ResponseYes widgetShowAll prompt- prompt `afterResponse` \resp -> do+ prompt `after` response $ \resp -> do let closeUp = widgetDestroy (wiWindow wi) case resp of ResponseYes -> showSaveDialog wi closeUp@@ -320,15 +344,17 @@ let getW cast name = io $ builderGetObject builder cast name window <- getW castToWindow "diagramWindow"- [newItem, openItem, saveItem, closeItem, aboutItem] <-- mapM (getW castToImageMenuItem)- ["new", "open", "save", "close", "about"]- [newButton, openButton] <- mapM (getW castToButton) ["newButton", "openButton"]- exportItem <- getW castToMenuItem "export"- openTwoItem <- getW castToMenuItem "openTwo"+ header <- getW castToWidget "header"++ io $ b_windowSetTitlebar window header+ [openItem, openTwoItem] <- mapM (getW castToMenuItem) ["open", "openTwo"]+ [headerNew, headerSave, headerExport] <- mapM (getW castToButton) ["headerNew", "headerSave", "headerExport"]+ viewStatistics <- getW castToCheckMenuItem "statistics" filterNames <- getW castToMenuItem "filter"+ aboutItem <- getW castToMenuItem "about" + [newButton, openButton] <- mapM (getW castToButton) ["newButton", "openButton"] [nb, statsBook] <- mapM (getW castToNotebook) ["diagramOrNot", "statsBook"]@@ -336,26 +362,29 @@ -- Open two logs dialog openTwoDialog <- embedIO $ \r ->- setupOpenTwoDialog builder window $ \f1 f2 ->+ setupOpenTwoDialog window $ \f1 f2 -> makeCallback (loadInInitialWindow (TwoLogs f1 f2)) r -- Set up the window itself- embedIO $ onDestroy window . makeCallback maybeQuit+ embedIO $ (window `on` objectDestroy) . makeCallback maybeQuit -- File menu and related buttons embedIO $ \r -> do let new = makeCallback startRecording r- onActivateLeaf newItem new- onClicked newButton new+ forM [headerNew, newButton] $ \button ->+ button `on` buttonActivated $ new - let open = makeCallback (openDialogue window) r- onActivateLeaf openItem open- onClicked openButton open+ let open = makeCallback openDialogue r+ onMenuItemActivate openItem open+ openButton `on` buttonActivated $ open - onActivateLeaf openTwoItem $ widgetShowAll openTwoDialog+ onMenuItemActivate openTwoItem $ widgetShowAll openTwoDialog - -- Help menu- io $ onActivateLeaf aboutItem $ showAboutDialog window+ -- TODO: really this wants to live in the application menu, but that entails binding GApplication,+ -- GtkApplication, GMenu, GActionMap, GActionEntry, ...+ --+ -- Similarly, the drop-down menus would look better as popovers. But here we are.+ io $ onMenuItemActivate aboutItem $ showAboutDialog window m <- asks methodIcon s <- asks signalIcon@@ -377,8 +406,9 @@ logDetailsRef <- io $ newIORef Nothing let windowInfo = WindowInfo { wiWindow = window- , wiSave = saveItem- , wiExport = exportItem+ , wiHeaderBar = header+ , wiSave = headerSave+ , wiExport = headerExport , wiViewStatistics = viewStatistics , wiFilterNames = filterNames , wiNotebook = nb@@ -391,9 +421,6 @@ } io $ window `on` deleteEvent $ promptToSave windowInfo- io $ closeItem `on` menuItemActivate $ do- prompted <- promptToSave windowInfo- when (not prompted) (widgetDestroy window) incWindows io $ widgetShow window return windowInfo@@ -422,30 +449,27 @@ canvasSetShapes canvas shapes regions (rrCentreOffset rr) windowWidth -prettyDirectory :: String- -> String-prettyDirectory s = "(" ++ dropTrailingPathSeparator s ++ ")"+splitFileName_ :: String+ -> (String, String)+splitFileName_ s = (dropTrailingPathSeparator d, f)+ where+ (d, f) = splitFileName s logWindowTitle :: LogDetails- -> String-logWindowTitle (RecordedLog filepath) = "(*) " ++ takeFileName filepath-logWindowTitle (SingleLog filepath) =- intercalate " " [name, prettyDirectory directory]+ -> (String, Maybe String)+logWindowTitle (RecordedLog filepath) = ("*" ++ takeFileName filepath, Nothing)+logWindowTitle (SingleLog filepath) = (name, Just directory) where- (directory, name) = splitFileName filepath+ (directory, name) = splitFileName_ filepath logWindowTitle (TwoLogs sessionPath systemPath) =- intercalate " " $ filter (not . null)- [ sessionName, sessionDirectory'- , "&"- , systemName, prettyDirectory systemDirectory- ]+ -- TODO: this looks terrible, need a custom widget+ (sessionName ++ " & " ++ systemName,+ Just $ if sessionDirectory == systemDirectory+ then sessionDirectory+ else sessionDirectory ++ " & " ++ systemDirectory) where- (sessionDirectory, sessionName) = splitFileName sessionPath- (systemDirectory, systemName ) = splitFileName systemPath- sessionDirectory' =- if sessionDirectory == systemDirectory- then ""- else prettyDirectory sessionDirectory+ (sessionDirectory, sessionName) = splitFileName_ sessionPath+ (systemDirectory, systemName ) = splitFileName_ systemPath logTitle :: LogDetails -> String@@ -460,8 +484,9 @@ -> IO () wiSetLogDetails wi logDetails = do writeIORef (wiLogDetails wi) (Just logDetails)- windowSetTitle (wiWindow wi)- (printf (__ "%s - Bustle") (logWindowTitle logDetails) :: String)+ let (title, subtitle) = logWindowTitle logDetails+ (wiWindow wi) `set` [ windowTitle := title ]+ b_headerBarSetSubtitle (wiHeaderBar wi) subtitle setPage :: MonadIO io => WindowInfo@@ -495,7 +520,7 @@ updateDisplayedLog wi rr widgetSetSensitivity exportItem True- onActivateLeaf exportItem $ do+ exportItem `on` buttonActivated $ do shapes <- canvasGetShapes canvas saveToPDFDialogue wi shapes @@ -513,7 +538,7 @@ else widgetHide statsBook widgetSetSensitivity filterNames True- onActivateLeaf filterNames $ do+ onMenuItemActivate filterNames $ do hidden <- readIORef hiddenRef hidden' <- runFilterDialog window (sessionParticipants $ rrApplications rr) hidden writeIORef hiddenRef hidden'@@ -529,17 +554,16 @@ C.catch (fmap Just (pixbufNewFromFile iconName)) (\(GError _ _ msg) -> warn (toString msg) >> return Nothing) -openDialogue :: Window -> B ()-openDialogue window = embedIO $ \r -> do- chooser <- fileChooserDialogNew Nothing (Just window) FileChooserActionOpen+openDialogue :: B ()+openDialogue = embedIO $ \r -> do+ chooser <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen [ ("gtk-cancel", ResponseCancel) , ("gtk-open", ResponseAccept) ]- chooser `set` [ windowModal := True- , fileChooserLocalOnly := True+ chooser `set` [ fileChooserLocalOnly := True ] - chooser `afterResponse` \resp -> do+ chooser `after` response $ \resp -> do when (resp == ResponseAccept) $ do Just fn <- fileChooserGetFilename chooser makeCallback (loadInInitialWindow (SingleLog fn)) r@@ -574,7 +598,7 @@ TwoLogs p _ -> Just $ takeDirectory p maybeM mdirectory $ fileChooserSetCurrentFolder chooser - chooser `afterResponse` \resp -> do+ chooser `after` response $ \resp -> do when (resp == ResponseAccept) $ do Just fn <- io $ fileChooserGetFilename chooser let (width, height) = diagramDimensions shapes
Bustle/UI/AboutDialog.hs view
@@ -50,12 +50,12 @@ , aboutDialogAuthors := authors , aboutDialogCopyright := "© 2008–2014 Will Thompson, Collabora Ltd. and contributors" , aboutDialogLicense := license+ , aboutDialogLogoIconName := Just "bustle"+ , windowModal := True+ , windowTransientFor := window ]- dialog `afterResponse` \resp ->+ dialog `after` response $ \resp -> when (resp == ResponseCancel) (widgetDestroy dialog)- windowSetTransientFor dialog window- windowSetModal dialog True- aboutDialogSetLogoIconName dialog (Just "bustle") widgetShowAll dialog
Bustle/UI/Canvas.hs view
@@ -35,6 +35,7 @@ import Control.Monad (when) import Graphics.UI.Gtk+import Graphics.Rendering.Cairo (Render, translate) import Bustle.Diagram import Bustle.Regions@@ -131,11 +132,7 @@ "End" -> updateWith regionSelectionLast _ -> stopEvent - -- Expose events- -- I think we could speed things up by only showing the revealed area- -- rather than everything that's visible.- layout `on` exposeEvent $ tryEvent $ io $ canvasUpdate canvas-+ layout `on` draw $ canvasDraw canvas return () canvasInvalidateArea :: Canvas a@@ -257,30 +254,30 @@ canvasGetShapes = readIORef . canvasShapes -- | Redraws the currently-visible area of the canvas-canvasUpdate :: Canvas a- -> IO ()-canvasUpdate canvas = do- current <- canvasGetSelection canvas- shapes <- canvasGetShapes canvas- width <- readIORef $ canvasWidth canvas+canvasDraw :: Canvas a+ -> Render ()+canvasDraw canvas = do+ current <- io $ canvasGetSelection canvas+ shapes <- io $ canvasGetShapes canvas+ width <- io $ readIORef $ canvasWidth canvas let shapes' = case current of Nothing -> shapes Just (Stripe y1 y2, _) -> Highlight (0, y1, width, y2):shapes let layout = canvasLayout canvas - hadj <- layoutGetHAdjustment layout- hpos <- adjustmentGetValue hadj- hpage <- adjustmentGetPageSize hadj+ hadj <- io $ layoutGetHAdjustment layout+ hpos <- io $ adjustmentGetValue hadj+ hpage <- io $ adjustmentGetPageSize hadj - vadj <- layoutGetVAdjustment layout- vpos <- adjustmentGetValue vadj- vpage <- adjustmentGetPageSize vadj+ vadj <- io $ layoutGetVAdjustment layout+ vpos <- io $ adjustmentGetValue vadj+ vpage <- io $ adjustmentGetPageSize vadj let r = (hpos, vpos, hpos + hpage, vpos + vpage) - win <- layoutGetDrawWindow layout- renderWithDrawable win $ drawRegion r (canvasShowBounds canvas) shapes'+ translate (-hpos) (-vpos)+ drawRegion r (canvasShowBounds canvas) shapes' canvasFocus :: Canvas a -> IO ()
Bustle/UI/FilterDialog.hs view
@@ -22,21 +22,36 @@ ) where -import Data.List (intercalate)+import Data.List (intercalate, groupBy, findIndices) import qualified Data.Set as Set import Data.Set (Set)+import qualified Data.Function as F import Graphics.UI.Gtk import Bustle.Translation (__) import Bustle.Types +namespace :: String+ -> (String, String)+namespace name = case reverse (findIndices (== '.') name) of+ [] -> ("", name)+ (i:_) -> splitAt (i + 1) name+ formatNames :: (UniqueName, Set OtherName) -> String formatNames (u, os) | Set.null os = unUniqueName u- | otherwise = intercalate "\n" . map unOtherName $ Set.toAscList os+ | otherwise = intercalate "\n" . map (formatGroup . groupGroup) $ groups+ where+ groups = groupBy ((==) `F.on` fst) . map (namespace . unOtherName) $ Set.toAscList os + groupGroup [] = error "unpossible empty group from groupBy"+ groupGroup xs@((ns, _):_) = (ns, map snd xs)++ formatGroup (ns, [y]) = ns ++ y+ formatGroup (ns, ys) = ns ++ "{" ++ (intercalate "," ys) ++ "}"+ type NameStore = ListStore (Bool, (UniqueName, Set OtherName)) makeStore :: [(UniqueName, Set OtherName)]@@ -91,9 +106,11 @@ -> IO (Set UniqueName) -- ^ The set of names to *hide* runFilterDialog parent names currentlyHidden = do d <- dialogNew- windowSetTransientFor d parent+ (windowWidth, windowHeight) <- windowGetSize parent+ windowSetDefaultSize d (windowWidth * 7 `div` 8) (windowHeight `div` 2)+ d `set` [ windowTransientFor := parent ] dialogAddButton d stockClose ResponseClose- vbox <- dialogGetUpper d+ vbox <- fmap castToBox $ dialogGetContentArea d boxSetSpacing vbox 6 nameStore <- makeStore names currentlyHidden@@ -109,7 +126,7 @@ labelSetLineWrap instructions True boxPackStart vbox instructions PackNatural 0 - containerAdd vbox sw+ boxPackStart vbox sw PackGrow 0 widgetShowAll vbox _ <- dialogRun d
Bustle/UI/OpenTwoDialog.hs view
@@ -28,6 +28,7 @@ import Graphics.UI.Gtk import Bustle.Util+import Paths_bustle -- Propagates changes to d1's currently-selected folder to d2, if and only if -- d2 doesn't have a currently-selected file (otherwise, choosing a file@@ -37,7 +38,7 @@ => chooser -> chooser -> IO (ConnectId chooser)-propagateCurrentFolder d1 d2 = d1 `onCurrentFolderChanged` do+propagateCurrentFolder d1 d2 = d1 `on` currentFolderChanged $ do f1 <- fileChooserGetCurrentFolder d1 f2 <- fileChooserGetCurrentFolder d2 otherFile <- fileChooserGetFilename d2@@ -48,25 +49,27 @@ fileChooserSetCurrentFolder d2 (fromJust f1) return () -setupOpenTwoDialog :: Builder- -> Window+setupOpenTwoDialog :: Window -> (FilePath -> FilePath -> IO ()) -> IO Dialog-setupOpenTwoDialog builder parent callback = do+setupOpenTwoDialog parent callback = do+ builder <- builderNew+ builderAddFromFile builder =<< getDataFileName "data/OpenTwoDialog.ui"+ dialog <- builderGetObject builder castToDialog "openTwoDialog" [sessionBusChooser, systemBusChooser] <- mapM (builderGetObject builder castToFileChooserButton) ["sessionBusChooser", "systemBusChooser"] openTwoOpenButton <- builderGetObject builder castToButton "openTwoOpenButton" - windowSetTransientFor dialog parent+ dialog `set` [ windowTransientFor := parent ] dialog `on` deleteEvent $ tryEvent $ io $ widgetHide dialog propagateCurrentFolder sessionBusChooser systemBusChooser propagateCurrentFolder systemBusChooser sessionBusChooser let hideMyself = do- widgetHideAll dialog+ widgetHide dialog fileChooserUnselectAll sessionBusChooser fileChooserUnselectAll systemBusChooser @@ -82,7 +85,7 @@ connectGeneric "file-set" False systemBusChooser updateOpenSensitivity updateOpenSensitivity - dialog `afterResponse` \resp -> do+ dialog `after` response $ \resp -> do when (resp == ResponseAccept) $ do Just f1 <- fileChooserGetFilename sessionBusChooser Just f2 <- fileChooserGetFilename systemBusChooser
Bustle/UI/Recorder.hs view
@@ -27,6 +27,7 @@ import Control.Concurrent.MVar import qualified Data.Map as Map import Data.Monoid+import Data.Maybe (maybeToList) import Control.Monad.State (runStateT) import Text.Printf @@ -95,9 +96,12 @@ monitor <- monitorNew BusTypeSession filename dialog <- dialogNew - maybe (return ()) (windowSetTransientFor dialog) mwindow- dialog `set` [ windowModal := True ]+ dialog `set` (map (windowTransientFor :=) (maybeToList mwindow))+ dialog `set` [ windowModal := True+ , windowTitle := ""+ ] + label <- labelNew (Nothing :: Maybe String) labelSetMarkup label $ (printf (__ "Logged <b>%u</b> messages…") (0 :: Int) :: String)@@ -121,19 +125,21 @@ processor <- processBatch pendingRef n label incoming processorId <- timeoutAdd processor 200 - bar <- progressBarNew- pulseId <- timeoutAdd (progressBarPulse bar >> return True) 100+ spinner <- spinnerNew+ spinnerStart spinner - vbox <- dialogGetUpper dialog- boxPackStart vbox label PackGrow 0- boxPackStart vbox bar PackNatural 0+ vbox <- fmap castToBox $ dialogGetContentArea dialog+ hbox <- hBoxNew False 8+ boxPackStart hbox spinner PackNatural 0+ boxPackStart hbox label PackGrow 0+ boxPackStart vbox hbox PackGrow 0 dialogAddButton dialog "gtk-media-stop" ResponseClose - dialog `afterResponse` \_ -> do+ dialog `after` response $ \_ -> do monitorStop monitor signalDisconnect handlerId- timeoutRemove pulseId+ spinnerStop spinner timeoutRemove processorId -- Flush out any last messages from the queue. processor@@ -161,7 +167,7 @@ , fileChooserDoOverwriteConfirmation := True ] - chooser `afterResponse` \resp -> do+ chooser `after` response $ \resp -> do when (resp == ResponseAccept) $ do Just fn <- fileChooserGetFilename chooser callback fn
Bustle/UI/Util.hs view
@@ -41,5 +41,5 @@ maybeM mbody $ messageDialogSetSecondaryText dialog - dialog `afterResponse` \_ -> widgetDestroy dialog+ dialog `after` response $ \_ -> widgetDestroy dialog widgetShowAll dialog
Bustle/VariantFormatter.hs view
@@ -110,6 +110,7 @@ typeCode TypeString = "s" typeCode TypeSignature = "g" typeCode TypeObjectPath = "o"+typeCode TypeUnixFd = "h" typeCode TypeVariant = "v" typeCode (TypeArray t) = 'a':typeCode t typeCode (TypeDictionary kt vt) = concat [ "a{", typeCode kt , typeCode vt, "}"]@@ -137,6 +138,7 @@ TypeString -> format_String . fromJust . fromVariant TypeSignature -> format_Signature . fromJust . fromVariant TypeObjectPath -> format_ObjectPath . fromJust . fromVariant+ TypeUnixFd -> const "<fd>" TypeVariant -> format_Variant VariantStyleAngleBrackets . fromJust . fromVariant TypeArray TypeWord8 -> format_ByteArray . fromJust . fromVariant TypeArray _ -> format_Array . fromJust . fromVariant
Makefile view
@@ -29,7 +29,7 @@ BUSTLE_PCAP_HEADERS = c-sources/pcap-monitor.h $(BUSTLE_PCAP_GENERATED_HEADERS) bustle-pcap.1: dist/build/bustle-pcap- -help2man --output=$@ --no-info --name='Generate D-Bus logs for bustle' $<+ help2man --output=$@ --no-info --name='Generate D-Bus logs for bustle' $< bustle.desktop: data/bustle.desktop.in LC_ALL=C intltool-merge -d -u po $< $@@@ -97,7 +97,7 @@ TARBALL := $(TARBALL_DIR).tar.bz2 maintainer-binary-tarball: all mkdir -p $(TARBALL_FULL_DIR)- cabal-dev install --prefix=$(TOP)/$(TARBALL_FULL_DIR) \+ cabal install --prefix=$(TOP)/$(TARBALL_FULL_DIR) \ --datadir=$(TOP)/$(TARBALL_FULL_DIR) --datasubdir=. cp bustle.sh README.md $(TARBALL_FULL_DIR) perl -pi -e 's{^ bustle-pcap}{ ./bustle-pcap};' \
NEWS.md view
@@ -1,3 +1,12 @@+Bustle 0.5.0 (2015-06-04)+-------------------------++* Use Gtk+ 3, making Bustle more beautiful and support hidpi displays.+* Fix warnings triggered by recent GHCs and standard libraries by+ completely mechanical patching.+* Try not to crash if you view the body of a message containing a Unix+ FD.+ Bustle 0.4.8 (2015-03-22) -------------------------
Test/Regions.hs view
@@ -171,6 +171,9 @@ withRegions vr $ \rs -> property $ regionSelectionNew (regionSelectionFlatten rs) == rs +-- Essential scary hack to make quickCheckAll work O_o+-- https://hackage.haskell.org/package/QuickCheck-2.7.6/docs/Test-QuickCheck-All.html+return [] runTests = $quickCheckAll main = do
bustle.cabal view
@@ -1,6 +1,6 @@ Name: bustle Category: Network, Desktop-Version: 0.4.8+Version: 0.5.0 Cabal-Version: >= 1.8 Synopsis: Draw sequence diagrams of D-Bus traffic Description: Draw sequence diagrams of D-Bus traffic@@ -11,6 +11,7 @@ Data-files: data/dfeet-method.png, data/dfeet-signal.png, data/bustle.ui,+ data/OpenTwoDialog.ui, LICENSE Build-type: Custom Extra-source-files:@@ -69,6 +70,7 @@ Main-is: Bustle.hs Other-modules: Bustle.Application.Monad , Bustle.Diagram+ , Bustle.Gtk , Bustle.Loader , Bustle.Loader.OldSkool , Bustle.Loader.Pcap@@ -107,7 +109,8 @@ , directory , filepath , glib- , gtk >= 0.12.4+ , gio+ , gtk3 , hgettext >= 0.1.5 , mtl , pango@@ -137,7 +140,8 @@ , dbus , directory , filepath- , gtk > 0.12+ -- 0.13.6 doesn't compile with GCC 5: https://github.com/gtk2hs/gtk2hs/issues/104+ , gtk3 >= 0.13.7 , glib , hgettext , mtl@@ -191,7 +195,7 @@ , dbus >= 0.10 , directory , filepath- , gtk+ , gtk3 , mtl , text , pango
+ data/OpenTwoDialog.ui view
@@ -0,0 +1,133 @@+<?xml version="1.0" encoding="UTF-8"?>+<interface>+ <!-- interface-requires gtk+ 3.0 -->+ <object class="GtkDialog" id="openTwoDialog">+ <property name="can_focus">False</property>+ <property name="border_width">5</property>+ <property name="title" translatable="yes">Open a Pair of Logs</property>+ <property name="resizable">False</property>+ <property name="modal">True</property>+ <property name="type_hint">dialog</property>+ <property name="icon-name">bustle</property>+ <child internal-child="vbox">+ <object class="GtkBox" id="dialog-vbox1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="orientation">vertical</property>+ <property name="spacing">2</property>+ <child internal-child="action_area">+ <object class="GtkButtonBox" id="dialog-action_area1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="layout_style">end</property>+ <child>+ <object class="GtkButton" id="openTwoCancelButton">+ <property name="label">gtk-cancel</property>+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_action_appearance">False</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkButton" id="openTwoOpenButton">+ <property name="label">gtk-open</property>+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_action_appearance">False</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkTable" id="table1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="n_rows">2</property>+ <property name="n_columns">2</property>+ <property name="column_spacing">6</property>+ <property name="row_spacing">6</property>+ <child>+ <object class="GtkFileChooserButton" id="systemBusChooser">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="title" translatable="yes">Select system bus log</property>+ <property name="width_chars">30</property>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="y_options"></property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="label44">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">0</property>+ <property name="label" translatable="yes">System bus log:</property>+ </object>+ <packing>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="label55">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">0</property>+ <property name="label" translatable="yes">Session bus log:</property>+ </object>+ </child>+ <child>+ <object class="GtkFileChooserButton" id="sessionBusChooser">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="title" translatable="yes">Select session bus log</property>+ <property name="width_chars">30</property>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="y_options">GTK_EXPAND</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ </child>+ <action-widgets>+ <action-widget response="-6">openTwoCancelButton</action-widget>+ <action-widget response="-3">openTwoOpenButton</action-widget>+ </action-widgets>+ </object>+</interface>
data/bustle.ui view
@@ -12,168 +12,6 @@ <property name="visible">True</property> <property name="can_focus">False</property> <child>- <object class="GtkMenuBar" id="menubar1">- <property name="visible">True</property>- <property name="can_focus">False</property>- <child>- <object class="GtkMenuItem" id="menuitem1">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="label" translatable="yes">_File</property>- <property name="use_underline">True</property>- <child type="submenu">- <object class="GtkMenu" id="menu1">- <property name="visible">True</property>- <property name="can_focus">False</property>- <child>- <object class="GtkImageMenuItem" id="new">- <property name="label">gtk-new</property>- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- <accelerator key="n" signal="activate" modifiers="GDK_CONTROL_MASK"/>- </object>- </child>- <child>- <object class="GtkImageMenuItem" id="open">- <property name="label">gtk-open</property>- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- <accelerator key="o" signal="activate" modifiers="GDK_CONTROL_MASK"/>- </object>- </child>- <child>- <object class="GtkMenuItem" id="openTwo">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="tooltip_text" translatable="yes">Display two logs—one for the session bus, one for the system bus—side by side.</property>- <property name="label" translatable="yes">O_pen a Pair of Logs…</property>- <property name="use_underline">True</property>- </object>- </child>- <child>- <object class="GtkImageMenuItem" id="save">- <property name="label">gtk-save-as</property>- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="sensitive">False</property>- <property name="can_focus">False</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- <accelerator key="s" signal="activate" modifiers="GDK_CONTROL_MASK"/>- </object>- </child>- <child>- <object class="GtkMenuItem" id="export">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="sensitive">False</property>- <property name="can_focus">False</property>- <property name="label" translatable="yes">_Export as PDF…</property>- <property name="use_underline">True</property>- <accelerator key="s" signal="activate" modifiers="GDK_SHIFT_MASK | GDK_CONTROL_MASK"/>- </object>- </child>- <child>- <object class="GtkSeparatorMenuItem" id="separatormenuitem1">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- </object>- </child>- <child>- <object class="GtkImageMenuItem" id="close">- <property name="label">gtk-close</property>- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="sensitive">True</property>- <property name="can_focus">False</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- <accelerator key="w" signal="activate" modifiers="GDK_CONTROL_MASK"/>- </object>- </child>- </object>- </child>- </object>- </child>- <child>- <object class="GtkMenuItem" id="menuitem3">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="label" translatable="yes">_View</property>- <property name="use_underline">True</property>- <child type="submenu">- <object class="GtkMenu" id="menu2">- <property name="visible">True</property>- <property name="can_focus">False</property>- <child>- <object class="GtkMenuItem" id="filter">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="sensitive">False</property>- <property name="can_focus">False</property>- <property name="label" translatable="yes">_Filter Visible Services…</property>- <property name="use_underline">True</property>- <accelerator key="f" signal="activate" modifiers="GDK_CONTROL_MASK"/>- </object>- </child>- <child>- <object class="GtkCheckMenuItem" id="statistics">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="sensitive">False</property>- <property name="can_focus">False</property>- <property name="label" translatable="yes">_Statistics</property>- <property name="use_underline">True</property>- <accelerator key="F9" signal="activate"/>- </object>- </child>- </object>- </child>- </object>- </child>- <child>- <object class="GtkMenuItem" id="menuitem4">- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="label" translatable="yes">_Help</property>- <property name="use_underline">True</property>- <child type="submenu">- <object class="GtkMenu" id="menu3">- <property name="visible">True</property>- <property name="can_focus">False</property>- <child>- <object class="GtkImageMenuItem" id="about">- <property name="label">gtk-about</property>- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- </object>- </child>- </object>- </child>- </object>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child> <object class="GtkNotebook" id="diagramOrNot"> <property name="visible">True</property> <property name="can_focus">True</property>@@ -491,133 +329,172 @@ </object> </child> </object>- <object class="GtkDialog" id="openTwoDialog">- <property name="can_focus">False</property>- <property name="border_width">5</property>- <property name="title" translatable="yes">Open a Pair of Logs</property>- <property name="resizable">False</property>- <property name="modal">True</property>- <property name="type_hint">dialog</property>- <property name="icon-name">bustle</property>- <child internal-child="vbox">- <object class="GtkBox" id="dialog-vbox1">+ <object class="GtkHeaderBar" id="header">+ <property name="visible">True</property>+ <property name="show-close-button">True</property>++ <child>+ <object class="GtkMenuButton" id="headerOpen"> <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="orientation">vertical</property>- <property name="spacing">2</property>- <child internal-child="action_area">- <object class="GtkButtonBox" id="dialog-action_area1">+ <property name="sensitive">True</property>+ <property name="tooltip_text" translatable="yes">Open an existing log</property>+ <property name="popup">openMenu</property>+ <style>+ <class name="image-button"/>+ </style>+ <child>+ <object class="GtkImage"> <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="layout_style">end</property>- <child>- <object class="GtkButton" id="openTwoCancelButton">- <property name="label">gtk-cancel</property>- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="use_action_appearance">False</property>- <property name="use_stock">True</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkButton" id="openTwoOpenButton">- <property name="label">gtk-open</property>- <property name="use_action_appearance">False</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="use_action_appearance">False</property>- <property name="use_stock">True</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">1</property>- </packing>- </child>+ <property name="icon-name">document-open-symbolic</property>+ <property name="icon-size">1</property> </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="pack_type">end</property>- <property name="position">0</property>- </packing> </child>+ </object>+ <packing>+ <property name="pack-type">GTK_PACK_START</property>+ </packing>+ </child>++ <!-- TODO: media-record-symbolic -->+ <child>+ <object class="GtkButton" id="headerNew">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Record</property>+ <property name="tooltip_text" translatable="yes">Record a new log</property>+ </object>+ </child>++ <child>+ <object class="GtkMenuButton">+ <property name="visible">True</property>+ <property name="popup">filterStatsEtc</property>+ <style>+ <class name="image-button"/>+ </style> <child>- <object class="GtkTable" id="table1">+ <object class="GtkImage"> <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="n_rows">2</property>- <property name="n_columns">2</property>- <property name="column_spacing">6</property>- <property name="row_spacing">6</property>- <child>- <object class="GtkFileChooserButton" id="systemBusChooser">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="title" translatable="yes">Select system bus log</property>- <property name="width_chars">30</property>- </object>- <packing>- <property name="left_attach">1</property>- <property name="right_attach">2</property>- <property name="top_attach">1</property>- <property name="bottom_attach">2</property>- <property name="y_options"></property>- </packing>- </child>- <child>- <object class="GtkLabel" id="label44">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="xalign">0</property>- <property name="label" translatable="yes">System bus log:</property>- </object>- <packing>- <property name="top_attach">1</property>- <property name="bottom_attach">2</property>- </packing>- </child>- <child>- <object class="GtkLabel" id="label55">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="xalign">0</property>- <property name="label" translatable="yes">Session bus log:</property>- </object>- </child>- <child>- <object class="GtkFileChooserButton" id="sessionBusChooser">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="title" translatable="yes">Select session bus log</property>- <property name="width_chars">30</property>- </object>- <packing>- <property name="left_attach">1</property>- <property name="right_attach">2</property>- <property name="y_options">GTK_EXPAND</property>- </packing>- </child>+ <property name="icon-name">open-menu-symbolic</property>+ <property name="icon-size">1</property> </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing> </child> </object>+ <packing>+ <property name="pack-type">end</property>+ </packing> </child>- <action-widgets>- <action-widget response="-6">openTwoCancelButton</action-widget>- <action-widget response="-3">openTwoOpenButton</action-widget>- </action-widgets>++ <child>+ <object class="GtkButton" id="headerExport">+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="tooltip_text" translatable="yes">Export as PDF</property>+ <style>+ <class name="image-button"/>+ </style>+ <child>+ <object class="GtkImage">+ <property name="visible">True</property>+ <property name="icon-name">document-send-symbolic</property>+ <property name="icon-size">1</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="pack-type">end</property>+ </packing>+ </child>++ <child>+ <object class="GtkButton" id="headerSave">+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="tooltip_text" translatable="yes">Save</property>+ <style>+ <class name="image-button"/>+ </style>+ <child>+ <object class="GtkImage">+ <property name="visible">True</property>+ <property name="icon-name">document-save-symbolic</property>+ <property name="icon-size">1</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="pack-type">end</property>+ </packing>+ </child> </object>++ <object class="GtkMenu" id="filterStatsEtc">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="halign">end</property>+ <child>+ <object class="GtkMenuItem" id="filter">+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">_Filter Visible Services…</property>+ <property name="use_underline">True</property>+ <accelerator key="f" signal="activate" modifiers="GDK_CONTROL_MASK"/>+ </object>+ </child>+ <child>+ <object class="GtkCheckMenuItem" id="statistics">+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="sensitive">False</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">_Statistics</property>+ <property name="use_underline">True</property>+ <accelerator key="F9" signal="activate"/>+ </object>+ </child>+ <child>+ <object class="GtkSeparatorMenuItem" id="separatormenuitem1">+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="about">+ <property name="label">gtk-about</property>+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </object>+ </child>+ </object>++ <object class="GtkMenu" id="openMenu">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkImageMenuItem" id="open">+ <property name="label">gtk-open</property>+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ <accelerator key="o" signal="activate" modifiers="GDK_CONTROL_MASK"/>+ </object>+ </child>+ <child>+ <object class="GtkMenuItem" id="openTwo">+ <property name="use_action_appearance">False</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Display two logs—one for the session bus, one for the system bus—side by side.</property>+ <property name="label" translatable="yes">O_pen a Pair of Logs…</property>+ <property name="use_underline">True</property>+ </object>+ </child>+ </object> </interface>