diff options
author | 2012-07-19 23:34:33 -0400 | |
---|---|---|
committer | 2012-07-19 23:34:33 -0400 | |
commit | 6b4fe507f68427e0cb37e22f278c375151e8e89f (patch) | |
tree | 63abb559975643df9593814b1108ebf3be94f91c /Assistant/Threads | |
parent | 0496a3971d4679e6a482a5eb277091980383f831 (diff) |
only use dbus when there's a client connected we know will send mount events
Diffstat (limited to 'Assistant/Threads')
-rw-r--r-- | Assistant/Threads/MountWatcher.hs | 66 |
1 files changed, 44 insertions, 22 deletions
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index b55e3284b..f1e33a99f 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -21,6 +21,7 @@ import qualified Data.Set as S #if WITH_DBUS import DBus.Client +import DBus #else #warning Building without dbus support; will use mtab polling #endif @@ -34,30 +35,51 @@ mountWatcherThread st handle = #endif #if WITH_DBUS + dbusThread :: ThreadState -> DaemonStatusHandle -> IO () -dbusThread st handle = do - r <- tryIO connectSession - case r of - Left e -> do - print $ "Failed to connect to dbus; falling back to mtab polling (" ++ show e ++ ")" - pollingThread st handle - Right client -> do - {- Store the current mount points in an mvar, - - to be compared later. We could in theory work - - out the mount point from the dbus message, but - - this is easier. -} - mvar <- newMVar =<< currentMountPoints - -- Spawn a listener thread, and returns. - listen client mountadded (go mvar) +dbusThread st handle = (go =<< connectSession) `catchIO` onerr where - mountadded = matchAny - { matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor" - , matchMember = Just "MountAdded" - } - go mvar event = do - nowmounted <- currentMountPoints - wasmounted <- swapMVar mvar nowmounted - handleMounts st handle wasmounted nowmounted + go client = ifM (checkMountMonitor client) + ( do + {- Store the current mount points in an mvar, + - to be compared later. We could in theory + - work out the mount point from the dbus + - message, but this is easier. -} + mvar <- newMVar =<< currentMountPoints + listen client mountAdded $ \_event -> do + nowmounted <- currentMountPoints + wasmounted <- swapMVar mvar nowmounted + handleMounts st handle wasmounted nowmounted + , do + runThreadState st $ + warning "No known volume monitor available through dbus; falling back to mtab polling" + pollinstead + ) + onerr e = do + runThreadState st $ + warning $ "Failed to use dbus; falling back to mtab polling (" ++ show e ++ ")" + pollinstead + pollinstead = pollingThread st handle + +listClientNames :: Client -> IO [String] +listClientNames client = do + reply <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames") + { methodCallDestination = Just "org.freedesktop.DBus" } + return $ fromMaybe [] $ fromVariant (methodReturnBody reply !! 0) + +{- Examine the list of clients connected to dbus, to see if there + - are any we can use to monitor mounts. -} +checkMountMonitor :: Client -> IO Bool +checkMountMonitor client = any (`elem` knownclients) <$> listClientNames client + where + knownclients = ["org.gtk.Private.GduVolumeMonitor"] + +{- Filter matching events recieved when drives are mounted. -} +mountAdded ::MatchRule +mountAdded = matchAny + { matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor" + , matchMember = Just "MountAdded" + } #endif |