MountWatcher thread

Currently only prints mount points when mounts happen.

Assistant.hs

@@ -46,6 +46,11 @@
  - 	Wakes up periodically and records the daemon's status to disk.
  - Thread 12: sanity checker
  - 	Wakes up periodically (rarely) and does sanity checks.
+ - Thread 13: mount watcher
+ - 	Either uses dbus to watch for drive mount events, or, when
+ - 	there's no dbus, polls to find newly mounted filesystems.
+ - 	Once a filesystem that contains a remote is mounted, syncs
+ - 	with it.
  -
  - ThreadState: (MVar)
  - 	The Annex state is stored here, which allows resuscitating the
@@ -92,6 +97,7 @@ import Assistant.Threads.Merger
 import Assistant.Threads.TransferWatcher
 import Assistant.Threads.Transferrer
 import Assistant.Threads.SanityChecker
+import Assistant.Threads.MountWatcher
 import qualified Utility.Daemon
 import Utility.LogFile
 import Utility.ThreadScheduler
@@ -127,6 +133,7 @@ startDaemon assistant foreground
 				, transfererThread st dstatus transferqueue transferslots
 				, daemonStatusThread st dstatus
 				, sanityCheckerThread st dstatus transferqueue changechan
+				, mountWatcherThread st dstatus
 				, watchThread st dstatus transferqueue changechan
 				]
 			waitForTermination

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

Assistant/Threads/Watcher.hs

@@ -5,8 +5,6 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
-
 module Assistant.Threads.Watcher where
 
 import Common.Annex

Makefile

@@ -1,11 +1,11 @@
 bins=git-annex
 mans=git-annex.1 git-annex-shell.1
-sources=Build/SysConfig.hs Utility/Touch.hs
+sources=Build/SysConfig.hs Utility/Touch.hs Utility/Mounts.hs
 all=$(bins) $(mans) docs
 
 OS:=$(shell uname | sed 's/[-_].*//')
 ifeq ($(OS),Linux)
-BASEFLAGS_OPTS+=-DWITH_INOTIFY
+BASEFLAGS_OPTS+=-DWITH_INOTIFY -DWITH_DBUS
 clibs=Utility/libdiskfree.o
 else
 BASEFLAGS_OPTS+=-DWITH_KQUEUE

debian/control

@@ -22,6 +22,7 @@ Build-Depends:
 	libghc-edit-distance-dev,
 	libghc-hinotify-dev [linux-any],
 	libghc-stm-dev (>= 2.3),
+	libghc-dbus-dev,
 	ikiwiki,
 	perlmagick,
 	git,

git-annex.cabal

@@ -31,6 +31,9 @@ Flag S3
 Flag Inotify
   Description: Enable inotify support
 
+Flag Dbus
+  Description: Enable dbus support
+
 Flag Assistant
   Description: Enable git-annex assistant and watch command
 
@@ -41,8 +44,8 @@ Executable git-annex
    pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP,
    base == 4.5.*, monad-control, transformers-base, lifted-base,
    IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process
-  -- Need to list this because it's generated from a .hsc file.
-  Other-Modules: Utility.Touch
+  -- Need to list these because they're generated from .hsc files.
+  Other-Modules: Utility.Touch Utility.Mounts
   C-Sources: Utility/libdiskfree.c
   Extensions: CPP
   GHC-Options: -threaded
@@ -59,6 +62,10 @@ Executable git-annex
     Build-Depends: hinotify
     CPP-Options: -DWITH_INOTIFY
 
+  if flag(Dbus)
+    Build-Depends: dbus
+    CPP-Options: -DWITH_DBUS
+
 Test-Suite test
   Type: exitcode-stdio-1.0
   Main-Is: test.hs