Don't crash on UnmarshalError

We hit UnmarshalError if the log contains messages using types like 'h'
that dbus-core doesn't understand yet. We shouldn't crash when this
happens.

It would be better to show the warnings in the UI, so the user knows
some messages are missing; or maybe even interleave them so we can show
a warning inline to say “there should be a message here but we couldn't
read it”. Another time.

<https://bugs.freedesktop.org/show_bug.cgi?id=44714>

4 files changed, 23 insertions, 30 deletions

diff --git a/Bustle/Loader.hs b/Bustle/Loader.hs
index aefcd93..994aef8 100644
--- a/Bustle/Loader.hs
+++ b/Bustle/Loader.hs
@@ -5,6 +5,7 @@ module Bustle.Loader
 where
 
 import Control.Monad.Error
+import Control.Arrow ((***))
 
 import qualified Bustle.Loader.OldSkool as Old
 import qualified Bustle.Loader.Pcap as Pcap
@@ -18,12 +19,12 @@ instance Error LoadError where
 
 readLog :: MonadIO io
         => FilePath
-        -> ErrorT LoadError io Log
+        -> ErrorT LoadError io ([String], Log)
 readLog f = do
     pcapResult <- io $ Pcap.readPcap f
-    liftM (filter (isRelevant . dmMessage)) $ case pcapResult of
+    liftM (id *** filter (isRelevant . dmMessage)) $ case pcapResult of
         Right ms -> return ms
-        Left _ -> readOldLogFile
+        Left _ -> liftM ((,) []) readOldLogFile
   where
     readOldLogFile = do
         input <- handleIOExceptions (LoadError f . show) $ readFile f
diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs
index a545ae3..436b2b5 100644
--- a/Bustle/Loader/Pcap.hs
+++ b/Bustle/Loader/Pcap.hs
@@ -5,6 +5,7 @@ module Bustle.Loader.Pcap
 where
 
 import Data.Maybe (fromJust)
+import Data.Either (partitionEithers)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Control.Exception (try)
@@ -194,8 +195,7 @@ convert hdr body =
 
 data Result e a =
     EOF
-  | Failed e
-  | Read a
+  | Packet (Either e a)
   deriving Show
 
 readOne :: (Monad m, MonadIO m)
@@ -211,33 +211,23 @@ readOne p f = do
     -- or something?
     if hdrCaptureLength hdr == 0
         then return EOF
-        else do
-            x <- f hdr body
-            return $ case x of
-                Left e  -> Failed e
-                Right a -> Read a
+        else liftM Packet $ f hdr body
 
 mapBodies :: (Monad m, MonadIO m)
           => PcapHandle
           -> (PktHdr -> BS.ByteString -> StateT s m (Either e a))
-          -> StateT s m (Either e [a])
+          -> StateT s m [Either e a]
 mapBodies p f = do
     ret <- readOne p f
     case ret of
-        EOF      -> return $ Right []
-        Failed e -> return $ Left e
-        Read a   -> do
-            ret' <- mapBodies p f
-            case ret' of
-                Left _   -> return ret'
-                Right as -> return (Right (a:as))
-
-readPcap :: FilePath -> IO (Either IOError [B.DetailedMessage])
+        EOF      -> return $ []
+        Packet x -> do
+            xs <- mapBodies p f
+            return $ x:xs
+
+readPcap :: FilePath
+         -> IO (Either IOError ([String], [B.DetailedMessage]))
 readPcap path = try $ do
     p <- openOffline path
 
-    ret <- evalStateT (mapBodies p convert) Map.empty
-    -- FIXME: make the error handling less shoddy
-    case ret of
-        Left e -> error $ show e
-        Right xs -> return xs
+    liftM partitionEithers $ evalStateT (mapBodies p convert) Map.empty
diff --git a/Bustle/Noninteractive.hs b/Bustle/Noninteractive.hs
index 30e3d71..2986a27 100644
--- a/Bustle/Noninteractive.hs
+++ b/Bustle/Noninteractive.hs
@@ -32,7 +32,9 @@ process filepath analyze format = do
                           , err
                           ]
             exitFailure
-        Right log -> mapM_ (putStrLn . format) $ analyze log
+        Right (warnings, log) -> do
+            mapM warn warnings
+            mapM_ (putStrLn . format) $ analyze log
 
 formatInterface :: Maybe String -> String
 formatInterface = fromMaybe "(no interface)"
diff --git a/Bustle/UI.hs b/Bustle/UI.hs
index a4824e5..f5a4d90 100644
--- a/Bustle/UI.hs
+++ b/Bustle/UI.hs
@@ -168,14 +168,14 @@ loadLogWith :: B WindowInfo   -- ^ action returning a window to load the log(s)
             -> B ()
 loadLogWith getWindow session maybeSystem = do
     ret <- runErrorT $ do
-        sessionMessages <- readLog session
-        systemMessages <- case maybeSystem of
+        (sessionWarnings, sessionMessages) <- readLog session
+        (systemWarnings, systemMessages) <- case maybeSystem of
             Just system -> readLog system
-            Nothing     -> return []
+            Nothing     -> return ([], [])
 
         -- FIXME: pass the log file name into the renderer
         let rr = process sessionMessages systemMessages
-        forM_ (rrWarnings rr) $ io . warn
+        io $ mapM warn $ sessionWarnings ++ systemWarnings ++ rrWarnings rr
 
         windowInfo <- lift getWindow
         lift $ displayLog windowInfo