MountWatcher thread

Currently only prints mount points when mounts happen.

1 files changed, 89 insertions, 0 deletions

diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
new file mode 100644
index 000000000..f3b9c0a3a
--- /dev/null
+++ b/Assistant/Threads/MountWatcher.hs
@@ -0,0 +1,89 @@
+{- git-annex assistant mount watcher, using either dbus or mtab polling
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Assistant.Threads.MountWatcher where
+
+import Common.Annex
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Utility.ThreadScheduler
+import Utility.Mounts
+
+import Control.Concurrent
+import qualified Data.Set as S
+
+#if WITH_DBUS
+import DBus.Client
+#else
+#warning Building without dbus support; will use mtab polling
+#endif
+
+mountWatcherThread :: ThreadState -> DaemonStatusHandle -> IO ()
+mountWatcherThread st handle =
+#if WITH_DBUS
+	dbusThread st handle
+#else
+	pollingThread 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)
+	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
+
+#endif
+
+pollingThread :: ThreadState -> DaemonStatusHandle -> IO ()
+pollingThread st handle = go =<< currentMountPoints
+	where
+		go wasmounted = do
+			threadDelaySeconds (Seconds 10)
+			nowmounted <- currentMountPoints
+			handleMounts st handle wasmounted nowmounted
+			go nowmounted
+
+handleMounts :: ThreadState -> DaemonStatusHandle -> MountPoints -> MountPoints -> IO ()
+handleMounts st handle wasmounted nowmounted = mapM_ (handleMount st handle) $
+	S.toList $ newMountPoints wasmounted nowmounted
+
+handleMount :: ThreadState -> DaemonStatusHandle -> FilePath -> IO ()
+handleMount st handle mountpoint = do
+	putStrLn $ "mounted: " ++ mountpoint
+
+type MountPoints = S.Set FilePath
+
+{- Reads mtab, getting the current set of mount points. -}
+currentMountPoints :: IO MountPoints
+currentMountPoints = S.fromList . map mnt_dir <$> read_mtab
+
+{- Finds new mount points, given an old and a new set. -}
+newMountPoints :: MountPoints -> MountPoints -> MountPoints
+newMountPoints old new = S.difference new old