diff options
Diffstat (limited to 'Assistant/Threads')
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 3 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 24 | ||||
| -rw-r--r-- | Assistant/Threads/TransferWatcher.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 4 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 2 |
6 files changed, 22 insertions, 29 deletions
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index cba53af23..3762c4836 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -51,8 +51,7 @@ pushThread st daemonstatus commitchan pushmap = do now <- getCurrentTime if shouldPush now commits then do - remotes <- runThreadState st $ - knownRemotes <$> getDaemonStatus daemonstatus + remotes <- knownRemotes <$> getDaemonStatus daemonstatus pushToRemotes thisThread now st (Just pushmap) remotes else do debug thisThread diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 09aee0797..5e27246a0 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -26,32 +26,28 @@ thisThread = "SanityChecker" {- This thread wakes up occasionally to make sure the tree is in good shape. -} sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO () sanityCheckerThread st status transferqueue changechan = forever $ do - waitForNextCheck st status + waitForNextCheck status debug thisThread ["starting sanity check"] - runThreadState st $ - modifyDaemonStatus_ status $ \s -> s - { sanityCheckRunning = True } + modifyDaemonStatus_ status $ \s -> s + { sanityCheckRunning = True } now <- getPOSIXTime -- before check started catchIO (check st status transferqueue changechan) (runThreadState st . warning . show) - runThreadState st $ do - modifyDaemonStatus_ status $ \s -> s - { sanityCheckRunning = False - , lastSanityCheck = Just now - } + modifyDaemonStatus_ status $ \s -> s + { sanityCheckRunning = False + , lastSanityCheck = Just now + } debug thisThread ["sanity check complete"] - {- Only run one check per day, from the time of the last check. -} -waitForNextCheck :: ThreadState -> DaemonStatusHandle -> IO () -waitForNextCheck st status = do - v <- runThreadState st $ - lastSanityCheck <$> getDaemonStatus status +waitForNextCheck :: DaemonStatusHandle -> IO () +waitForNextCheck status = do + v <- lastSanityCheck <$> getDaemonStatus status now <- getPOSIXTime threadDelaySeconds $ Seconds $ calcdelay now v where diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index be520aaf9..447ff2264 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -55,12 +55,11 @@ onErr _ _ msg _ = error msg onAdd :: Handler onAdd st dstatus file _ = case parseTransferFile file of Nothing -> noop - Just t -> do - runThreadState st $ go t =<< checkTransfer t + Just t -> go t =<< runThreadState st (checkTransfer t) where go _ Nothing = noop -- transfer already finished go t (Just info) = do - liftIO $ debug thisThread + debug thisThread [ "transfer starting:" , show t ] @@ -71,11 +70,11 @@ onAdd st dstatus file _ = case parseTransferFile file of {- Called when a transfer information file is removed. -} onDel :: Handler -onDel st dstatus file _ = case parseTransferFile file of +onDel _ dstatus file _ = case parseTransferFile file of Nothing -> noop Just t -> do debug thisThread [ "transfer finishing:" , show t ] - void $ runThreadState st $ removeTransfer dstatus t + void $ removeTransfer dstatus t diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index d8a146948..30802f742 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -48,7 +48,7 @@ transfererThread st dstatus transferqueue slots = go - being uploaded to isn't known to have the file. -} shouldTransfer :: DaemonStatusHandle -> Transfer -> TransferInfo -> Annex Bool shouldTransfer dstatus t info = - go =<< currentTransfers <$> getDaemonStatus dstatus + go =<< currentTransfers <$> liftIO (getDaemonStatus dstatus) where go m | M.member t m = return False @@ -84,7 +84,7 @@ transferThread st dstatus slots t info = case (transferRemote info, associatedFi tid <- inTransferSlot slots st $ transferprocess remote file now <- getCurrentTime - runThreadState st $ adjustTransfers dstatus $ + adjustTransfers dstatus $ M.insertWith' const t info { startedTime = Just $ utcTimeToPOSIXSeconds now , transferTid = Just tid diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 31025361b..ab57bf04a 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -76,8 +76,7 @@ statupScan st dstatus scanner = do runThreadState st $ showAction "scanning" r <- scanner - runThreadState st $ - modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True } + modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True } -- Notice any files that were deleted before watching was started. runThreadState st $ do @@ -132,7 +131,7 @@ runHandler threadname st dstatus transferqueue changechan handler file filestatu onAdd :: Handler onAdd threadname file filestatus dstatus _ | maybe False isRegularFile filestatus = do - ifM (scanComplete <$> getDaemonStatus dstatus) + ifM (scanComplete <$> liftIO (getDaemonStatus dstatus)) ( go , ifM (null <$> inRepo (Git.LsFiles.notInRepo False [file])) ( noChange @@ -156,7 +155,7 @@ onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.l link <- calcGitLink file key ifM ((==) link <$> liftIO (readSymbolicLink file)) ( do - s <- getDaemonStatus dstatus + s <- liftIO $ getDaemonStatus dstatus checkcontent key s ensurestaged link s , do @@ -167,7 +166,7 @@ onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.l ) go Nothing = do -- other symlink link <- liftIO (readSymbolicLink file) - ensurestaged link =<< getDaemonStatus dstatus + ensurestaged link =<< liftIO (getDaemonStatus dstatus) {- This is often called on symlinks that are already - staged correctly. A symlink may have been deleted diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 92f7ff253..6e895ccf6 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -115,7 +115,7 @@ statusDisplay = do current <- liftIO $ runThreadState (threadState webapp) $ M.toList . currentTransfers - <$> getDaemonStatus (daemonStatus webapp) + <$> liftIO (getDaemonStatus $ daemonStatus webapp) queued <- liftIO $ getTransferQueue $ transferQueue webapp let transfers = current ++ queued |