Use GDBusMessage rather than 'dbus' library

This avoids needing two separate implementations of the DBus protocol in
the application, at the cost of writing a hand-written binding for parts
of the GDBusMessage and GVariant API.

11 files changed, 530 insertions, 286 deletions

diff --git a/Bustle/GDBusMessage.hs b/Bustle/GDBusMessage.hs
index 8a29896..d556748 100644
--- a/Bustle/GDBusMessage.hs
+++ b/Bustle/GDBusMessage.hs
@@ -21,25 +21,131 @@ module Bustle.GDBusMessage
   (
 -- * Types
     GDBusMessage
+  , MessageType(..)
+  , Serial
+
+  , BusName
+  , formatBusName
+  , busName_
+
+  , ObjectPath
+  , formatObjectPath
+  , objectPath_
+
+  , InterfaceName
+  , formatInterfaceName
+  , interfaceName_
+
+  , MemberName
+  , formatMemberName
+  , memberName_
+
+-- * Constructors
+  , makeNewGDBusMessage
+  , wrapNewGDBusMessage
+  , messageNewSignal
 
-{-
 -- * Methods
-  , monitorNew
-  , monitorStop
+  , messageType
+  , messageSerial
+  , messageReplySerial
+  , messageSender
+  , messageDestination
+  , messageErrorName
+  , messagePath
+  , messageInterface
+  , messageMember
 
--- * Signals
-  , monitorMessageLogged
-  , monitorStopped
-  -}
+  , messagePrintBody
+  , messageGetBodyString
   )
 where
 
+import Data.Word
+import Data.String
+
 import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.C
+import Foreign.Marshal.Alloc
+import System.IO.Unsafe
 
 import System.Glib.GObject
+import System.Glib.UTFString
+
+import Control.Monad (guard)
+import Control.Monad.Trans (liftIO)
+import Control.Monad.Trans.Maybe
+
+import Bustle.GVariant
+
+data MessageType = MessageTypeInvalid
+                 | MessageTypeMethodCall
+                 | MessageTypeMethodReturn
+                 | MessageTypeError
+                 | MessageTypeSignal
+  deriving
+    (Show, Ord, Eq, Enum)
+
+-- 0 is unused in the wire protocol so indicates "no serial"
+type Serial = Word32
+
+newtype BusName = BusName String
+    deriving (Eq, Ord, Show)
+
+instance IsString BusName where
+    fromString = busName_
+
+newtype ObjectPath = ObjectPath String
+    deriving (Eq, Ord, Show)
+
+instance IsString ObjectPath where
+    fromString = objectPath_
+
+newtype InterfaceName = InterfaceName String
+    deriving (Eq, Ord, Show)
+
+newtype MemberName = MemberName String
+    deriving (Eq, Ord, Show)
+
+instance IsString MemberName where
+    fromString = memberName_
+
+-- TODO: validate
+busName_ :: String
+         -> BusName
+busName_ = BusName
+
+formatBusName :: BusName
+              -> String
+formatBusName (BusName n) = n
+
+objectPath_ :: String
+            -> ObjectPath
+objectPath_ = ObjectPath
+
+formatObjectPath :: ObjectPath
+                 -> String
+formatObjectPath (ObjectPath n) = n
+
+interfaceName_ :: String
+               -> InterfaceName
+interfaceName_ = InterfaceName
+
+formatInterfaceName :: InterfaceName
+                    -> String
+formatInterfaceName (InterfaceName n) = n
+
+memberName_ :: String
+            -> MemberName
+memberName_ = MemberName
+
+formatMemberName :: MemberName
+                 -> String
+formatMemberName (MemberName n) = n
 
 newtype GDBusMessage = GDBusMessage { unGDBusMessage :: ForeignPtr GDBusMessage }
-    deriving (Eq, Ord)
+    deriving (Eq, Ord, Show)
 
 mkGDBusMessage :: (ForeignPtr GDBusMessage -> GDBusMessage, FinalizerPtr a)
 mkGDBusMessage = (GDBusMessage, objectUnref)
@@ -47,3 +153,149 @@ mkGDBusMessage = (GDBusMessage, objectUnref)
 instance GObjectClass GDBusMessage where
     toGObject = GObject . castForeignPtr . unGDBusMessage
     unsafeCastGObject = GDBusMessage . castForeignPtr . unGObject
+
+
+makeNewGDBusMessage :: IO (Ptr GDBusMessage)
+                    -> IO GDBusMessage
+makeNewGDBusMessage = makeNewGObject mkGDBusMessage
+
+wrapNewGDBusMessage :: IO (Ptr GDBusMessage)
+                    -> IO GDBusMessage
+wrapNewGDBusMessage = wrapNewGObject mkGDBusMessage
+
+-- Foreign imports
+foreign import ccall unsafe "g_dbus_message_new_signal"
+    g_dbus_message_new_signal :: CString
+                              -> CString
+                              -> CString
+                              -> IO (Ptr GDBusMessage)
+
+foreign import ccall unsafe "g_dbus_message_get_message_type"
+    g_dbus_message_get_message_type :: Ptr GDBusMessage
+                                    -> IO Int
+
+foreign import ccall unsafe "g_dbus_message_get_serial"
+    g_dbus_message_get_serial :: Ptr GDBusMessage
+                              -> IO Word32
+
+foreign import ccall unsafe "g_dbus_message_get_reply_serial"
+    g_dbus_message_get_reply_serial :: Ptr GDBusMessage
+                                    -> IO Word32
+
+foreign import ccall unsafe "g_dbus_message_get_sender"
+    g_dbus_message_get_sender :: Ptr GDBusMessage
+                              -> IO CString
+
+foreign import ccall unsafe "g_dbus_message_get_destination"
+    g_dbus_message_get_destination :: Ptr GDBusMessage
+                                   -> IO CString
+
+foreign import ccall unsafe "g_dbus_message_get_error_name"
+    g_dbus_message_get_error_name :: Ptr GDBusMessage
+                                  -> IO CString
+
+foreign import ccall unsafe "g_dbus_message_get_path"
+    g_dbus_message_get_path :: Ptr GDBusMessage
+                                  -> IO CString
+
+foreign import ccall unsafe "g_dbus_message_get_interface"
+    g_dbus_message_get_interface :: Ptr GDBusMessage
+                                  -> IO CString
+
+foreign import ccall unsafe "g_dbus_message_get_member"
+    g_dbus_message_get_member :: Ptr GDBusMessage
+                                  -> IO CString
+
+foreign import ccall unsafe "g_dbus_message_get_body"
+    g_dbus_message_get_body :: Ptr GDBusMessage
+                            -> IO (Ptr GVariant)
+
+-- Bindings
+
+messageNewSignal :: ObjectPath
+                              -> InterfaceName
+                              -> MemberName
+                              -> IO GDBusMessage
+messageNewSignal (ObjectPath o) (InterfaceName i) (MemberName m) =
+    withCString o $ \o_ptr ->
+    withCString i $ \i_ptr ->
+    withCString m $ \m_ptr ->
+        wrapNewGDBusMessage $ g_dbus_message_new_signal o_ptr i_ptr m_ptr
+
+-- FIXME: remove unsafePerformIOs – GDBusMessage is not immutable
+messageType :: GDBusMessage
+            -> MessageType
+messageType message = unsafePerformIO $
+    withForeignPtr (unGDBusMessage message) $ \c_message ->
+    toEnum <$> g_dbus_message_get_message_type c_message
+
+messageSerial :: GDBusMessage
+              -> Serial
+messageSerial message = unsafePerformIO $
+    withForeignPtr (unGDBusMessage message) $ \c_message ->
+    g_dbus_message_get_serial c_message
+
+messageReplySerial :: GDBusMessage
+                   -> Serial
+messageReplySerial message = unsafePerformIO $
+    withForeignPtr (unGDBusMessage message) $ \c_message ->
+    g_dbus_message_get_reply_serial c_message
+
+messageStr :: (String -> a)
+           -> (Ptr GDBusMessage -> IO CString)
+           -> GDBusMessage
+           -> Maybe a
+messageStr ctor f message = unsafePerformIO $
+    withForeignPtr (unGDBusMessage message) $ \c_message -> do
+    c_str <- f c_message
+    if c_str == nullPtr
+        then return Nothing
+        else Just . ctor <$> peekUTFString c_str
+
+messageSender :: GDBusMessage
+              -> Maybe BusName
+messageSender = messageStr BusName g_dbus_message_get_sender
+
+messageDestination :: GDBusMessage
+                   -> Maybe BusName
+messageDestination = messageStr BusName g_dbus_message_get_destination
+
+messageErrorName :: GDBusMessage
+                 -> Maybe String
+messageErrorName = messageStr id g_dbus_message_get_error_name
+
+messagePath :: GDBusMessage
+            -> Maybe ObjectPath
+messagePath = messageStr ObjectPath g_dbus_message_get_path
+
+messageInterface :: GDBusMessage
+                 -> Maybe InterfaceName
+messageInterface = messageStr InterfaceName g_dbus_message_get_interface
+
+messageMember :: GDBusMessage
+              -> Maybe MemberName
+messageMember = messageStr MemberName g_dbus_message_get_member
+
+messageGetBody :: GDBusMessage
+               -> IO (Maybe GVariant)
+messageGetBody message = do
+    body <- liftIO $ withForeignPtr (unGDBusMessage message) g_dbus_message_get_body
+    if body == nullPtr
+        then return Nothing
+        else Just <$> makeNewGVariant (return body)
+
+messagePrintBody :: GDBusMessage
+                 -> String
+messagePrintBody message = unsafePerformIO $ do
+    body <- messageGetBody message
+    case body of
+        Nothing -> return ""
+        Just b  -> variantPrint b WithAnnotations
+
+messageGetBodyString :: GDBusMessage
+                     -> Word
+                     -> IO (Maybe String)
+messageGetBodyString message i = runMaybeT $ do
+    body <- MaybeT $ messageGetBody message
+    child <- MaybeT $ variantGetChild body i
+    MaybeT $ variantGetString child
diff --git a/Bustle/GVariant.hs b/Bustle/GVariant.hs
new file mode 100644
index 0000000..1e89769
--- /dev/null
+++ b/Bustle/GVariant.hs
@@ -0,0 +1,126 @@
+{-
+Bustle.GVariant: bindings for GVariant
+Copyright © 2020 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.GVariant
+  (
+-- * Types
+    GVariant
+  , TypeAnnotate(..)
+
+-- * Constructors
+  , makeNewGVariant
+  , wrapNewGVariant
+
+-- * Methods
+  , variantGetChild
+  , variantGetString
+  , variantPrint
+
+  )
+where
+
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.C
+
+import System.Glib.UTFString
+
+import Control.Monad (guard)
+import Control.Monad.Trans (liftIO)
+import Control.Monad.Trans.Maybe
+
+data TypeAnnotate = NoAnnotations
+                  | WithAnnotations
+  deriving
+    (Show, Ord, Eq, Enum)
+
+newtype GVariant = GVariant { unGVariant :: ForeignPtr GVariant }
+    deriving (Eq, Ord, Show)
+
+makeNewGVariant :: IO (Ptr GVariant)
+                -> IO GVariant
+makeNewGVariant act = wrapNewGVariant (act >>= g_variant_ref)
+
+wrapNewGVariant :: IO (Ptr GVariant)
+                -> IO GVariant
+wrapNewGVariant act = do
+    vPtr <- act
+    v <- newForeignPtr g_variant_unref vPtr
+    return $ GVariant v
+
+-- Foreign imports
+foreign import ccall unsafe "g_variant_is_of_type"
+    g_variant_is_of_type :: Ptr a
+                         -> CString
+                         -> IO CInt
+
+foreign import ccall unsafe "g_variant_n_children"
+    g_variant_n_children :: Ptr a
+                             -> IO CSize
+
+foreign import ccall unsafe "g_variant_get_child_value"
+    g_variant_get_child_value :: Ptr a
+                              -> CSize
+                              -> IO (Ptr a)
+
+foreign import ccall unsafe "g_variant_get_string"
+    g_variant_get_string :: Ptr a
+                         -> Ptr CSize
+                         -> IO CString
+
+foreign import ccall unsafe "g_variant_print"
+    g_variant_print :: Ptr a
+                    -> CInt
+                    -> IO CString
+
+foreign import ccall unsafe "g_variant_ref"
+    g_variant_ref :: Ptr GVariant
+                  -> IO (Ptr GVariant)
+
+foreign import ccall unsafe "&g_variant_unref"
+    g_variant_unref :: FunPtr (Ptr GVariant -> IO ())
+
+-- Bindings
+variantNChildren :: GVariant
+                    -> IO Word
+variantNChildren v = withForeignPtr (unGVariant v) $ \vPtr -> do
+    fromIntegral <$> g_variant_n_children vPtr
+
+variantGetChild :: GVariant
+                -> Word
+                -> IO (Maybe GVariant)
+variantGetChild v i = withForeignPtr (unGVariant v) $ \vPtr -> runMaybeT $ do
+    n <- liftIO $ variantNChildren v
+    guard (i < n)
+    liftIO $ wrapNewGVariant $ g_variant_get_child_value vPtr (fromIntegral i)
+
+variantGetString :: GVariant
+                 -> IO (Maybe String)
+variantGetString v = withForeignPtr (unGVariant v) $ \vPtr -> runMaybeT $ do
+    r <- liftIO $ withCString "s" $ g_variant_is_of_type vPtr
+    guard (r /= 0)
+    s <- liftIO $ g_variant_get_string vPtr nullPtr
+    liftIO $ peekUTFString s
+
+variantPrint :: GVariant
+             -> TypeAnnotate
+             -> IO String
+variantPrint v annotate = withForeignPtr (unGVariant v) $ \vPtr -> do
+    cstr <- g_variant_print vPtr (fromIntegral $ fromEnum annotate)
+    readUTFString cstr
diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs
index eb0485d..a10ee85 100644
--- a/Bustle/Loader/Pcap.hs
+++ b/Bustle/Loader/Pcap.hs
@@ -32,14 +32,14 @@ import qualified Data.Map as Map
 import Data.Map (Map)
 import Control.Exception (try)
 import Control.Monad.State
+import Control.Monad.Trans.Maybe
 
-import System.Glib (GError)
-
-import DBus
+import System.IO.Unsafe (unsafePerformIO)
 
-import qualified Data.ByteString as BS
+import System.Glib (GError)
 
 import qualified Bustle.Types as B
+import Bustle.GDBusMessage
 import Bustle.Reader
 
 -- Conversions from dbus-core's types into Bustle's more stupid types. This
@@ -61,23 +61,20 @@ convertBusName fallback n =
   where
     fallback_ = busName_ fallback
 
-convertMember :: (a -> ObjectPath)
-              -> (a -> Maybe InterfaceName)
-              -> (a -> MemberName)
-              -> a
+convertMember :: GDBusMessage
               -> B.Member
-convertMember getObjectPath getInterfaceName getMemberName m =
-    B.Member (getObjectPath m)
-             (getInterfaceName m)
-             (getMemberName m)
+convertMember m =
+    B.Member (fromMaybe (objectPath_ "") $ messagePath m)
+             (messageInterface m)
+             (fromMaybe (memberName_ "") $ messageMember m)
 
 type PendingMessages = Map (Maybe BusName, Serial)
-                           (MethodCall, B.Detailed B.Message)
+                           (B.Detailed B.Message)
 
 popMatchingCall :: (MonadState PendingMessages m)
                 => Maybe BusName
                 -> Serial
-                -> m (Maybe (MethodCall, B.Detailed B.Message))
+                -> m (Maybe (B.Detailed B.Message))
 popMatchingCall name serial = do
     ret <- tryPop (name, serial)
     case (ret, name) of
@@ -96,27 +93,27 @@ popMatchingCall name serial = do
 insertPending :: MonadState PendingMessages m
               => Maybe BusName
               -> Serial
-              -> MethodCall
               -> B.Detailed B.Message
               -> m ()
-insertPending n s rawCall b = modify $ Map.insert (n, s) (rawCall, b)
-
-isNOC :: Maybe BusName -> Signal -> Maybe (BusName, Maybe BusName, Maybe BusName)
-isNOC (Just sender) s | looksLikeNOC =
-    case names of
-        [Just n, old, new] -> Just (n, old, new)
-        _                  -> Nothing
+insertPending n s b = modify $ Map.insert (n, s) b
+
+-- FIXME: IO
+isNOC :: Maybe BusName -> GDBusMessage -> Maybe (BusName, Maybe BusName, Maybe BusName)
+isNOC maybeSender message = unsafePerformIO $ runMaybeT $ do
+    sender <- MaybeT . return $ maybeSender
+    guard (sender == B.dbusName)
+    guard (messageType message == MessageTypeSignal)
+    iface <- MaybeT . return $ messageInterface message
+    guard (iface == B.dbusInterface)
+    member <- MaybeT . return $ formatMemberName <$> messageMember message
+    guard (member == "NameOwnerChanged")
+    n <- MaybeT $ messageGetBodyString message 0
+    old <- MaybeT $ messageGetBodyString message 1
+    new <- MaybeT $ messageGetBodyString message 2
+    return (busName_ n, asBusName old, asBusName new)
   where
-    names :: [Maybe BusName]
-    names = map fromVariant $ signalBody s
-
-    looksLikeNOC =
-      (sender == B.dbusName) &&
-        (signalInterface s == B.dbusInterface) &&
-          (formatMemberName (signalMember s) == "NameOwnerChanged")
-
-isNOC _ _ = Nothing
-
+    asBusName "" = Nothing
+    asBusName name = Just $ busName_ name
 
 bustlifyNOC :: (BusName, Maybe BusName, Maybe BusName)
             -> B.NOC
@@ -136,101 +133,102 @@ bustlifyNOC ns@(name, oldOwner, newOwner)
     uniquify = B.UniqueName
     otherify = B.OtherName
 
-tryBustlifyGetNameOwnerReply :: Maybe (MethodCall, a)
-                             -> MethodReturn
+-- FIXME: IO
+tryBustlifyGetNameOwnerReply :: Maybe (B.Detailed a)
+                             -> GDBusMessage
                              -> Maybe B.NOC
-tryBustlifyGetNameOwnerReply maybeCall mr = do
+tryBustlifyGetNameOwnerReply maybeCall reply = unsafePerformIO $ runMaybeT $ do
     -- FIXME: obviously this should be more robust:
     --  • check that the service really is the bus daemon
     --  • don't crash if the body of the call or reply doesn't contain one bus name.
-    (rawCall, _) <- maybeCall
-    guard (formatMemberName (methodCallMember rawCall) == "GetNameOwner")
-    ownedName <- fromVariant (head (methodCallBody rawCall))
-    return $ bustlifyNOC ( ownedName
+    call <- MaybeT . return $ B.deReceivedMessage <$> maybeCall
+    member <- MaybeT . return $ messageMember call
+    guard (formatMemberName member == "GetNameOwner")
+    ownedName <- MaybeT $ messageGetBodyString call 0
+    owner <- MaybeT $ messageGetBodyString reply 0
+    return $ bustlifyNOC ( busName_ ownedName
                          , Nothing
-                         , fromVariant (head (methodReturnBody mr))
+                         , Just $ busName_ owner
                          )
 
 bustlify :: MonadState PendingMessages m
          => B.Microseconds
          -> Int
-         -> ReceivedMessage
+         -> GDBusMessage
          -> m B.DetailedEvent
 bustlify µs bytes m = do
     bm <- buildBustledMessage
     return $ B.Detailed µs bm bytes m
   where
-    sender = receivedMessageSender m
+    sender = messageSender m
     -- FIXME: can we do away with the un-Maybe-ing and just push that Nothing
     -- means 'the monitor' downwards? Or skip the message if sender is Nothing.
     wrappedSender = convertBusName "sen.der" sender
 
-    buildBustledMessage = case m of
-        (ReceivedMethodCall serial mc) -> do
+    buildBustledMessage = case messageType m of
+        MessageTypeMethodCall -> do
             let call = B.MethodCall
-                             { B.serial = serialValue serial
+                             { B.serial = messageSerial m
                              , B.sender = wrappedSender
-                             , B.destination = convertBusName "method.call.destination" $ methodCallDestination mc
-                             , B.member = convertMember methodCallPath methodCallInterface methodCallMember mc
+                             , B.destination = convertBusName "method.call.destination" $ messageDestination m
+                             , B.member = convertMember m
                              }
             -- FIXME: we shouldn't need to construct almost the same thing here
             -- and 10 lines above maybe?
-            insertPending sender serial mc (B.Detailed µs call bytes m)
+            insertPending sender (messageSerial m) (B.Detailed µs call bytes m)
             return $ B.MessageEvent call
 
-        (ReceivedMethodReturn _serial mr) -> do
-            call <- popMatchingCall (methodReturnDestination mr) (methodReturnSerial mr)
+        MessageTypeMethodReturn -> do
+            call <- popMatchingCall (messageDestination m) (messageReplySerial m)
 
-            return $ case tryBustlifyGetNameOwnerReply call mr of
+            return $ case tryBustlifyGetNameOwnerReply call m of
                 Just noc -> B.NOCEvent noc
                 Nothing  -> B.MessageEvent $ B.MethodReturn
-                               { B.inReplyTo = fmap snd call
+                               { B.inReplyTo = call
                                , B.sender = wrappedSender
-                               , B.destination = convertBusName "method.return.destination" $ methodReturnDestination mr
+                               , B.destination = convertBusName "method.return.destination" $ messageDestination m
                                }
 
-        (ReceivedMethodError _serial e) -> do
-            call <- popMatchingCall (methodErrorDestination e) (methodErrorSerial e)
+        MessageTypeError -> do
+            call <- popMatchingCall (messageDestination m) (messageReplySerial m)
             return $ B.MessageEvent $ B.Error
-                        { B.inReplyTo = fmap snd call
+                        { B.inReplyTo = call
                         , B.sender = wrappedSender
-                        , B.destination = convertBusName "method.error.destination" $ methodErrorDestination e
+                        , B.destination = convertBusName "method.error.destination" $ messageDestination m
                         }
 
-        (ReceivedSignal _serial sig)
-            | Just names <- isNOC sender sig -> return $ B.NOCEvent $ bustlifyNOC names
-            | otherwise                      -> return $ B.MessageEvent $
+        MessageTypeSignal
+            | Just names <- isNOC sender m -> return $ B.NOCEvent $ bustlifyNOC names
+            | otherwise                    -> return $ B.MessageEvent $
                 B.Signal { B.sender = wrappedSender
-                         , B.member = convertMember signalPath (Just . signalInterface) signalMember sig
-                         , B.signalDestination = stupifyBusName <$> signalDestination sig
+                         , B.member = convertMember m
+                         , B.signalDestination = stupifyBusName <$> messageDestination m
                          }
 
         _ -> error "woah there! someone added a new message type."
 
 convert :: MonadState PendingMessages m
         => B.Microseconds
-        -> BS.ByteString
+        -> Int
+        -> GDBusMessage
         -> m (Either String B.DetailedEvent)
-convert µs body =
-    case unmarshal body of
-        Left e  -> return $ Left $ unmarshalErrorMessage e
-        Right m -> Right <$> bustlify µs (BS.length body) m
+convert µs bytes message = Right <$> bustlify µs bytes message
 
 readOne :: (MonadState s m, MonadIO m)
         => Reader
-        -> (B.Microseconds -> BS.ByteString -> m (Either e a))
+        -> (B.Microseconds -> Int -> GDBusMessage -> m (Either e a))
         -> m (Maybe (Either e a))
 readOne p f = do
     ret <- liftIO $ readerReadOne p
     case ret of
         Nothing -> return Nothing
-        Just (µsec, body) -> Just <$> f µsec body
+        Just (µsec, bytes, body) -> Just <$> f µsec bytes body
 
 -- This shows up as the biggest thing on the heap profile. Which is kind of a
 -- surprise. It's supposedly the list.
 mapBodies :: (MonadState s m, MonadIO m)
           => Reader
-          -> (B.Microseconds -> BS.ByteString -> m (Either e a))
+          -> (B.Microseconds -> Int -> GDBusMessage -> m (Either e a))
           -> m [Either e a]
 mapBodies p f = do
     ret <- readOne p f
diff --git a/Bustle/Monitor.hs b/Bustle/Monitor.hs
index 9bd4f50..0977990 100644
--- a/Bustle/Monitor.hs
+++ b/Bustle/Monitor.hs
@@ -99,20 +99,20 @@ monitorStop :: Monitor
 monitorStop monitor =
     withForeignPtr (unMonitor monitor) bustle_pcap_monitor_stop
 
-messageLoggedHandler :: (Microseconds -> BS.ByteString -> IO ())
+messageLoggedHandler :: (Microseconds -> Int -> GDBusMessage -> IO ())
                      -> a
                      -> CLong
                      -> CLong
                      -> Ptr CChar
                      -> CUInt
-                     -> GDBusMessage
+                     -> Ptr GDBusMessage
                      -> IO ()
-messageLoggedHandler user _obj sec usec blob blobLength _message = do
-    blobBS <- BS.packCStringLen (blob, fromIntegral blobLength)
+messageLoggedHandler user _obj sec usec _blob blobLength messagePtr = do
     let µsec = fromIntegral sec * (10 ^ (6 :: Int)) + fromIntegral usec
-    failOnGError $ user µsec blobBS
+    message <- makeNewGDBusMessage (return messagePtr)
+    failOnGError $ user µsec (fromIntegral blobLength) message
 
-monitorMessageLogged :: Signal Monitor (Microseconds -> BS.ByteString -> IO ())
+monitorMessageLogged :: Signal Monitor (Microseconds -> Int -> GDBusMessage -> IO ())
 monitorMessageLogged =
     Signal $ \after_ obj user ->
         connectGeneric "message-logged" after_ obj $ messageLoggedHandler user
diff --git a/Bustle/Reader.hs b/Bustle/Reader.hs
index ae9a611..6a0b519 100644
--- a/Bustle/Reader.hs
+++ b/Bustle/Reader.hs
@@ -38,8 +38,6 @@ import Foreign.Marshal.Alloc
 import Foreign.Ptr
 import Foreign.Storable
 
-import qualified Data.ByteString as BS
-
 import System.Glib.GObject
 import System.Glib.GError
 
@@ -70,7 +68,7 @@ foreign import ccall "bustle_pcap_reader_read_one"
                                 -> Ptr CLong
                                 -> Ptr (Ptr CChar)
                                 -> Ptr CUInt
-                                -> Ptr GDBusMessage
+                                -> Ptr (Ptr GDBusMessage)
                                 -> Ptr (Ptr ())
                                 -> IO CInt
 
@@ -88,14 +86,16 @@ readerOpen filename =
           bustle_pcap_reader_open c_filename gerrorPtr
 
 readerReadOne :: Reader
-              -> IO (Maybe (Microseconds, BS.ByteString))
+              -> IO (Maybe (Microseconds, Int, GDBusMessage))
 readerReadOne reader =
     withForeignPtr (unReader reader) $ \c_reader ->
     alloca $ \secPtr ->
     alloca $ \usecPtr ->
     alloca $ \blobPtrPtr ->
-    alloca $ \lengthPtr -> do
-        propagateGError $ bustle_pcap_reader_read_one c_reader secPtr usecPtr blobPtrPtr lengthPtr nullPtr
+    alloca $ \lengthPtr ->
+    alloca $ \messagePtr -> do
+        poke messagePtr nullPtr
+        propagateGError $ bustle_pcap_reader_read_one c_reader secPtr usecPtr blobPtrPtr lengthPtr messagePtr
         blob <- peek blobPtrPtr
         if blob == nullPtr
             then return Nothing
@@ -103,9 +103,9 @@ readerReadOne reader =
                 sec <- peek secPtr
                 usec <- peek usecPtr
                 blobLength <- peek lengthPtr
-                blobBS <- BS.packCStringLen (blob, fromIntegral blobLength)
                 let µsec = fromIntegral sec * (10 ^ (6 :: Int)) + fromIntegral usec
-                return $ Just (µsec, blobBS)
+                message <- wrapNewGDBusMessage $ peek messagePtr
+                return $ Just (µsec, fromIntegral blobLength, message)
 
 readerClose :: Reader
             -> IO ()
diff --git a/Bustle/Types.hs b/Bustle/Types.hs
index 78306c4..36a4e8c 100644
--- a/Bustle/Types.hs
+++ b/Bustle/Types.hs
@@ -65,20 +65,12 @@ module Bustle.Types
   )
 where
 
-import Data.Word (Word32)
-import DBus ( ObjectPath, formatObjectPath
-            , InterfaceName, formatInterfaceName, interfaceName_
-            , MemberName, formatMemberName
-            , BusName, formatBusName, busName_
-            , ReceivedMessage
-            )
+import Bustle.GDBusMessage
 import Data.Maybe (maybeToList)
 import Data.Either (partitionEithers)
 import Data.Set (Set)
 import qualified Data.Set as Set
 
-type Serial = Word32
-
 newtype UniqueName = UniqueName BusName
   deriving (Ord, Show, Eq)
 newtype OtherName = OtherName BusName
@@ -195,7 +187,7 @@ data Detailed e =
     Detailed { deTimestamp :: Microseconds
              , deEvent :: e
              , deMessageSize :: MessageSize
-             , deReceivedMessage :: ReceivedMessage
+             , deReceivedMessage :: GDBusMessage
              }
   deriving (Show, Eq, Functor)
 
diff --git a/Bustle/UI.hs b/Bustle/UI.hs
index 7eda4f7..efcb8f7 100644
--- a/Bustle/UI.hs
+++ b/Bustle/UI.hs
@@ -41,6 +41,7 @@ import Bustle.Application.Monad
 import Bustle.Renderer
 import Bustle.Types
 import Bustle.Diagram
+import Bustle.GDBusMessage
 import qualified Bustle.Marquee as Marquee
 import Bustle.Monitor
 import Bustle.Util
@@ -284,9 +285,10 @@ recorderRun wi target filename r = C.handle newFailed $ do
     loaderStateRef <- newIORef Map.empty
     pendingRef <- newIORef []
 
-    let updateLabel µs body = do
+    let updateLabel :: Microseconds -> Int -> GDBusMessage -> IO ()
+        updateLabel µs l msg = do
             s <- readIORef loaderStateRef
-            (m, s') <- runStateT (convert µs body) s
+            (m, s') <- runStateT (convert µs l msg) s
             s' `seq` writeIORef loaderStateRef s'
 
             case m of
diff --git a/Bustle/UI/DetailsView.hs b/Bustle/UI/DetailsView.hs
index 820aff0..134038f 100644
--- a/Bustle/UI/DetailsView.hs
+++ b/Bustle/UI/DetailsView.hs
@@ -24,16 +24,11 @@ module Bustle.UI.DetailsView
   )
 where
 
-import Data.List (intercalate)
 import Graphics.UI.Gtk hiding (Signal)
 
-import qualified DBus as D
-import DBus.Internal.Message (MethodError(..))
-import DBus.Internal.Types (ErrorName(..))
-
 import Bustle.Types
 import Bustle.Marquee
-import Bustle.VariantFormatter
+import Bustle.GDBusMessage
 
 type OptionalRow = (Label, Label)
 
@@ -92,12 +87,11 @@ getDestination (Detailed _ m _ _) = case m of
     _                                -> Just (destination m)
 
 getErrorName :: Detailed a -> Maybe String
-getErrorName (Detailed _ _ _ rm) = case rm of
-    D.ReceivedMethodError _ MethodError{ methodErrorName = ErrorName en} -> Just en
-    _                                                                    -> Nothing
+getErrorName (Detailed _ _ _ m) = messageErrorName m
 
 formatMessage :: Detailed Message -> String
-formatMessage (Detailed _ _ _ rm) =
+formatMessage (Detailed _ _ _ m) = messagePrintBody m
+{- TODO reintroduce special case?
     case (rm, D.fromVariant <$> body) of
         -- Special-case errors, which (are supposed to) have a single
         -- human-readable string argument
@@ -106,6 +100,7 @@ formatMessage (Detailed _ _ _ rm) =
   where
     body = D.receivedMessageBody rm
     formatted = intercalate "\n" $ map (format_Variant VariantStyleSignature) body
+    -}
 
 detailsViewGetTop :: DetailsView -> Widget
 detailsViewGetTop = toWidget . detailsGrid
@@ -135,7 +130,7 @@ detailsViewUpdate d m = do
     setOptionalRow (detailsDestination d) (unBusName <$> getDestination m)
     setOptionalRow (detailsErrorName d) (getErrorName m)
 
-    labelSetText (detailsPath d) (maybe unknown (D.formatObjectPath . path) member_)
+    labelSetText (detailsPath d) (maybe unknown (formatObjectPath . path) member_)
     labelSetMarkup (detailsMember d) (maybe unknown getMemberMarkup member_)
     textBufferSetText buf (formatMessage m)
   where
diff --git a/Bustle/VariantFormatter.hs b/Bustle/VariantFormatter.hs
deleted file mode 100644
index 4fd730d..0000000
--- a/Bustle/VariantFormatter.hs
+++ /dev/null
@@ -1,150 +0,0 @@
-{-
-Bustle.VariantFormatter: produces GVariant strings representing D-Bus values
-Copyright © 2011 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
--}
-module Bustle.VariantFormatter
-  ( format_Variant
-  , VariantStyle(..)
-  )
-where
-
-import Data.Word
-import Data.Int
-import Data.List (intercalate)
-import Data.Char (chr, isPrint)
--- :'(
-import Data.Maybe (fromJust)
-
-import DBus
-
-format_Bool :: Bool -> String
-format_Bool = show
-
-format_Word8 :: Word8 -> String
-format_Word8 = show
-
-format_ByteArray :: Array -> String
-format_ByteArray ay =
-    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
-format_Int16 = show
-format_Int32 :: Int32 -> String
-format_Int32 = show
-format_Int64 :: Int64 -> String
-format_Int64 = show
-
-format_Word16 :: Word16 -> String
-format_Word16 = show
-format_Word32 :: Word32 -> String
-format_Word32 = show
-format_Word64 :: Word64 -> String
-format_Word64 = show
-
-format_Double :: Double -> String
-format_Double = show
-
-format_String :: String -> String
-format_String = show
-
-format_Signature :: Signature -> String
-format_Signature = show . formatSignature
-
-format_ObjectPath :: ObjectPath -> String
-format_ObjectPath = show . formatObjectPath
-
-format_Array :: Array -> String
-format_Array a = "[" ++ intercalate ", " items ++ "]"
-  where
-    items = map (format_Variant VariantStyleBare) $ arrayItems a
-
-format_Dictionary :: Dictionary -> String
-format_Dictionary d = "{" ++ intercalate ", " items ++ "}"
-  where
-    items = map (\(k, v) -> format_Variant VariantStyleBare k ++ ": " ++ format_Variant VariantStyleBare v) $ dictionaryItems d
-
--- FIXME…
-format_Structure :: Structure -> String
-format_Structure s = case structureItems s of
-    []  -> "()"
-    [v] -> "(" ++ format_Variant VariantStyleBare v ++ ",)"
-    vs  -> "(" ++ intercalate ", " items ++ ")"
-      where
-        items = map (format_Variant VariantStyleBare) vs
-
-data VariantStyle =
-    VariantStyleBare
-  | VariantStyleSignature
-  | VariantStyleAngleBrackets
-
--- why did you remove typeCode from the public API, John…
-typeCode :: Type -> String
-typeCode TypeBoolean    = "b"
-typeCode TypeWord8      = "y"
-typeCode TypeWord16     = "q"
-typeCode TypeWord32     = "u"
-typeCode TypeWord64     = "t"
-typeCode TypeInt16      = "n"
-typeCode TypeInt32      = "i"
-typeCode TypeInt64      = "x"
-typeCode TypeDouble     = "d"
-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, "}"]
-typeCode (TypeStructure ts) = concat ["(", concatMap typeCode ts, ")"]
-
-format_Variant :: VariantStyle -> Variant -> String
-format_Variant style v =
-    case style of
-      VariantStyleBare -> formatted
-      VariantStyleSignature -> typeSignature ++ " " ++ formatted
-      VariantStyleAngleBrackets -> "<" ++ typeSignature ++ " " ++ formatted ++ ">"
-  where
-    ty = variantType v
-    typeSignature = ('@':) . typeCode $ ty
-    format = case ty of
-        TypeBoolean -> format_Bool . fromJust . fromVariant
-        TypeInt16 -> format_Int16 . fromJust . fromVariant
-        TypeInt32 -> format_Int32 . fromJust . fromVariant
-        TypeInt64 -> format_Int64 . fromJust . fromVariant
-        TypeWord8 -> format_Word8 . fromJust . fromVariant
-        TypeWord16 -> format_Word16 . fromJust . fromVariant
-        TypeWord32 -> format_Word32 . fromJust . fromVariant
-        TypeWord64 -> format_Word64 . fromJust . fromVariant
-        TypeDouble -> format_Double . fromJust . fromVariant
-        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
-        TypeDictionary _ _ -> format_Dictionary . fromJust . fromVariant
-        TypeStructure _ -> format_Structure . fromJust . fromVariant
-    formatted = format v
diff --git a/Test/Renderer.hs b/Test/Renderer.hs
index 388c849..45defc0 100644
--- a/Test/Renderer.hs
+++ b/Test/Renderer.hs
@@ -13,10 +13,10 @@ import qualified Data.Set as Set
 import Data.Monoid
 import Data.List
 import System.Exit (exitFailure)
-import DBus (objectPath_, busName_, ReceivedMessage(ReceivedMethodReturn), firstSerial, methodReturn)
 
 import Bustle.Types
 import Bustle.Renderer
+import Bustle.GDBusMessage
 
 main :: IO ()
 main = defaultMain tests
@@ -39,9 +39,18 @@ main = defaultMain tests
 -- disconnect from the bus before the end of the log. This is a regression test
 -- for a bug I almost introduced.
 activeService = UniqueName ":1.1"
-dummyReceivedMessage = ReceivedMethodReturn firstSerial (methodReturn firstSerial)
-swaddle messages timestamps = map (\(e, ts) -> Detailed ts e 0 dummyReceivedMessage)
-                                  (zip messages timestamps)
+dummyReceivedMessage :: IO GDBusMessage
+dummyReceivedMessage = messageNewSignal o i m
+  where
+    o = objectPath_ "/"
+    i = interfaceName_ "com.example"
+    m = memberName_ "Signal"
+
+swaddle :: [Event] -> [Microseconds] -> IO [DetailedEvent]
+swaddle messages timestamps = forM (zip messages timestamps) $ \(e, ts) -> do
+    m <- dummyReceivedMessage
+    return $ Detailed ts e 0 m
+
 sessionLogWithoutDisconnect =
     [ NOCEvent $ Connected activeService
     , MessageEvent $ Signal (U activeService) Nothing $ Member (objectPath_ "/") Nothing "Hello"
@@ -49,10 +58,12 @@ sessionLogWithoutDisconnect =
 sessionLogWithDisconnect = sessionLogWithoutDisconnect ++ [ NOCEvent $ Disconnected activeService ]
 expectedParticipants = [ (activeService, Set.empty) ]
 
-test_ l expected = expected @=? ps
-  where
-    rr = process (swaddle l [1..]) []
-    ps = sessionParticipants (rrApplications rr)
+-- test_ :: a -> b -> Assertion
+test_ l expected = do
+    events <- swaddle l [1..]
+    let rr = process events []
+    let ps = sessionParticipants (rrApplications rr)
+    expected @=? ps
 
 test_participants = test_ sessionLogWithoutDisconnect expectedParticipants
 test_participants_with_disconnect = test_ sessionLogWithDisconnect expectedParticipants
@@ -73,7 +84,10 @@ bareLog = [ NOCEvent $ Connected u1
           ++ map (\o -> NOCEvent (NameChanged o (Claimed u2))) os ++
           [ MessageEvent $ MethodCall 0 (U u1) (O (head os)) m ]
 
+sessionLog :: IO [DetailedEvent]
 sessionLog = swaddle bareLog [1,3..]
+
+systemLog :: IO [DetailedEvent]
 systemLog  = swaddle bareLog [2,4..]
 
 test_incremental_simple :: (Show b, Eq b)
@@ -100,13 +114,19 @@ test_incremental :: (  RendererResult Participants
                     -> Assertion
                     )
                  -> Assertion
-test_incremental f = f fullRR incrementalRR
+test_incremental f = do
+    events <- sessionLog
+    let full = fullRR events
+    let incremental = incrementalRR events
+    f full incremental
 
 -- TODO: it should be possible to make this work for side-by-side logs too.
 -- Currently it doesn't seem to...
-fullRR, incrementalRR :: RendererResult Participants
-fullRR = process sessionLog []
-incrementalRR = mconcat rrs
+fullRR, incrementalRR :: [DetailedEvent]
+                      -> RendererResult Participants
+fullRR events = process events []
+
+incrementalRR events = mconcat rrs
   where
     processOne m = state $ processSome [m] []
-    (rrs, _) = runState (mapM processOne sessionLog) rendererStateNew
+    (rrs, _) = runState (mapM processOne events) rendererStateNew
diff --git a/bustle.cabal b/bustle.cabal
index 7c7a921..7738994 100644
--- a/bustle.cabal
+++ b/bustle.cabal
@@ -81,6 +81,7 @@ Executable bustle
   Other-modules: Bustle.Application.Monad
                , Bustle.Diagram
                , Bustle.GDBusMessage
+               , Bustle.GVariant
                , Bustle.Loader
                , Bustle.Loader.Pcap
                , Bustle.Marquee
@@ -103,7 +104,6 @@ Executable bustle
                , Bustle.UI.RecordAddressDialog
                , Bustle.UI.Recorder
                , Bustle.Util
-               , Bustle.VariantFormatter
                , Paths_bustle
   autogen-modules: Paths_bustle
   default-language: Haskell2010
@@ -121,7 +121,6 @@ Executable bustle
                , bytestring
                , cairo
                , containers
-               , dbus >= 0.10
                , directory
                , filepath
                , glib
@@ -132,6 +131,7 @@ Executable bustle
                , process
                , text
                , time
+               , transformers
   if flag(hgettext)
     Build-Depends: hgettext >= 0.1.5
                  , setlocale
@@ -154,9 +154,9 @@ Executable dump-messages
   Build-Depends: base
                , bytestring
                , containers
-               , dbus >= 0.10
                , mtl
                , text
+               , transformers
 
   if flag(hgettext)
       Build-Depends: hgettext >= 0.1.5
@@ -172,16 +172,24 @@ Executable dump-messages
 Test-suite test-pcap-crash
     type: exitcode-stdio-1.0
     main-is: Test/PcapCrash.hs
-    other-modules: Bustle.Loader.Pcap
+    other-modules: Bustle.GDBusMessage
+                 , Bustle.GVariant
+                 , Bustle.Loader.Pcap
+                 , Bustle.Reader
                  , Bustle.Translation
                  , Bustle.Types
     default-language: Haskell2010
     Build-Depends: base
                  , bytestring
                  , containers
-                 , dbus >= 0.10
+                 , glib
                  , mtl
                  , text
+                 , transformers
+    C-sources: c-sources/pcap-reader.c
+    pkgconfig-depends: glib-2.0 >= 2.54,
+                       gio-unix-2.0
+    extra-libraries: pcap
     if flag(hgettext)
         Build-Depends: hgettext >= 0.1.5
                      , setlocale
@@ -205,6 +213,8 @@ Test-suite test-renderer
     type: exitcode-stdio-1.0
     main-is: Test/Renderer.hs
     other-modules: Bustle.Diagram
+                 , Bustle.GDBusMessage
+                 , Bustle.GVariant
                  , Bustle.Marquee
                  , Bustle.Regions
                  , Bustle.Renderer
@@ -212,21 +222,20 @@ Test-suite test-renderer
                  , Bustle.Types
                  , Bustle.Util
 
-
-
     default-language: Haskell2010
     Build-Depends: base
                  , cairo
                  , containers
-                 , dbus >= 0.10
                  , directory
                  , filepath
+                 , glib
                  , gtk3
                  , mtl
                  , text
                  , pango
                  , test-framework
                  , test-framework-hunit
+                 , transformers
                  , HUnit
     if flag(hgettext)
         Build-Depends: hgettext >= 0.1.5