blob: f3b9c0a3a7c6ce79e7b6200136e2d91a781a1517 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
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
|
