pushed Assistant monad down into DaemonStatus code
Currently have three old versions of functions that more reworking is needed to remove: getDaemonStatusOld, modifyDaemonStatusOld_, and modifyDaemonStatusOld
This commit is contained in:
parent
ea8df8fe9f
commit
47d94eb9a4
20 changed files with 141 additions and 152 deletions
|
@ -74,7 +74,7 @@ reloadConfigs changedconfigs = do
|
|||
{- Changes to the remote log, or the trust log, can affect the
|
||||
- syncRemotes list -}
|
||||
when (Logs.Remote.remoteLog `elem` fs || Logs.Trust.trustLog `elem` fs) $
|
||||
liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
|
||||
updateSyncRemotes
|
||||
where
|
||||
(fs, as) = unzip $ filter (flip S.member changedfiles . fst)
|
||||
configFilesActions
|
||||
|
|
|
@ -177,7 +177,7 @@ remotesUnder dir = do
|
|||
let (waschanged, rs') = unzip pairs
|
||||
when (any id waschanged) $ do
|
||||
liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' }
|
||||
liftAnnex . updateSyncRemotes =<< getAssistant daemonStatusHandle
|
||||
updateSyncRemotes
|
||||
return $ map snd $ filter fst pairs
|
||||
where
|
||||
checkremote repotop r = case Remote.localpath r of
|
||||
|
|
|
@ -104,12 +104,12 @@ pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
|
|||
pairReqReceived True _ _ = noop -- ignore our own PairReq
|
||||
pairReqReceived False urlrenderer msg = do
|
||||
url <- liftIO $ renderUrl urlrenderer (FinishPairR msg) []
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ void $ addAlert dstatus $ pairRequestReceivedAlert repo
|
||||
close <- asIO removeAlert
|
||||
void $ addAlert $ pairRequestReceivedAlert repo
|
||||
AlertButton
|
||||
{ buttonUrl = url
|
||||
, buttonLabel = T.pack "Respond"
|
||||
, buttonAction = Just $ removeAlert dstatus
|
||||
, buttonAction = Just close
|
||||
}
|
||||
where
|
||||
repo = pairRepo msg
|
||||
|
|
|
@ -28,14 +28,12 @@ sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do
|
|||
debug ["sanity check complete"]
|
||||
where
|
||||
go = do
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ modifyDaemonStatus_ dstatus $ \s -> s
|
||||
{ sanityCheckRunning = True }
|
||||
modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
|
||||
|
||||
now <- liftIO $ getPOSIXTime -- before check started
|
||||
r <- either showerr return =<< tryIO <~> check
|
||||
|
||||
liftIO $ modifyDaemonStatus_ dstatus $ \s -> s
|
||||
modifyDaemonStatus_ $ \s -> s
|
||||
{ sanityCheckRunning = False
|
||||
, lastSanityCheck = Just now
|
||||
}
|
||||
|
@ -84,8 +82,7 @@ check = do
|
|||
slop = fromIntegral tenMinutes
|
||||
insanity msg = do
|
||||
liftAnnex $ warning msg
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ void $ addAlert dstatus $ sanityCheckFixAlert msg
|
||||
void $ addAlert $ sanityCheckFixAlert msg
|
||||
addsymlink file s = do
|
||||
Watcher.runHandler Watcher.onAddSymlink file s
|
||||
insanity $ "found unstaged symlink: " ++ file
|
||||
|
|
|
@ -52,7 +52,5 @@ transferPollerThread = NamedThread "TransferPoller" $ do
|
|||
|
||||
newsize t info sz
|
||||
| bytesComplete info /= sz && isJust sz =
|
||||
withAssistant daemonStatusHandle $ \h ->
|
||||
alterTransferInfo h t $
|
||||
\i -> i { bytesComplete = sz }
|
||||
alterTransferInfo t $ \i -> i { bytesComplete = sz }
|
||||
| otherwise = noop
|
||||
|
|
|
@ -64,8 +64,7 @@ onAdd file = case parseTransferFile file of
|
|||
debug [ "transfer starting:", show t]
|
||||
r <- headMaybe . filter (sameuuid t)
|
||||
<$> liftAnnex Remote.remoteList
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ updateTransferInfo dstatus t info { transferRemote = r }
|
||||
updateTransferInfo t info { transferRemote = r }
|
||||
sameuuid t r = Remote.uuid r == transferUUID t
|
||||
|
||||
{- Called when a transfer information file is updated.
|
||||
|
@ -79,9 +78,8 @@ onModify file = do
|
|||
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
|
||||
where
|
||||
go _ Nothing = noop
|
||||
go t (Just newinfo) = withAssistant daemonStatusHandle $ \h ->
|
||||
alterTransferInfo h t $
|
||||
\i -> i { bytesComplete = bytesComplete newinfo }
|
||||
go t (Just newinfo) = alterTransferInfo t $
|
||||
\i -> i { bytesComplete = bytesComplete newinfo }
|
||||
|
||||
{- This thread can only watch transfer sizes when the DirWatcher supports
|
||||
- tracking modificatons to files. -}
|
||||
|
@ -94,7 +92,7 @@ onDel file = case parseTransferFile file of
|
|||
Nothing -> noop
|
||||
Just t -> do
|
||||
debug [ "transfer finishing:", show t]
|
||||
minfo <- flip removeTransfer t <<~ daemonStatusHandle
|
||||
minfo <- removeTransfer t
|
||||
|
||||
finished <- asIO2 finishedTransfer
|
||||
void $ liftIO $ forkIO $ do
|
||||
|
|
|
@ -32,9 +32,8 @@ transfererThread = NamedThread "Transferr" $ do
|
|||
program <- liftIO readProgramFile
|
||||
transferqueue <- getAssistant transferQueue
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
slots <- getAssistant transferSlots
|
||||
starter <- asIO2 $ startTransfer program
|
||||
liftIO $ forever $ inTransferSlot dstatus slots $
|
||||
forever $ inTransferSlot $ liftIO $
|
||||
maybe (return Nothing) (uncurry starter)
|
||||
=<< getNextTransfer transferqueue dstatus notrunning
|
||||
where
|
||||
|
@ -48,12 +47,12 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
|
|||
(Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info)
|
||||
( do
|
||||
debug [ "Transferring:" , show t ]
|
||||
notifyTransfer <<~ daemonStatusHandle
|
||||
notifyTransfer
|
||||
tp <- asIO2 transferprocess
|
||||
return $ Just (t, info, tp remote file)
|
||||
, do
|
||||
debug [ "Skipping unnecessary transfer:" , show t ]
|
||||
void $ flip removeTransfer t <<~ daemonStatusHandle
|
||||
void $ removeTransfer t
|
||||
return Nothing
|
||||
)
|
||||
_ -> return Nothing
|
||||
|
@ -77,10 +76,8 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
|
|||
- in the transfer.
|
||||
-}
|
||||
whenM (liftIO $ (==) ExitSuccess <$> waitForProcess pid) $ do
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ void $ addAlert dstatus $
|
||||
makeAlertFiller True $
|
||||
transferFileAlert direction True file
|
||||
void $ addAlert $ makeAlertFiller True $
|
||||
transferFileAlert direction True file
|
||||
recordCommit
|
||||
where
|
||||
params =
|
||||
|
|
|
@ -85,9 +85,7 @@ startupScan scanner = do
|
|||
inRepo $ Git.Command.run "add" [Param "--update"]
|
||||
showAction "started"
|
||||
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
liftIO $ modifyDaemonStatus_ dstatus $
|
||||
\s -> s { scanComplete = True }
|
||||
modifyDaemonStatus_ $ \s -> s { scanComplete = True }
|
||||
|
||||
return (True, r)
|
||||
|
||||
|
@ -218,8 +216,7 @@ onDelDir dir _ = do
|
|||
onErr :: Handler
|
||||
onErr msg _ = do
|
||||
liftAnnex $ warning msg
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
void $ liftIO $ addAlert dstatus $ warningAlert "watcher" msg
|
||||
void $ addAlert $ warningAlert "watcher" msg
|
||||
noChange
|
||||
|
||||
{- Adds a symlink to the index, without ever accessing the actual symlink
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue