diff options
Diffstat (limited to 'Assistant/Threads/TransferWatcher.hs')
| -rw-r--r-- | Assistant/Threads/TransferWatcher.hs | 46 |
1 files changed, 14 insertions, 32 deletions
diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 766c1f89e..364ce0468 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -10,23 +10,20 @@ module Assistant.Threads.TransferWatcher where import Common.Annex import Assistant.ThreadedMonad import Assistant.DaemonStatus -import Assistant.TransferSlots import Logs.Transfer import Utility.DirWatcher import Utility.Types.DirWatcher -import Annex.BranchState import Data.Map as M -import System.Posix.Process {- This thread watches for changes to the gitAnnexTransferDir, - and updates the DaemonStatus's map of ongoing transfers. -} -transferWatcherThread :: ThreadState -> DaemonStatusHandle -> TransferSlots -> IO () -transferWatcherThread st dstatus transferslots = do +transferWatcherThread :: ThreadState -> DaemonStatusHandle -> IO () +transferWatcherThread st dstatus = do g <- runThreadState st $ fromRepo id let dir = gitAnnexTransferDir g createDirectoryIfMissing True dir - let hook a = Just $ runHandler st dstatus transferslots a + let hook a = Just $ runHandler st dstatus a let hooks = mkWatchHooks { addHook = hook onAdd , delHook = hook onDel @@ -34,51 +31,36 @@ transferWatcherThread st dstatus transferslots = do } void $ watchDir dir (const False) hooks id -type Handler = ThreadState -> DaemonStatusHandle -> TransferSlots -> FilePath -> Maybe FileStatus -> IO () +type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus -> IO () {- Runs an action handler. - - Exceptions are ignored, otherwise a whole thread could be crashed. -} -runHandler :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Handler -> FilePath -> Maybe FileStatus -> IO () -runHandler st dstatus transferslots handler file filestatus = void $ do +runHandler :: ThreadState -> DaemonStatusHandle -> Handler -> FilePath -> Maybe FileStatus -> IO () +runHandler st dstatus handler file filestatus = void $ do either print (const noop) =<< tryIO go where - go = handler st dstatus transferslots file filestatus + go = handler st dstatus file filestatus {- 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 st dstatus file _ = case parseTransferFile file of Nothing -> noop Just t -> runThreadState st $ go t =<< checkTransfer t where go _ Nothing = noop -- transfer already finished go t (Just info) = adjustTransfers dstatus $ M.insertWith' merge t info - -- preseve shouldWait flag, which is not written to disk - merge new old = new { shouldWait = shouldWait old } + -- preseve transferTid, which is not written to disk + merge new old = new { transferTid = transferTid old } -{- Called when a transfer information file is removed. - - - - When the transfer process is a child of this process, wait on it - - to avoid zombies. - -} +{- Called when a transfer information file is removed. -} onDel :: Handler -onDel st dstatus transferslots file _ = case parseTransferFile file of +onDel st dstatus file _ = case parseTransferFile file of Nothing -> noop - Just t -> maybe noop waitchild - =<< runThreadState st (removeTransfer dstatus t) - where - waitchild info - | shouldWait info = case transferPid info of - Nothing -> noop - Just pid -> do - void $ tryIO $ - getProcessStatus True False pid - runThreadState st invalidateCache - transferComplete transferslots - | otherwise = noop + Just t -> void $ runThreadState st $ removeTransfer dstatus t |