1 files changed, 210 insertions, 0 deletions
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
new file mode 100644
index 000000000..83f582a91
--- /dev/null
+++ b/Assistant/Threads/MountWatcher.hs
@@ -0,0 +1,210 @@
+{- 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 Assistant.Common
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.Threads.Pusher (pushToRemotes)
+import Assistant.Alert
+import qualified Annex
+import qualified Git
+import Utility.ThreadScheduler
+import Utility.Mounts
+import Remote.List
+import qualified Types.Remote as Remote
+import Assistant.Threads.Merger
+import qualified Git.Branch
+
+import Control.Concurrent
+import qualified Control.Exception as E
+import qualified Data.Set as S
+import Data.Time.Clock
+
+#if WITH_DBUS
+import DBus.Client
+import DBus
+import Data.Word (Word32)
+#else
+#warning Building without dbus support; will use mtab polling
+#endif
+
+thisThread :: ThreadName
+thisThread = "MountWatcher"
+
+mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
+mountWatcherThread st handle scanremotes =
+#if WITH_DBUS
+	dbusThread st handle scanremotes
+#else
+	pollingThread st handle scanremotes
+#endif
+
+#if WITH_DBUS
+
+dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
+dbusThread st dstatus scanremotes = E.catch (go =<< connectSession) onerr
+	where
+		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
+				forM_ mountAdded $ \matcher ->
+					listen client matcher $ \_event -> do
+						nowmounted <- currentMountPoints
+						wasmounted <- swapMVar mvar nowmounted
+						handleMounts st dstatus scanremotes wasmounted nowmounted
+			, do
+				runThreadState st $
+					warning "No known volume monitor available through dbus; falling back to mtab polling"
+				pollinstead
+			)
+		onerr :: E.SomeException -> IO ()
+		onerr e = do
+			runThreadState st $
+				warning $ "Failed to use dbus; falling back to mtab polling (" ++ show e ++ ")"
+			pollinstead
+		pollinstead = pollingThread st dstatus scanremotes
+
+type ServiceName = String
+
+listServiceNames :: Client -> IO [ServiceName]
+listServiceNames client = do
+	reply <- callDBus client "ListNames" []
+	return $ fromMaybe [] $ fromVariant (methodReturnBody reply !! 0)
+
+callDBus :: Client -> MemberName -> [Variant] -> IO MethodReturn
+callDBus client name params = call_ client $
+	(methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" name)
+		{ methodCallDestination = Just "org.freedesktop.DBus"
+		, methodCallBody = params
+		}
+
+{- Examine the list of services connected to dbus, to see if there
+ - are any we can use to monitor mounts. If not, will attempt to start one. -}
+checkMountMonitor :: Client -> IO Bool
+checkMountMonitor client = do
+	running <- filter (`elem` usableservices)
+		<$> listServiceNames client
+	case running of
+		[] -> startOneService client startableservices
+		(service:_) -> do
+			debug thisThread [ "Using running DBUS service"
+				, service
+				, "to monitor mount events."
+				]
+			return True
+	where
+		startableservices = [gvfs]
+		usableservices = startableservices ++ [kde]
+		gvfs = "org.gtk.Private.GduVolumeMonitor"
+		kde = "org.kde.DeviceNotifications"
+
+startOneService :: Client -> [ServiceName] -> IO Bool
+startOneService _ [] = return False
+startOneService client (x:xs) = do
+	_ <- callDBus client "StartServiceByName"
+		[toVariant x, toVariant (0 :: Word32)]
+	ifM (elem x <$> listServiceNames client)
+		( do
+			debug thisThread [ "Started DBUS service"
+				, x
+				, "to monitor mount events."
+				]
+			return True
+		, startOneService client xs
+		)
+
+{- Filter matching events recieved when drives are mounted. -}	
+mountAdded :: [MatchRule]
+mountAdded = [gvfs, kde]
+	where
+		gvfs = matchAny
+			{ matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor"
+			, matchMember = Just "MountAdded"
+			}
+		kde = matchAny
+			{ matchInterface = Just "org.kde.Solid.Device"
+			, matchMember = Just "setupDone"
+			}
+
+#endif
+
+pollingThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
+pollingThread st dstatus scanremotes = go =<< currentMountPoints
+	where
+		go wasmounted = do
+			threadDelaySeconds (Seconds 10)
+			nowmounted <- currentMountPoints
+			handleMounts st dstatus scanremotes wasmounted nowmounted
+			go nowmounted
+
+handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> MountPoints -> MountPoints -> IO ()
+handleMounts st dstatus scanremotes wasmounted nowmounted =
+	mapM_ (handleMount st dstatus scanremotes . mnt_dir) $
+		S.toList $ newMountPoints wasmounted nowmounted
+
+handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> FilePath -> IO ()
+handleMount st dstatus scanremotes dir = do
+	debug thisThread ["detected mount of", dir]
+	rs <- remotesUnder st dstatus dir
+	unless (null rs) $ do
+		let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs
+		unless (null nonspecial) $ do
+			void $ alertWhile dstatus (syncAlert nonspecial) $ do
+				debug thisThread ["syncing with", show rs]
+				sync nonspecial =<< runThreadState st (inRepo Git.Branch.current)
+			addScanRemotes scanremotes nonspecial
+	where
+		sync rs (Just branch) = do
+			runThreadState st $ manualPull (Just branch) rs
+			now <- getCurrentTime	
+			pushToRemotes thisThread now st Nothing rs
+		{- No local branch exists yet, but we can try pulling. -}
+		sync rs Nothing = do
+			runThreadState st $ manualPull Nothing rs
+			return True
+
+{- Finds remotes located underneath the mount point.
+ -
+ - Updates state to include the remotes.
+ -
+ - The config of git remotes is re-read, as it may not have been available
+ - at startup time, or may have changed (it could even be a different
+ - repository at the same remote location..)
+ -}
+remotesUnder :: ThreadState -> DaemonStatusHandle -> FilePath -> IO [Remote]
+remotesUnder st dstatus dir = runThreadState st $ do
+	repotop <- fromRepo Git.repoPath
+	rs <- remoteList
+	pairs <- mapM (checkremote repotop) rs
+	let (waschanged, rs') = unzip pairs
+	when (any id waschanged) $ do
+		Annex.changeState $ \s -> s { Annex.remotes = rs' }
+		updateKnownRemotes dstatus
+	return $ map snd $ filter fst pairs
+	where
+		checkremote repotop r = case Remote.path r of
+			Just p | dirContains dir (absPathFrom repotop p) ->
+				(,) <$> pure True <*> updateRemote r
+			_ -> return (False, r)
+
+type MountPoints = S.Set Mntent
+
+currentMountPoints :: IO MountPoints
+currentMountPoints = S.fromList <$> getMounts
+
+newMountPoints :: MountPoints -> MountPoints -> MountPoints
+newMountPoints old new = S.difference new old