160 lines
4.7 KiB
Haskell
160 lines
4.7 KiB
Haskell
{- 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 Utility.ThreadScheduler
|
|
import Utility.Mounts
|
|
|
|
import Control.Concurrent
|
|
import qualified Control.Exception as E
|
|
import qualified Data.Set as S
|
|
|
|
#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 -> 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 = 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 handle 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 handle
|
|
|
|
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
|
|
if null running
|
|
then startOneService client startableservices
|
|
else do
|
|
debug thisThread [ "Using running DBUS service"
|
|
, Prelude.head running
|
|
, "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 -> 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 -> Mntent -> IO ()
|
|
handleMount st handle mntent = do
|
|
debug thisThread ["detected mount of", mnt_dir mntent]
|
|
|
|
type MountPoints = S.Set Mntent
|
|
|
|
{- Reads mtab, getting the current set of mount points. -}
|
|
currentMountPoints :: IO MountPoints
|
|
currentMountPoints = S.fromList <$> getMounts
|
|
|
|
{- Finds new mount points, given an old and a new set. -}
|
|
newMountPoints :: MountPoints -> MountPoints -> MountPoints
|
|
newMountPoints old new = S.difference new old
|