converted 2 more threads.. only 2 more to go
This commit is contained in:
parent
0ba4df3c1a
commit
3eecb5b7bb
3 changed files with 126 additions and 132 deletions
|
@ -199,12 +199,12 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
|
|||
, assist $ pushThread
|
||||
, assist $ pushRetryThread
|
||||
, assist $ mergeThread
|
||||
, assist $ transferWatcherThread st dstatus transferqueue
|
||||
, assist $ transferWatcherThread
|
||||
, assist $ transferPollerThread
|
||||
, assist $ transfererThread st dstatus transferqueue transferslots commitchan
|
||||
, assist $ daemonStatusThread
|
||||
, assist $ sanityCheckerThread
|
||||
, assist $ mountWatcherThread st dstatus scanremotes pushnotifier
|
||||
, assist $ mountWatcherThread
|
||||
, assist $ netWatcherThread
|
||||
, assist $ netWatcherFallbackThread
|
||||
, assist $ transferScannerThread
|
||||
|
|
|
@ -11,11 +11,8 @@
|
|||
module Assistant.Threads.MountWatcher where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.Sync
|
||||
import Assistant.Pushes
|
||||
import qualified Annex
|
||||
import qualified Git
|
||||
import Utility.ThreadScheduler
|
||||
|
@ -39,61 +36,61 @@ import qualified Control.Exception as E
|
|||
thisThread :: ThreadName
|
||||
thisThread = "MountWatcher"
|
||||
|
||||
mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> NamedThread
|
||||
mountWatcherThread st handle scanremotes pushnotifier = thread $ liftIO $
|
||||
mountWatcherThread :: NamedThread
|
||||
mountWatcherThread = NamedThread "MountWatcher" $
|
||||
#if WITH_DBUS
|
||||
dbusThread st handle scanremotes pushnotifier
|
||||
dbusThread
|
||||
#else
|
||||
pollingThread st handle scanremotes pushnotifier
|
||||
pollingThread
|
||||
#endif
|
||||
where
|
||||
thread = NamedThread thisThread
|
||||
|
||||
#if WITH_DBUS
|
||||
|
||||
dbusThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO ()
|
||||
dbusThread st dstatus scanremotes pushnotifier =
|
||||
E.catch (runClient getSessionAddress go) onerr
|
||||
dbusThread :: Assistant ()
|
||||
dbusThread = do
|
||||
runclient <- asIO go
|
||||
r <- liftIO $ E.try $ runClient getSessionAddress runclient
|
||||
either onerr (const noop) r
|
||||
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_ mountChanged $ \matcher ->
|
||||
listen client matcher $ \_event -> do
|
||||
nowmounted <- currentMountPoints
|
||||
wasmounted <- swapMVar mvar nowmounted
|
||||
handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted
|
||||
{- 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 <- liftIO $ newMVar =<< currentMountPoints
|
||||
handleevent <- asIO $ \_event -> do
|
||||
nowmounted <- liftIO $ currentMountPoints
|
||||
wasmounted <- liftIO $ swapMVar mvar nowmounted
|
||||
handleMounts wasmounted nowmounted
|
||||
liftIO $ forM_ mountChanged $ \matcher ->
|
||||
listen client matcher handleevent
|
||||
, do
|
||||
runThreadState st $
|
||||
liftAnnex $
|
||||
warning "No known volume monitor available through dbus; falling back to mtab polling"
|
||||
pollinstead
|
||||
pollingThread
|
||||
)
|
||||
onerr :: E.SomeException -> IO ()
|
||||
onerr :: E.SomeException -> Assistant ()
|
||||
onerr e = do
|
||||
{- If the session dbus fails, the user probably
|
||||
- logged out of their desktop. Even if they log
|
||||
- back in, we won't have access to the dbus
|
||||
- session key, so polling is the best that can be
|
||||
- done in this situation. -}
|
||||
runThreadState st $
|
||||
liftAnnex $
|
||||
warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
|
||||
pollinstead
|
||||
pollinstead = pollingThread st dstatus scanremotes pushnotifier
|
||||
pollingThread
|
||||
|
||||
{- 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 -> Assistant Bool
|
||||
checkMountMonitor client = do
|
||||
running <- filter (`elem` usableservices)
|
||||
<$> listServiceNames client
|
||||
<$> liftIO (listServiceNames client)
|
||||
case running of
|
||||
[] -> startOneService client startableservices
|
||||
[] -> liftIO $ startOneService client startableservices
|
||||
(service:_) -> do
|
||||
brokendebug thisThread [ "Using running DBUS service"
|
||||
debug [ "Using running DBUS service"
|
||||
, service
|
||||
, "to monitor mount events."
|
||||
]
|
||||
|
@ -144,26 +141,29 @@ mountChanged = [gvfs True, gvfs False, kde, kdefallback]
|
|||
|
||||
#endif
|
||||
|
||||
pollingThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> IO ()
|
||||
pollingThread st dstatus scanremotes pushnotifier = go =<< currentMountPoints
|
||||
pollingThread :: Assistant ()
|
||||
pollingThread = go =<< liftIO currentMountPoints
|
||||
where
|
||||
go wasmounted = do
|
||||
threadDelaySeconds (Seconds 10)
|
||||
nowmounted <- currentMountPoints
|
||||
handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted
|
||||
liftIO $ threadDelaySeconds (Seconds 10)
|
||||
nowmounted <- liftIO currentMountPoints
|
||||
handleMounts wasmounted nowmounted
|
||||
go nowmounted
|
||||
|
||||
handleMounts :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> MountPoints -> MountPoints -> IO ()
|
||||
handleMounts st dstatus scanremotes pushnotifier wasmounted nowmounted =
|
||||
mapM_ (handleMount st dstatus scanremotes pushnotifier . mnt_dir) $
|
||||
handleMounts :: MountPoints -> MountPoints -> Assistant ()
|
||||
handleMounts wasmounted nowmounted =
|
||||
mapM_ (handleMount . mnt_dir) $
|
||||
S.toList $ newMountPoints wasmounted nowmounted
|
||||
|
||||
handleMount :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PushNotifier -> FilePath -> IO ()
|
||||
handleMount st dstatus scanremotes pushnotifier dir = do
|
||||
brokendebug thisThread ["detected mount of", dir]
|
||||
reconnectRemotes thisThread st dstatus scanremotes (Just pushnotifier)
|
||||
=<< filter (Git.repoIsLocal . Remote.repo)
|
||||
<$> remotesUnder st dstatus dir
|
||||
handleMount :: FilePath -> Assistant ()
|
||||
handleMount dir = do
|
||||
debug ["detected mount of", dir]
|
||||
rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir
|
||||
d <- getAssistant id
|
||||
liftIO $
|
||||
reconnectRemotes (threadName d) (threadState d)
|
||||
(daemonStatusHandle d) (scanRemoteMap d)
|
||||
(Just $ pushNotifier d) rs
|
||||
|
||||
{- Finds remotes located underneath the mount point.
|
||||
-
|
||||
|
@ -173,15 +173,15 @@ handleMount st dstatus scanremotes pushnotifier dir = do
|
|||
- 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
|
||||
remotesUnder :: FilePath -> Assistant [Remote]
|
||||
remotesUnder dir = do
|
||||
repotop <- liftAnnex $ fromRepo Git.repoPath
|
||||
rs <- liftAnnex remoteList
|
||||
pairs <- liftAnnex $ mapM (checkremote repotop) rs
|
||||
let (waschanged, rs') = unzip pairs
|
||||
when (any id waschanged) $ do
|
||||
Annex.changeState $ \s -> s { Annex.remotes = rs' }
|
||||
updateSyncRemotes dstatus
|
||||
liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' }
|
||||
liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
|
||||
return $ map snd $ filter fst pairs
|
||||
where
|
||||
checkremote repotop r = case Remote.localpath r of
|
||||
|
|
|
@ -8,7 +8,6 @@
|
|||
module Assistant.Threads.TransferWatcher where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.Drop
|
||||
|
@ -20,60 +19,53 @@ import qualified Remote
|
|||
|
||||
import Control.Concurrent
|
||||
|
||||
thisThread :: ThreadName
|
||||
thisThread = "TransferWatcher"
|
||||
|
||||
{- This thread watches for changes to the gitAnnexTransferDir,
|
||||
- and updates the DaemonStatus's map of ongoing transfers. -}
|
||||
transferWatcherThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> NamedThread
|
||||
transferWatcherThread st dstatus transferqueue = thread $ liftIO $ do
|
||||
g <- runThreadState st gitRepo
|
||||
let dir = gitAnnexTransferDir g
|
||||
createDirectoryIfMissing True dir
|
||||
let hook a = Just $ runHandler st dstatus transferqueue a
|
||||
transferWatcherThread :: NamedThread
|
||||
transferWatcherThread = NamedThread "TransferWatcher" $ do
|
||||
dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo
|
||||
liftIO $ createDirectoryIfMissing True dir
|
||||
let hook a = Just <$> asIO2 (runHandler a)
|
||||
addhook <- hook onAdd
|
||||
delhook <- hook onDel
|
||||
modifyhook <- hook onModify
|
||||
errhook <- hook onErr
|
||||
let hooks = mkWatchHooks
|
||||
{ addHook = hook onAdd
|
||||
, delHook = hook onDel
|
||||
, modifyHook = hook onModify
|
||||
, errHook = hook onErr
|
||||
{ addHook = addhook
|
||||
, delHook = delhook
|
||||
, modifyHook = modifyhook
|
||||
, errHook = errhook
|
||||
}
|
||||
void $ watchDir dir (const False) hooks id
|
||||
brokendebug thisThread ["watching for transfers"]
|
||||
where
|
||||
thread = NamedThread thisThread
|
||||
void $ liftIO $ watchDir dir (const False) hooks id
|
||||
debug ["watching for transfers"]
|
||||
|
||||
type Handler = ThreadState -> DaemonStatusHandle -> TransferQueue -> FilePath -> Maybe FileStatus -> IO ()
|
||||
type Handler = FilePath -> Assistant ()
|
||||
|
||||
{- Runs an action handler.
|
||||
-
|
||||
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
||||
-}
|
||||
runHandler :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Handler -> FilePath -> Maybe FileStatus -> IO ()
|
||||
runHandler st dstatus transferqueue handler file filestatus = void $
|
||||
either print (const noop) =<< tryIO go
|
||||
where
|
||||
go = handler st dstatus transferqueue file filestatus
|
||||
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
|
||||
runHandler handler file _filestatus =
|
||||
either (liftIO . print) (const noop) =<< tryIO <~> handler file
|
||||
|
||||
{- Called when there's an error with inotify. -}
|
||||
onErr :: Handler
|
||||
onErr _ _ _ msg _ = error msg
|
||||
onErr msg = error msg
|
||||
|
||||
{- Called when a new transfer information file is written. -}
|
||||
onAdd :: Handler
|
||||
onAdd st dstatus _ file _ = case parseTransferFile file of
|
||||
onAdd file = case parseTransferFile file of
|
||||
Nothing -> noop
|
||||
Just t -> go t =<< runThreadState st (checkTransfer t)
|
||||
Just t -> go t =<< liftAnnex (checkTransfer t)
|
||||
where
|
||||
go _ Nothing = noop -- transfer already finished
|
||||
go t (Just info) = do
|
||||
brokendebug thisThread
|
||||
[ "transfer starting:"
|
||||
, show t
|
||||
]
|
||||
debug [ "transfer starting:", show t]
|
||||
r <- headMaybe . filter (sameuuid t)
|
||||
<$> runThreadState st Remote.remoteList
|
||||
updateTransferInfo dstatus t info
|
||||
{ transferRemote = r }
|
||||
<$> liftAnnex Remote.remoteList
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ updateTransferInfo dstatus t info { transferRemote = r }
|
||||
sameuuid t r = Remote.uuid r == transferUUID t
|
||||
|
||||
{- Called when a transfer information file is updated.
|
||||
|
@ -81,15 +73,15 @@ onAdd st dstatus _ file _ = case parseTransferFile file of
|
|||
- The only thing that should change in the transfer info is the
|
||||
- bytesComplete, so that's the only thing updated in the DaemonStatus. -}
|
||||
onModify :: Handler
|
||||
onModify _ dstatus _ file _ = do
|
||||
onModify file = do
|
||||
case parseTransferFile file of
|
||||
Nothing -> noop
|
||||
Just t -> go t =<< readTransferInfoFile Nothing file
|
||||
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
|
||||
where
|
||||
go _ Nothing = noop
|
||||
go t (Just newinfo) = alterTransferInfo t
|
||||
(\i -> i { bytesComplete = bytesComplete newinfo })
|
||||
dstatus
|
||||
<<~ daemonStatusHandle
|
||||
|
||||
{- This thread can only watch transfer sizes when the DirWatcher supports
|
||||
- tracking modificatons to files. -}
|
||||
|
@ -98,21 +90,19 @@ watchesTransferSize = modifyTracked
|
|||
|
||||
{- Called when a transfer information file is removed. -}
|
||||
onDel :: Handler
|
||||
onDel st dstatus transferqueue file _ = case parseTransferFile file of
|
||||
onDel file = case parseTransferFile file of
|
||||
Nothing -> noop
|
||||
Just t -> do
|
||||
brokendebug thisThread
|
||||
[ "transfer finishing:"
|
||||
, show t
|
||||
]
|
||||
minfo <- removeTransfer dstatus t
|
||||
debug [ "transfer finishing:", show t]
|
||||
minfo <- flip removeTransfer t <<~ daemonStatusHandle
|
||||
|
||||
void $ forkIO $ do
|
||||
finished <- asIO2 finishedTransfer
|
||||
void $ liftIO $ forkIO $ do
|
||||
{- XXX race workaround delay. The location
|
||||
- log needs to be updated before finishedTransfer
|
||||
- runs. -}
|
||||
threadDelay 10000000 -- 10 seconds
|
||||
finishedTransfer st dstatus transferqueue t minfo
|
||||
finished t minfo
|
||||
|
||||
{- Queue uploads of files we successfully downloaded, spreading them
|
||||
- out to other reachable remotes.
|
||||
|
@ -123,15 +113,19 @@ onDel st dstatus transferqueue file _ = case parseTransferFile file of
|
|||
- Uploading a file may cause the local repo, or some other remote to not
|
||||
- want it; handle that too.
|
||||
-}
|
||||
finishedTransfer :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Transfer -> Maybe TransferInfo -> IO ()
|
||||
finishedTransfer st dstatus transferqueue t (Just info)
|
||||
| transferDirection t == Download = runThreadState st $
|
||||
whenM (inAnnex $ transferKey t) $ do
|
||||
handleDrops dstatus False
|
||||
finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
|
||||
finishedTransfer t (Just info)
|
||||
| transferDirection t == Download =
|
||||
whenM (liftAnnex $ inAnnex $ transferKey t) $ do
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
transferqueue <- getAssistant transferQueue
|
||||
liftAnnex $ handleDrops dstatus False
|
||||
(transferKey t) (associatedFile info)
|
||||
queueTransfersMatching (/= transferUUID t)
|
||||
liftAnnex $ queueTransfersMatching (/= transferUUID t)
|
||||
Later transferqueue dstatus
|
||||
(transferKey t) (associatedFile info) Upload
|
||||
| otherwise = runThreadState st $
|
||||
handleDrops dstatus True (transferKey t) (associatedFile info)
|
||||
finishedTransfer _ _ _ _ _ = noop
|
||||
| otherwise = do
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftAnnex $ handleDrops dstatus True (transferKey t) (associatedFile info)
|
||||
finishedTransfer _ _ = noop
|
||||
|
||||
|
|
Loading…
Reference in a new issue