diff options
Diffstat (limited to 'Assistant/Threads')
| -rw-r--r-- | Assistant/Threads/MountWatcher.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 17 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 13 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 5 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 13 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 2 |
6 files changed, 32 insertions, 20 deletions
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 20862dac1..4baef1d11 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -165,7 +165,7 @@ handleMount st dstatus scanremotes mntent = do branch <- runThreadState st $ Command.Sync.currentBranch let nonspecial = filter (Git.repoIsLocal . Remote.repo) rs unless (null nonspecial) $ - alertWhile dstatus (syncMountAlert dir nonspecial) $ do + void $ alertWhile dstatus (syncMountAlert dir nonspecial) $ do debug thisThread ["syncing with", show nonspecial] runThreadState st $ manualPull branch nonspecial now <- getCurrentTime diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 1b0420b9b..0a0edf1d0 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -37,7 +37,7 @@ pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do , "failed pushes" ] now <- getCurrentTime - alertWhile dstatus (pushRetryAlert topush) $ + void $ alertWhile dstatus (pushRetryAlert topush) $ pushToRemotes thisThread now st (Just pushmap) topush where halfhour = 1800 @@ -54,7 +54,7 @@ pushThread st dstatus commitchan pushmap = do if shouldPush now commits then do remotes <- knownRemotes <$> getDaemonStatus dstatus - alertWhile dstatus (pushAlert remotes) $ + void $ alertWhile dstatus (pushAlert remotes) $ pushToRemotes thisThread now st (Just pushmap) remotes else do debug thisThread @@ -80,7 +80,7 @@ shouldPush _now commits - - Avoids running possibly long-duration commands in the Annex monad, so - as not to block other threads. -} -pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO () +pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO Bool pushToRemotes threadname now st mpushmap remotes = do (g, branch) <- runThreadState st $ (,) <$> fromRepo id <*> Command.Sync.currentBranch @@ -92,6 +92,11 @@ pushToRemotes threadname now st mpushmap remotes = do , show rs ] Command.Sync.updateBranch (Command.Sync.syncBranch branch) g + {- TODO git push exits nonzero if the remote + - is already up-to-date. This code does not tell + - the difference between the two. Could perhaps + - be check the refs when it seemed to fail? + - Note bewloe -} (succeeded, failed) <- inParallel (push g branch) rs case mpushmap of Nothing -> noop @@ -104,8 +109,10 @@ pushToRemotes threadname now st mpushmap remotes = do [ "failed to push to" , show failed ] - unless (null failed || not shouldretry) $ - retry branch g failed + if (null failed || not shouldretry) + {- TODO see above TODO item -} + then return True -- return $ null failed + else retry branch g failed makemap l = M.fromList $ zip l (repeat now) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index cd5dc0644..a7c2189d8 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -31,7 +31,7 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do debug thisThread ["starting sanity check"] - alertWhile dstatus sanityCheckAlert go + void $ alertWhile dstatus sanityCheckAlert go debug thisThread ["sanity check complete"] where @@ -40,14 +40,18 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do { sanityCheckRunning = True } now <- getPOSIXTime -- before check started - catchIO (check st dstatus transferqueue changechan) - (runThreadState st . warning . show) + r <- catchIO (check st dstatus transferqueue changechan) + $ \e -> do + runThreadState st $ warning $ show e + return False modifyDaemonStatus_ dstatus $ \s -> s { sanityCheckRunning = False , lastSanityCheck = Just now } + return r + {- Only run one check per day, from the time of the last check. -} waitForNextCheck :: DaemonStatusHandle -> IO () waitForNextCheck dstatus = do @@ -67,7 +71,7 @@ oneDay = 24 * 60 * 60 {- It's important to stay out of the Annex monad as much as possible while - running potentially expensive parts of this check, since remaining in it - will block the watcher. -} -check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO () +check :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO Bool check st dstatus transferqueue changechan = do g <- runThreadState st $ fromRepo id -- Find old unstaged symlinks, and add them to git. @@ -80,6 +84,7 @@ check st dstatus transferqueue changechan = do | isSymbolicLink s -> addsymlink file ms _ -> noop + return True where toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) slop = fromIntegral tenMinutes diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 1d91a65d4..2cba0b2a7 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -32,18 +32,19 @@ transferScannerThread st dstatus scanremotes transferqueue = do runEvery (Seconds 2) $ do r <- getScanRemote scanremotes liftIO $ debug thisThread ["starting scan of", show r] - alertWhile dstatus (scanAlert r) $ + void $ alertWhile dstatus (scanAlert r) $ scan st dstatus transferqueue r liftIO $ debug thisThread ["finished scan of", show r] {- This is a naive scan through the git work tree. - - The scan is blocked when the transfer queue gets too large. -} -scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO () +scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool scan st dstatus transferqueue r = do g <- runThreadState st $ fromRepo id files <- LsFiles.inRepo [] g go files + return True where go [] = return () go (f:fs) = do diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index ddbd51655..bfeec7630 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -72,24 +72,23 @@ watchThread st dstatus transferqueue changechan = do } {- Initial scartup scan. The action should return once the scan is complete. -} -startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a +startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO () startupScan st dstatus scanner = do runThreadState st $ showAction "scanning" - r <- alertWhile dstatus startupScanAlert $ do - r <- scanner - modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True } + void $ alertWhile dstatus startupScanAlert $ do + void $ scanner -- Notice any files that were deleted before -- watching was started. runThreadState st $ do inRepo $ Git.Command.run "add" [Param "--update"] showAction "started" - return r + + modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True } + return True void $ addAlert dstatus runningAlert - return r - ignored :: FilePath -> Bool ignored = ig . takeFileName where diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 7ad40c307..d26855910 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -232,7 +232,7 @@ sideBarDisplay noScript = do (alertHeader alert) $ case alertMessage alert of StringAlert s -> [whamlet|#{s}|] - WidgetAlert w -> w + WidgetAlert w -> w alert rendermessage msg = addalert "yesodmessage" True False "alert-info" Nothing [whamlet|#{msg}|] |