summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Common.hs23
-rw-r--r--Assistant/Sync.hs3
-rw-r--r--Assistant/Threads/Committer.hs21
-rw-r--r--Assistant/Threads/Pusher.hs12
-rw-r--r--Assistant/Threads/SanityChecker.hs5
-rw-r--r--Assistant/Threads/TransferScanner.hs4
-rw-r--r--Assistant/Threads/Watcher.hs4
7 files changed, 33 insertions, 39 deletions
diff --git a/Assistant/Common.hs b/Assistant/Common.hs
index fcb6d65c8..ebef9469a 100644
--- a/Assistant/Common.hs
+++ b/Assistant/Common.hs
@@ -76,23 +76,26 @@ updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstat
-
- The alert is left visible afterwards, as filler.
- Old filler is pruned, to prevent the map growing too large. -}
-alertWhile :: DaemonStatusHandle -> Alert -> IO Bool -> IO Bool
-alertWhile dstatus alert a = alertWhile' dstatus alert $ do
+alertWhile :: Alert -> Assistant Bool -> Assistant Bool
+alertWhile alert a = alertWhile' alert $ do
r <- a
return (r, r)
{- Like alertWhile, but allows the activity to return a value too. -}
-alertWhile' :: DaemonStatusHandle -> Alert -> IO (Bool, a) -> IO a
-alertWhile' dstatus alert a = do
+alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
+alertWhile' alert a = do
let alert' = alert { alertClass = Activity }
- i <- addAlert dstatus alert'
+ dstatus <- getAssistant daemonStatusHandle
+ i <- liftIO $ addAlert dstatus alert'
(ok, r) <- a
- updateAlertMap dstatus $ mergeAlert i $ makeAlertFiller ok alert'
+ liftIO $ updateAlertMap dstatus $
+ mergeAlert i $ makeAlertFiller ok alert'
return r
{- Displays an alert while performing an activity, then removes it. -}
-alertDuring :: DaemonStatusHandle -> Alert -> IO a -> IO a
-alertDuring dstatus alert a = do
+alertDuring :: Alert -> Assistant a -> Assistant a
+alertDuring alert a = do
let alert' = alert { alertClass = Activity }
- i <- addAlert dstatus alert'
- removeAlert dstatus i `after` a
+ dstatus <- getAssistant daemonStatusHandle
+ i <- liftIO $ addAlert dstatus alert'
+ liftIO (removeAlert dstatus i) `after` a
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 4d5f8f625..6a2f5266e 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -38,8 +38,7 @@ import Control.Concurrent
reconnectRemotes :: Bool -> [Remote] -> Assistant ()
reconnectRemotes _ [] = noop
reconnectRemotes notifypushes rs = void $ do
- dstatus <- getAssistant daemonStatusHandle
- alertWhile dstatus (syncAlert rs) <~> do
+ alertWhile (syncAlert rs) $ do
(ok, diverged) <- sync
=<< liftAnnex (inRepo Git.Branch.current)
scanremotes <- getAssistant scanRemoteMap
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index 7bcdaa836..b3a737872 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -58,8 +58,7 @@ commitThread = NamedThread "Committer" $ do
, show (length readychanges)
, "changes"
]
- dstatus <- getAssistant daemonStatusHandle
- void $ alertWhile dstatus commitAlert <~>
+ void $ alertWhile commitAlert $
liftAnnex commitStaged
recordCommit <<~ commitChan
else refill readychanges
@@ -177,21 +176,19 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
add :: Change -> Assistant (Maybe Change)
add change@(InProcessAddChange { keySource = ks }) = do
- dstatus <- getAssistant daemonStatusHandle
- alertWhile' dstatus (addFileAlert $ keyFilename ks) <~> add' change ks
- add _ = return Nothing
-
- add' change ks = liftM ret $ catchMaybeIO <~> do
- sanitycheck ks $ do
- key <- liftAnnex $ do
- showStart "add" $ keyFilename ks
- Command.Add.ingest ks
- done (finishedChange change) (keyFilename ks) key
+ alertWhile' (addFileAlert $ keyFilename ks) $
+ liftM ret $ catchMaybeIO <~> do
+ sanitycheck ks $ do
+ key <- liftAnnex $ do
+ showStart "add" $ keyFilename ks
+ Command.Add.ingest ks
+ done (finishedChange change) (keyFilename ks) key
where
{- Add errors tend to be transient and will be automatically
- dealt with, so don't pass to the alert code. -}
ret (Just j@(Just _)) = (True, j)
ret _ = (True, Nothing)
+ add _ = return Nothing
done _ _ Nothing = do
liftAnnex showEndFail
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index 0235e6efc..95e4e1276 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@@ -31,9 +31,8 @@ pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
topush <- liftIO $ getFailedPushesBefore pushmap (fromIntegral halfhour)
unless (null topush) $ do
debug ["retrying", show (length topush), "failed pushes"]
- now <- liftIO $ getCurrentTime
- dstatus <- getAssistant daemonStatusHandle
- void $ alertWhile dstatus (pushRetryAlert topush) <~>
+ void $ alertWhile (pushRetryAlert topush) $ do
+ now <- liftIO $ getCurrentTime
pushToRemotes now True topush
where
halfhour = 1800
@@ -48,10 +47,9 @@ pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do
if shouldPush commits
then do
remotes <- filter pushable . syncRemotes <$> daemonStatus
- unless (null remotes) $ do
- now <- liftIO $ getCurrentTime
- dstatus <- getAssistant daemonStatusHandle
- void $ alertWhile dstatus (pushAlert remotes) <~>
+ unless (null remotes) $
+ void $ alertWhile (pushAlert remotes) $ do
+ now <- liftIO $ getCurrentTime
pushToRemotes now True remotes
else do
debug ["delaying push of", show (length commits), "commits"]
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index d92c6c394..46f399dab 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -24,10 +24,7 @@ sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do
waitForNextCheck
debug ["starting sanity check"]
-
- dstatus <- getAssistant daemonStatusHandle
- void $ alertWhile dstatus sanityCheckAlert <~> go
-
+ void $ alertWhile sanityCheckAlert go
debug ["sanity check complete"]
where
go = do
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 8c46a79fa..3e99b60f5 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -100,10 +100,10 @@ failedTransferScan r = do
expensiveScan :: [Remote] -> Assistant ()
expensiveScan rs = unless onlyweb $ do
debug ["starting scan of", show visiblers]
- dstatus <- getAssistant daemonStatusHandle
- void $ alertWhile dstatus (scanAlert visiblers) <~> do
+ void $ alertWhile (scanAlert visiblers) $ do
g <- liftAnnex gitRepo
(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
+ dstatus <- getAssistant daemonStatusHandle
forM_ files $ \f -> do
ts <- liftAnnex $
ifAnnexed f (findtransfers dstatus f) (return [])
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 172b7976e..1c796a521 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -75,8 +75,7 @@ watchThread = NamedThread "Watcher" $ do
startupScan :: IO a -> Assistant a
startupScan scanner = do
liftAnnex $ showAction "scanning"
- dstatus <- getAssistant daemonStatusHandle
- alertWhile' dstatus startupScanAlert <~> do
+ alertWhile' startupScanAlert $ do
r <- liftIO $ scanner
-- Notice any files that were deleted before
@@ -85,6 +84,7 @@ startupScan scanner = do
inRepo $ Git.Command.run "add" [Param "--update"]
showAction "started"
+ dstatus <- getAssistant daemonStatusHandle
liftIO $ modifyDaemonStatus_ dstatus $
\s -> s { scanComplete = True }