split Changes and lifted

This commit is contained in:
Joey Hess 2012-10-29 19:30:23 -04:00
parent 39a3adf434
commit d2294f0dfa
5 changed files with 82 additions and 67 deletions

View file

@ -11,6 +11,7 @@ module Assistant.Threads.Committer where
import Assistant.Common
import Assistant.Changes
import Assistant.Types.Changes
import Assistant.Commits
import Assistant.Alert
import Assistant.Threads.Watcher
@ -45,7 +46,7 @@ commitThread = NamedThread "Committer" $ do
-- We already waited one second as a simple rate limiter.
-- Next, wait until at least one change is available for
-- processing.
changes <- getChanges <<~ changeChan
changes <- getChanges
-- Now see if now's a good time to commit.
time <- liftIO getCurrentTime
if shouldCommit time changes
@ -67,7 +68,7 @@ commitThread = NamedThread "Committer" $ do
refill [] = noop
refill cs = do
debug ["delaying commit of", show (length cs), "changes"]
flip refillChanges cs <<~ changeChan
refillChanges cs
commitStaged :: Annex Bool
commitStaged = do
@ -148,15 +149,14 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
(postponed, toadd) <- partitionEithers <$> safeToAdd delayadd pending' inprocess
unless (null postponed) $
flip refillChanges postponed <<~ changeChan
refillChanges postponed
returnWhen (null toadd) $ do
added <- catMaybes <$> forM toadd add
if DirWatcher.eventsCoalesce || null added
then return $ added ++ otherchanges
else do
r <- handleAdds delayadd
=<< getChanges <<~ changeChan
r <- handleAdds delayadd =<< getChanges
return $ r ++ added ++ otherchanges
where
(incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs

View file

@ -17,6 +17,7 @@ module Assistant.Threads.Watcher (
import Assistant.Common
import Assistant.DaemonStatus
import Assistant.Changes
import Assistant.Types.Changes
import Assistant.TransferQueue
import Assistant.Alert
import Assistant.Drop
@ -114,12 +115,12 @@ runHandler handler file filestatus = void $ do
-- Just in case the commit thread is not
-- flushing the queue fast enough.
liftAnnex $ Annex.Queue.flushWhenFull
flip recordChange change <<~ changeChan
recordChange change
onAdd :: Handler
onAdd file filestatus
| maybe False isRegularFile filestatus = liftIO $ pendingAddChange file
| otherwise = liftIO $ noChange
| maybe False isRegularFile filestatus = pendingAddChange file
| otherwise = noChange
{- A symlink might be an arbitrary symlink, which is just added.
- Or, if it is a git-annex symlink, ensure it points to the content
@ -160,7 +161,7 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
| scanComplete daemonstatus = addlink link
| otherwise = case filestatus of
Just s
| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> liftIO noChange
| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
_ -> addlink link
{- For speed, tries to reuse the existing blob for symlink target. -}
@ -176,7 +177,7 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
sha <- inRepo $
Git.HashObject.hashObject BlobObject link
stageSymlink file sha
liftIO $ madeChange file LinkChange
madeChange file LinkChange
{- When a new link appears, or a link is changed, after the startup
- scan, handle getting or dropping the key's content. -}
@ -197,7 +198,7 @@ onDel file _ = do
liftAnnex $
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.unstageFile file)
liftIO $ madeChange file RmChange
madeChange file RmChange
{- A directory has been deleted, or moved, so tell git to remove anything
- that was inside it from its cache. Since it could reappear at any time,
@ -211,7 +212,7 @@ onDelDir dir _ = do
debug ["directory deleted", dir]
liftAnnex $ Annex.Queue.addCommand "rm"
[Params "--quiet -r --cached --ignore-unmatch --"] [dir]
liftIO $ madeChange dir RmDirChange
madeChange dir RmDirChange
{- Called when there's an error with inotify or kqueue. -}
onErr :: Handler
@ -219,7 +220,7 @@ onErr msg _ = do
liftAnnex $ warning msg
dstatus <- getAssistant daemonStatusHandle
void $ liftIO $ addAlert dstatus $ warningAlert "watcher" msg
liftIO noChange
noChange
{- Adds a symlink to the index, without ever accessing the actual symlink
- on disk. This avoids a race if git add is used, where the symlink is