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:
Joey Hess 2012-10-30 15:39:15 -04:00
parent ea8df8fe9f
commit 47d94eb9a4
20 changed files with 141 additions and 152 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View 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

View file

@ -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

View file

@ -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 =

View file

@ -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