diff options
author | Joey Hess <joey@kitenet.net> | 2012-07-28 18:02:11 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-07-28 18:02:11 -0400 |
commit | 3cc18857936e5a09e033439971dc9c43e6ccbaa2 (patch) | |
tree | a817de04aa65271b3036370d447cf1b228a4bffb /Assistant/Threads | |
parent | a17fde22fabdb706086ac945bc331e32527b58bd (diff) |
move DaemonStatus manipulation out of the Annex monad to IO
I've convinced myself that nothing in DaemonStatus can deadlock,
as it always keepts the TMVar full. That was the only reason it was in the
Annex monad.
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 |