diff options
| -rw-r--r-- | Assistant/Changes.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/Committer.hs | 31 | ||||
| -rw-r--r-- | Assistant/Threads/Watcher.hs | 39 | ||||
| -rw-r--r-- | Assistant/Types/Changes.hs | 19 | ||||
| -rw-r--r-- | debian/changelog | 2 |
5 files changed, 50 insertions, 43 deletions
diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs index 3d3956899..9114f5124 100644 --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -14,7 +14,7 @@ import Utility.TSet import Data.Time.Clock {- Handlers call this when they made a change that needs to get committed. -} -madeChange :: FilePath -> ChangeType -> Assistant (Maybe Change) +madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change) madeChange f t = Just <$> (Change <$> liftIO getCurrentTime <*> pure f <*> pure t) noChange :: Assistant (Maybe Change) diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 5887f5e43..1d2c5b63d 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -16,6 +16,7 @@ import Assistant.Commits import Assistant.Alert import Assistant.DaemonStatus import Assistant.TransferQueue +import Assistant.Drop import Logs.Transfer import Logs.Location import qualified Annex.Queue @@ -64,6 +65,7 @@ commitThread = namedThread "Committer" $ do void $ alertWhile commitAlert $ liftAnnex commitStaged recordCommit + mapM_ checkChangeContent readychanges else refill readychanges else refill changes where @@ -196,7 +198,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do key <- liftAnnex $ do showStart "add" $ keyFilename ks Command.Add.ingest $ Just ks - done (finishedChange change) (keyFilename ks) key + maybe failedingest (done 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. -} @@ -204,10 +206,11 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do ret _ = (True, Nothing) add _ = return Nothing - done _ _ Nothing = do + failedingest = do liftAnnex showEndFail return Nothing - done change file (Just key) = do + + done change file key = do liftAnnex $ do logStatus key InfoPresent link <- ifM isDirect @@ -217,8 +220,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do stageSymlink file =<< hashSymlink link showEndOk - queueTransfers "newly added file" Next key (Just file) Upload - return $ Just change + return $ Just $ finishedChange change key {- Check that the keysource's keyFilename still exists, - and is still a hard link to its contentLocation, @@ -299,3 +301,22 @@ safeToAdd delayadd pending inprocess = do tmpdir <- fromRepo gitAnnexTmpDir liftIO $ Lsof.queryDir tmpdir ) + +{- After a Change is committed, queue any necessary transfers or drops + - of the content of the key. + - + - This is not done during the startup scan, because the expensive + - transfer scan does the same thing then. + -} +checkChangeContent :: Change -> Assistant () +checkChangeContent (Change { changeInfo = i , changeFile = f }) = + case changeInfoKey i of + Nothing -> noop + Just k -> whenM (scanComplete <$> getDaemonStatus) $ do + present <- liftAnnex $ inAnnex k + if present + then queueTransfers "new file created" Next k (Just f) Upload + else queueTransfers "new or renamed file wanted" Next k (Just f) Download + handleDrops "file renamed" present k (Just f) Nothing +checkChangeContent _ = noop + diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 38c5c138f..ce308b3a3 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -20,10 +20,7 @@ import Assistant.Common import Assistant.DaemonStatus import Assistant.Changes import Assistant.Types.Changes -import Assistant.TransferQueue import Assistant.Alert -import Assistant.Drop -import Logs.Transfer import Utility.DirWatcher import Utility.Types.DirWatcher import Utility.Lsof @@ -178,6 +175,7 @@ onAdd file filestatus - really been modified. -} onAddDirect :: Handler onAddDirect file fs = do + debug ["add direct", file] v <- liftAnnex $ catKeyFile file case (v, fs) of (Just key, Just filestatus) -> @@ -201,20 +199,16 @@ onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile fil liftAnnex $ void $ addAssociatedFile key file link <- liftAnnex $ calcGitLink file key ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) - ( do - s <- getDaemonStatus - checkcontent key s - ensurestaged (Just link) s + ( ensurestaged (Just link) (Just key) =<< getDaemonStatus , do unless isdirect $ do liftIO $ removeFile file liftAnnex $ Backend.makeAnnexLink link file - checkcontent key =<< getDaemonStatus - addlink link + addlink link (Just key) ) go Nothing = do -- other symlink mlink <- liftIO (catchMaybeIO $ readSymbolicLink file) - ensurestaged mlink =<< getDaemonStatus + ensurestaged mlink Nothing =<< getDaemonStatus {- This is often called on symlinks that are already - staged correctly. A symlink may have been deleted @@ -227,16 +221,16 @@ onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile fil - (If the daemon has never ran before, avoid staging - links too.) -} - ensurestaged (Just link) daemonstatus - | scanComplete daemonstatus = addlink link + ensurestaged (Just link) mk daemonstatus + | scanComplete daemonstatus = addlink link mk | otherwise = case filestatus of Just s | not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange - _ -> addlink link - ensurestaged Nothing _ = noChange + _ -> addlink link mk + ensurestaged Nothing _ _ = noChange {- For speed, tries to reuse the existing blob for symlink target. -} - addlink link = do + addlink link mk = do debug ["add symlink", file] liftAnnex $ do v <- catObjectDetails $ Ref $ ':':file @@ -245,20 +239,7 @@ onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile fil | s2w8 link == L.unpack currlink -> stageSymlink file sha _ -> stageSymlink file =<< hashSymlink link - 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. - - Also, moving or copying a link may caused it be be transferred - - elsewhere, so check that too. -} - checkcontent key daemonstatus - | scanComplete daemonstatus = do - present <- liftAnnex $ inAnnex key - if present - then queueTransfers "new file created" Next key (Just file) Upload - else queueTransfers "new or renamed file wanted" Next key (Just file) Download - handleDrops "file renamed" present key (Just file) Nothing - | otherwise = noop + madeChange file $ LinkChange mk onDel :: Handler onDel file _ = do diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs index 887aa819e..d4e1b28bc 100644 --- a/Assistant/Types/Changes.hs +++ b/Assistant/Types/Changes.hs @@ -8,20 +8,26 @@ module Assistant.Types.Changes where import Types.KeySource +import Types.Key import Utility.TSet import Data.Time.Clock -data ChangeType = AddChange | LinkChange | RmChange | RmDirChange +data ChangeInfo = AddChange Key | LinkChange (Maybe Key) | RmChange | RmDirChange deriving (Show, Eq) +changeInfoKey :: ChangeInfo -> Maybe Key +changeInfoKey (AddChange k) = Just k +changeInfoKey (LinkChange (Just k)) = Just k +changeInfoKey _ = Nothing + type ChangeChan = TSet Change data Change = Change { changeTime :: UTCTime , changeFile :: FilePath - , changeType :: ChangeType + , changeInfo :: ChangeInfo } | PendingAddChange { changeTime ::UTCTime @@ -44,11 +50,10 @@ isInProcessAddChange :: Change -> Bool isInProcessAddChange (InProcessAddChange {}) = True isInProcessAddChange _ = False -finishedChange :: Change -> Change -finishedChange c@(InProcessAddChange { keySource = ks }) = Change +finishedChange :: Change -> Key -> Change +finishedChange c@(InProcessAddChange { keySource = ks }) k = Change { changeTime = changeTime c , changeFile = keyFilename ks - , changeType = AddChange + , changeInfo = AddChange k } -finishedChange c = c - +finishedChange c _ = c diff --git a/debian/changelog b/debian/changelog index 59208eb5b..75299cf39 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,7 +8,7 @@ git-annex (4.20130228) UNRELEASED; urgency=low * assistant: Avoid noise in logs from git commit about typechanged files in direct mode repositories. * assistant: Fix dropping content when a file is moved to an archive - directory. + directory, and getting contennt when a file is moved back out. * assistant: Set gc.auto=0 when creating repositories to prevent automatic commits from causing git-gc runs. * assistant: If gc.auto=0, run git-gc once a day, packing loose objects |