Remove unsafePerformIO from GDBusMessage binding

This application doesn't expose any setters, but in principle
GDBusMessage is mutable so these functions are impure.

3 files changed, 76 insertions, 70 deletions

diff --git a/Bustle/GDBusMessage.hs b/Bustle/GDBusMessage.hs
index d556748..030c106 100644
--- a/Bustle/GDBusMessage.hs
+++ b/Bustle/GDBusMessage.hs
@@ -68,7 +68,6 @@ 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
@@ -222,30 +221,29 @@ messageNewSignal (ObjectPath o) (InterfaceName i) (MemberName m) =
     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 $
+            -> IO MessageType
+messageType message =
     withForeignPtr (unGDBusMessage message) $ \c_message ->
     toEnum <$> g_dbus_message_get_message_type c_message
 
 messageSerial :: GDBusMessage
-              -> Serial
-messageSerial message = unsafePerformIO $
+              -> IO Serial
+messageSerial message =
     withForeignPtr (unGDBusMessage message) $ \c_message ->
     g_dbus_message_get_serial c_message
 
 messageReplySerial :: GDBusMessage
-                   -> Serial
-messageReplySerial message = unsafePerformIO $
+                   -> IO Serial
+messageReplySerial message =
     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 $
+           -> IO (Maybe a)
+messageStr ctor f message =
     withForeignPtr (unGDBusMessage message) $ \c_message -> do
     c_str <- f c_message
     if c_str == nullPtr
@@ -253,27 +251,27 @@ messageStr ctor f message = unsafePerformIO $
         else Just . ctor <$> peekUTFString c_str
 
 messageSender :: GDBusMessage
-              -> Maybe BusName
+              -> IO (Maybe BusName)
 messageSender = messageStr BusName g_dbus_message_get_sender
 
 messageDestination :: GDBusMessage
-                   -> Maybe BusName
+                   -> IO (Maybe BusName)
 messageDestination = messageStr BusName g_dbus_message_get_destination
 
 messageErrorName :: GDBusMessage
-                 -> Maybe String
+                 -> IO (Maybe String)
 messageErrorName = messageStr id g_dbus_message_get_error_name
 
 messagePath :: GDBusMessage
-            -> Maybe ObjectPath
+            -> IO (Maybe ObjectPath)
 messagePath = messageStr ObjectPath g_dbus_message_get_path
 
 messageInterface :: GDBusMessage
-                 -> Maybe InterfaceName
+                 -> IO (Maybe InterfaceName)
 messageInterface = messageStr InterfaceName g_dbus_message_get_interface
 
 messageMember :: GDBusMessage
-              -> Maybe MemberName
+              -> IO (Maybe MemberName)
 messageMember = messageStr MemberName g_dbus_message_get_member
 
 messageGetBody :: GDBusMessage
@@ -285,8 +283,8 @@ messageGetBody message = do
         else Just <$> makeNewGVariant (return body)
 
 messagePrintBody :: GDBusMessage
-                 -> String
-messagePrintBody message = unsafePerformIO $ do
+                 -> IO String
+messagePrintBody message = do
     body <- messageGetBody message
     case body of
         Nothing -> return ""
diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs
index a10ee85..e82ea82 100644
--- a/Bustle/Loader/Pcap.hs
+++ b/Bustle/Loader/Pcap.hs
@@ -34,8 +34,6 @@ import Control.Exception (try)
 import Control.Monad.State
 import Control.Monad.Trans.Maybe
 
-import System.IO.Unsafe (unsafePerformIO)
-
 import System.Glib (GError)
 
 import qualified Bustle.Types as B
@@ -61,12 +59,15 @@ convertBusName fallback n =
   where
     fallback_ = busName_ fallback
 
-convertMember :: GDBusMessage
-              -> B.Member
-convertMember m =
-    B.Member (fromMaybe (objectPath_ "") $ messagePath m)
-             (messageInterface m)
-             (fromMaybe (memberName_ "") $ messageMember m)
+convertMember :: MonadIO m
+              => GDBusMessage
+              -> m B.Member
+convertMember m = liftIO $ do
+    p <- fromMaybe (objectPath_ "") <$> messagePath m
+    i <- messageInterface m
+    member <- fromMaybe (memberName_ "") <$> messageMember m
+    return $ B.Member p i member
+
 
 type PendingMessages = Map (Maybe BusName, Serial)
                            (B.Detailed B.Message)
@@ -97,16 +98,19 @@ insertPending :: MonadState PendingMessages m
               -> m ()
 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
+isNOC :: MonadIO m
+      => Maybe BusName
+      -> GDBusMessage
+      -> m (Maybe (BusName, Maybe BusName, Maybe BusName))
+isNOC maybeSender message = liftIO $ runMaybeT $ do
     sender <- MaybeT . return $ maybeSender
     guard (sender == B.dbusName)
-    guard (messageType message == MessageTypeSignal)
-    iface <- MaybeT . return $ messageInterface message
+    type_ <- liftIO $ messageType message
+    guard (type_ == MessageTypeSignal)
+    iface <- MaybeT $ messageInterface message
     guard (iface == B.dbusInterface)
-    member <- MaybeT . return $ formatMemberName <$> messageMember message
-    guard (member == "NameOwnerChanged")
+    member <- MaybeT $ messageMember message
+    guard (formatMemberName member == "NameOwnerChanged")
     n <- MaybeT $ messageGetBodyString message 0
     old <- MaybeT $ messageGetBodyString message 1
     new <- MaybeT $ messageGetBodyString message 2
@@ -133,16 +137,16 @@ bustlifyNOC ns@(name, oldOwner, newOwner)
     uniquify = B.UniqueName
     otherify = B.OtherName
 
--- FIXME: IO
-tryBustlifyGetNameOwnerReply :: Maybe (B.Detailed a)
+tryBustlifyGetNameOwnerReply :: MonadIO m
+                             => Maybe (B.Detailed a)
                              -> GDBusMessage
-                             -> Maybe B.NOC
-tryBustlifyGetNameOwnerReply maybeCall reply = unsafePerformIO $ runMaybeT $ do
+                             -> m (Maybe B.NOC)
+tryBustlifyGetNameOwnerReply maybeCall reply = liftIO $ 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.
     call <- MaybeT . return $ B.deReceivedMessage <$> maybeCall
-    member <- MaybeT . return $ messageMember call
+    member <- MaybeT $ messageMember call
     guard (formatMemberName member == "GetNameOwner")
     ownedName <- MaybeT $ messageGetBodyString call 0
     owner <- MaybeT $ messageGetBodyString reply 0
@@ -151,63 +155,67 @@ tryBustlifyGetNameOwnerReply maybeCall reply = unsafePerformIO $ runMaybeT $ do
                          , Just $ busName_ owner
                          )
 
-bustlify :: MonadState PendingMessages m
+bustlify :: (MonadIO m, MonadState PendingMessages m)
          => B.Microseconds
          -> Int
          -> GDBusMessage
          -> m B.DetailedEvent
 bustlify µs bytes m = do
-    bm <- buildBustledMessage
-    return $ B.Detailed µs bm bytes m
-  where
-    sender = messageSender m
+    sender <- liftIO $ 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 messageType m of
+    let wrappedSender = convertBusName "sen.der" sender
+    serial <- liftIO $ messageSerial m
+    replySerial <- liftIO $ messageReplySerial m
+    destination <- liftIO $ messageDestination m
+
+    let detailed x = B.Detailed µs x bytes m
+    type_ <- liftIO $ messageType m
+    detailed <$> case type_ of
         MessageTypeMethodCall -> do
+            member <- convertMember m
             let call = B.MethodCall
-                             { B.serial = messageSerial m
+                             { B.serial = serial
                              , B.sender = wrappedSender
-                             , B.destination = convertBusName "method.call.destination" $ messageDestination m
-                             , B.member = convertMember m
+                             , B.destination = convertBusName "method.call.destination" destination
+                             , B.member = member
                              }
-            -- FIXME: we shouldn't need to construct almost the same thing here
-            -- and 10 lines above maybe?
-            insertPending sender (messageSerial m) (B.Detailed µs call bytes m)
+            insertPending sender serial (detailed call)
             return $ B.MessageEvent call
 
         MessageTypeMethodReturn -> do
-            call <- popMatchingCall (messageDestination m) (messageReplySerial m)
-
-            return $ case tryBustlifyGetNameOwnerReply call m of
+            call <- popMatchingCall destination replySerial
+            noc_ <- tryBustlifyGetNameOwnerReply call m
+            return $ case noc_ of
                 Just noc -> B.NOCEvent noc
                 Nothing  -> B.MessageEvent $ B.MethodReturn
                                { B.inReplyTo = call
                                , B.sender = wrappedSender
-                               , B.destination = convertBusName "method.return.destination" $ messageDestination m
+                               , B.destination = convertBusName "method.return.destination" destination
                                }
 
         MessageTypeError -> do
-            call <- popMatchingCall (messageDestination m) (messageReplySerial m)
+            call <- popMatchingCall destination replySerial
             return $ B.MessageEvent $ B.Error
                         { B.inReplyTo = call
                         , B.sender = wrappedSender
-                        , B.destination = convertBusName "method.error.destination" $ messageDestination m
+                        , B.destination = convertBusName "method.error.destination" destination
                         }
 
-        MessageTypeSignal
-            | Just names <- isNOC sender m -> return $ B.NOCEvent $ bustlifyNOC names
-            | otherwise                    -> return $ B.MessageEvent $
-                B.Signal { B.sender = wrappedSender
-                         , B.member = convertMember m
-                         , B.signalDestination = stupifyBusName <$> messageDestination m
-                         }
+        MessageTypeSignal -> do
+            names_ <- isNOC sender m
+            member <- convertMember m
+            return $ case names_ of
+                Just names -> B.NOCEvent $ bustlifyNOC names
+                Nothing    -> B.MessageEvent $
+                    B.Signal { B.sender = wrappedSender
+                             , B.member = member
+                             , B.signalDestination = stupifyBusName <$> destination
+                             }
 
         _ -> error "woah there! someone added a new message type."
 
-convert :: MonadState PendingMessages m
+convert :: (MonadIO m, MonadState PendingMessages m)
         => B.Microseconds
         -> Int
         -> GDBusMessage
diff --git a/Bustle/UI/DetailsView.hs b/Bustle/UI/DetailsView.hs
index 134038f..e1fa995 100644
--- a/Bustle/UI/DetailsView.hs
+++ b/Bustle/UI/DetailsView.hs
@@ -86,10 +86,10 @@ getDestination (Detailed _ m _ _) = case m of
     Signal { signalDestination = d } -> d
     _                                -> Just (destination m)
 
-getErrorName :: Detailed a -> Maybe String
+getErrorName :: Detailed a -> IO (Maybe String)
 getErrorName (Detailed _ _ _ m) = messageErrorName m
 
-formatMessage :: Detailed Message -> String
+formatMessage :: Detailed Message -> IO String
 formatMessage (Detailed _ _ _ m) = messagePrintBody m
 {- TODO reintroduce special case?
     case (rm, D.fromVariant <$> body) of
@@ -128,10 +128,10 @@ detailsViewUpdate d m = do
     -- to/from well-known names and show both
     labelSetText (detailsSender d) (unBusName . sender . deEvent $ m)
     setOptionalRow (detailsDestination d) (unBusName <$> getDestination m)
-    setOptionalRow (detailsErrorName d) (getErrorName m)
+    setOptionalRow (detailsErrorName d) =<< getErrorName m
 
     labelSetText (detailsPath d) (maybe unknown (formatObjectPath . path) member_)
     labelSetMarkup (detailsMember d) (maybe unknown getMemberMarkup member_)
-    textBufferSetText buf (formatMessage m)
+    textBufferSetText buf =<< formatMessage m
   where
     unknown = ""