diff --git a/Annex/Content.hs b/Annex/Content.hs index a47485b49c..3b41784a5e 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -1,6 +1,6 @@ {- git-annex file content managing - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -38,7 +38,7 @@ module Annex.Content ( removeAnnex, moveBad, KeyLocation(..), - getKeysPresent, + listKeys, saveState, downloadUrl, preseedTmp, @@ -70,12 +70,9 @@ import Utility.FileMode import qualified Annex.Url as Url import Utility.CopyFile import Utility.Metered -import Config import Git.FilePath import Annex.Perms import Annex.Link -import qualified Annex.Content.Direct as Direct -import Annex.ReplaceFile import Annex.LockPool import Messages.Progress import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) @@ -103,36 +100,22 @@ inAnnexCheck key check = inAnnex' id False check key {- inAnnex that performs an arbitrary check of the key's content. -} inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a -inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect - where - checkindirect loc = do - r <- check loc - if isgood r - then ifM (annexThin <$> Annex.getGitConfig) - -- When annex.thin is set, the object file - -- could be modified; make sure it's not. - -- (Suppress any messages about - -- checksumming, to avoid them cluttering - -- the display.) - ( ifM (doQuietAction $ isUnmodified key loc) - ( return r - , return bad - ) - , return r - ) - else return bad - - -- In direct mode, at least one of the associated files must pass the - -- check. Additionally, the file must be unmodified. - checkdirect [] = return bad - checkdirect (loc:locs) = do - r <- check loc - if isgood r - then ifM (Direct.goodContent key loc) +inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do + r <- check loc + if isgood r + then ifM (annexThin <$> Annex.getGitConfig) + -- When annex.thin is set, the object file + -- could be modified; make sure it's not. + -- (Suppress any messages about + -- checksumming, to avoid them cluttering + -- the display.) + ( ifM (doQuietAction $ isUnmodified key loc) ( return r - , checkdirect locs + , return bad ) - else checkdirect locs + , return r + ) + else return bad {- Like inAnnex, checks if the object file for a key exists, - but there are no guarantees it has the right content. -} @@ -148,15 +131,13 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key is_unlocked = Just True is_missing = Just False - go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile) - =<< contentLockFile key + go contentfile = flip checklock contentfile =<< contentLockFile key #ifndef mingw32_HOST_OS - checkindirect contentfile = checkOr is_missing contentfile - {- In direct mode, the content file must exist, but - - the lock file generally won't exist unless a removal is in - - process. -} - checkdirect contentfile lockfile = + checklock Nothing contentfile = checkOr is_missing contentfile + {- The content file must exist, but the lock file generally + - won't exist unless a removal is in process. -} + checklock (Just lockfile) contentfile = ifM (liftIO $ doesFileExist contentfile) ( checkOr is_unlocked lockfile , return is_missing @@ -166,8 +147,8 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key Just True -> is_locked Just False -> is_unlocked #else - checkindirect f = liftIO $ ifM (doesFileExist f) - ( lockShared f >>= \case + checklock Nothing contentfile = liftIO $ ifM (doesFileExist contentfile) + ( lockShared contentfile >>= \case Nothing -> return is_locked Just lockhandle -> do dropLock lockhandle @@ -176,7 +157,7 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key ) {- In Windows, see if we can take a shared lock. If so, - remove the lock file to clean up after ourselves. -} - checkdirect contentfile lockfile = + checklock (Just lockfile) contentfile = ifM (liftIO $ doesFileExist contentfile) ( modifyContent lockfile $ liftIO $ lockShared lockfile >>= \case @@ -189,15 +170,12 @@ inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key ) #endif -{- Direct mode and especially Windows has to use a separate lock - - file from the content, since locking the actual content file - - would interfere with the user's use of it. -} +{- Windows has to use a separate lock file from the content, since + - locking the actual content file would interfere with the user's + - use of it. -} contentLockFile :: Key -> Annex (Maybe FilePath) #ifndef mingw32_HOST_OS -contentLockFile key = ifM isDirect - ( Just <$> calcRepo (gitAnnexContentLock key) - , return Nothing - ) +contentLockFile _ = pure Nothing #else contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) #endif @@ -207,9 +185,6 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) - - If locking fails, or the content is not present, throws an exception - rather than running the action. - - - - Note that, in direct mode, nothing prevents the user from directly - - editing or removing the content, even while it's locked by this. -} lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a lockContentShared key a = lockContentUsing lock key $ ifM (inAnnex key) @@ -467,8 +442,6 @@ withTmp key action = do - - When a key has associated pointer files, the object is hard - linked (or copied) to the files, and the object file is left thawed. - - - - In direct mode, moves the object file to the associated file, or files. - - What if the key there already has content? This could happen for - various reasons; perhaps the same content is being annexed again. @@ -496,7 +469,7 @@ withTmp key action = do moveAnnex :: Key -> FilePath -> Annex Bool moveAnnex key src = ifM (checkSecureHashes key) ( do - withObjectLoc key storeobject storedirect + withObjectLoc key storeobject return True , return False ) @@ -513,32 +486,6 @@ moveAnnex key src = ifM (checkSecureHashes key) ics <- mapM (populatePointerFile (Restage True) key dest) fs Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) ) - storeindirect = storeobject =<< calcRepo (gitAnnexLocation key) - - {- In direct mode, the associated file's content may be locally - - modified. In that case, it's preserved. However, the content - - we're moving into the annex may be the only extant copy, so - - it's important we not lose it. So, when the key's content - - cannot be moved to any associated file, it's stored in indirect - - mode. - -} - storedirect = storedirect' storeindirect - storedirect' fallback [] = fallback - storedirect' fallback (f:fs) = do - thawContent src - v <- isAnnexLink f - if Just key == v - then do - Direct.updateInodeCache key src - replaceFile f $ liftIO . moveFile src - chmodContent f - forM_ fs $ - Direct.addContentWhenNotPresent key f - else ifM (Direct.goodContent key f) - ( storedirect' alreadyhave fs - , storedirect' fallback fs - ) - alreadyhave = liftIO $ removeFile src checkSecureHashes :: Key -> Annex Bool @@ -647,8 +594,8 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex key {- Returns a file that contains an object's content, - and a check to run after the transfer is complete. - - - When a file is unlocked (or in direct mode), it's possble for its - - content to change as it's being sent. The check detects this case + - When a file is unlocked, it's possble for its content to + - change as it's being sent. The check detects this case - and returns False. - - Note that the returned check action is, in some cases, run in the @@ -656,47 +603,24 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex key - the sender. So it cannot rely on Annex state. -} prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool)) -prepSendAnnex key = withObjectLoc key indirect direct - where - indirect f = do - cache <- Database.Keys.getInodeCaches key - cache' <- if null cache - -- Since no inode cache is in the database, this - -- object is not currently unlocked. But that could - -- change while the transfer is in progress, so - -- generate an inode cache for the starting - -- content. - then maybeToList <$> - withTSDelta (liftIO . genInodeCache f) - else pure cache - return $ if null cache' - then Nothing - else Just (f, sameInodeCache f cache') - direct [] = return Nothing - direct (f:fs) = do - cache <- Direct.recordedInodeCache key - -- check that we have a good file - ifM (sameInodeCache f cache) - ( return $ Just (f, sameInodeCache f cache) - , direct fs - ) +prepSendAnnex key = withObjectLoc key $ \f -> do + cache <- Database.Keys.getInodeCaches key + cache' <- if null cache + -- Since no inode cache is in the database, this + -- object is not currently unlocked. But that could + -- change while the transfer is in progress, so + -- generate an inode cache for the starting + -- content. + then maybeToList <$> + withTSDelta (liftIO . genInodeCache f) + else pure cache + return $ if null cache' + then Nothing + else Just (f, sameInodeCache f cache') -{- Performs an action, passing it the location to use for a key's content. - - - - In direct mode, the associated files will be passed. But, if there are - - no associated files for a key, the indirect mode action will be - - performed instead. -} -withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a -withObjectLoc key indirect direct = ifM isDirect - ( do - fs <- Direct.associatedFiles key - if null fs - then goindirect - else direct fs - , goindirect - ) - where - goindirect = indirect =<< calcRepo (gitAnnexLocation key) +{- Performs an action, passing it the location to use for a key's content. -} +withObjectLoc :: Key -> (FilePath -> Annex a) -> Annex a +withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do @@ -714,17 +638,15 @@ cleanObjectLoc key cleaner = do {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: ContentRemovalLock -> Annex () -removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect - where - remove file = cleanObjectLoc key $ do +removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> + cleanObjectLoc key $ do secureErase file liftIO $ nukeFile file g <- Annex.gitRepo mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) =<< Database.Keys.getAssociatedFiles key Database.Keys.removeInodeCaches key - Direct.removeInodeCache key - + where -- Check associated pointer file for modifications, and reset if -- it's unmodified. resetpointer file = ifM (isUnmodified key file) @@ -736,18 +658,6 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect , void $ tryIO $ thawContent file ) - -- In direct mode, deletes the associated files or files, and replaces - -- them with symlinks. - removedirect fs = do - cache <- Direct.recordedInodeCache key - Direct.removeInodeCache key - mapM_ (resetfile cache) fs - - resetfile cache f = whenM (Direct.sameInodeCache f cache) $ do - l <- calcRepo $ gitAnnexLink f key - secureErase f - replaceFile f $ makeAnnexLink l - {- Check if a file contains the unmodified content of the key. - - The expensive way to tell is to do a verification of its content. @@ -802,35 +712,32 @@ moveBad key = do logStatus key InfoMissing return dest -data KeyLocation = InAnnex | InRepository | InAnywhere +data KeyLocation = InAnnex | InAnywhere -{- List of keys whose content exists in the specified location. - - - InAnnex only lists keys with content in .git/annex/objects, - - while InRepository, in direct mode, also finds keys with content - - in the work tree. InAnywhere lists all keys that have directories - - in .git/annex/objects, whether or not the content is present. - - - - Note that InRepository has to check whether direct mode files - - have goodContent. +{- InAnnex only lists keys with content in .git/annex/objects. + - InAnywhere lists all keys that have directories in + - .git/annex/objects, whether or not the content is present. -} -getKeysPresent :: KeyLocation -> Annex [Key] -getKeysPresent keyloc = do - direct <- isDirect +listKeys :: KeyLocation -> Annex [Key] +listKeys keyloc = do dir <- fromRepo gitAnnexObjectDir - s <- getstate direct + {- In order to run Annex monad actions within unsafeInterleaveIO, + - the current state is taken and reused. No changes made to this + - state will be preserved. + -} + s <- Annex.getState id depth <- gitAnnexLocationDepth <$> Annex.getGitConfig - liftIO $ walk s direct depth dir + liftIO $ walk s depth dir where - walk s direct depth dir = do + walk s depth dir = do contents <- catchDefaultIO [] (dirContents dir) if depth < 2 then do - contents' <- filterM (present s direct) contents + contents' <- filterM (present s) contents let keys = mapMaybe (fileKey . takeFileName) contents' continue keys [] else do - let deeper = walk s direct (depth - 1) + let deeper = walk s (depth - 1) continue [] (map deeper contents) continue keys [] = return keys continue keys (a:as) = do @@ -842,33 +749,12 @@ getKeysPresent keyloc = do InAnywhere -> True _ -> False - present _ _ _ | inanywhere = pure True - present _ False d = presentInAnnex d - present s True d = presentDirect s d <||> presentInAnnex d + present _ _ | inanywhere = pure True + present _ d = presentInAnnex d presentInAnnex = doesFileExist . contentfile contentfile d = d takeFileName d - presentDirect s d = case keyloc of - InAnnex -> return False - InRepository -> case fileKey (takeFileName d) of - Nothing -> return False - Just k -> Annex.eval s $ - anyM (Direct.goodContent k) =<< Direct.associatedFiles k - InAnywhere -> return True - - {- In order to run Annex monad actions within unsafeInterleaveIO, - - the current state is taken and reused. No changes made to this - - state will be preserved. - - - - As an optimsation, call inodesChanged to prime the state with - - a cached value that will be used in the call to goodContent. - -} - getstate direct = do - when direct $ - void inodesChanged - Annex.getState id - {- Things to do to record changes to content when shutting down. - - It's acceptable to avoid committing changes to the branch, diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 9f07d5b39c..a8920bb9c5 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -113,7 +113,7 @@ distributionDownloadComplete d dest cleanup t | transferDirection t == Download = do debug ["finished downloading git-annex distribution"] maybe (failedupgrade "bad download") go - =<< liftAnnex (withObjectLoc k fsckit (getM fsckit)) + =<< liftAnnex (withObjectLoc k fsckit) | otherwise = cleanup where k = distributionKey d diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index 2ed0a415ae..f4251c0929 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -90,12 +90,7 @@ fixupReq req@(Req {}) = v <- getAnnexLinkTarget' (getfile r) False case parseLinkTargetOrPointer =<< v of Nothing -> return r - Just k -> setfile r <$> - withObjectLoc k - -- indirect mode - return - -- direct mode - (return . Prelude.head) + Just k -> withObjectLoc k (pure . setfile r) _ -> return r externalDiffer :: String -> [String] -> Differ diff --git a/Command/Info.hs b/Command/Info.hs index 7e62ce56bf..97bcd6330e 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -527,7 +527,7 @@ cachedPresentData = do case presentData s of Just v -> return v Nothing -> do - v <- foldKeys <$> lift (getKeysPresent InRepository) + v <- foldKeys <$> lift (listKeys InAnnex) put s { presentData = Just v } return v diff --git a/Command/Multicast.hs b/Command/Multicast.hs index f6242e0214..6c6d2c418b 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -137,7 +137,7 @@ send ups fs = do mk <- lookupFile f case mk of Nothing -> noop - Just k -> withObjectLoc k (addlist f) (const noop) + Just k -> withObjectLoc k (addlist f) liftIO $ hClose h serverkey <- uftpKey diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 0f61e08d34..3f2a45c10f 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -59,7 +59,7 @@ finish :: Annex () finish = do annexdir <- fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir - leftovers <- removeUnannexed =<< getKeysPresent InAnnex + leftovers <- removeUnannexed =<< listKeys InAnnex prepareRemoveAnnexDir annexdir if null leftovers then liftIO $ removeDirectoryRecursive annexdir diff --git a/Command/Unused.hs b/Command/Unused.hs index ca6fb01d8d..95f953395d 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -84,9 +84,7 @@ checkUnused refspec = chain 0 return [] findunused False = do showAction "checking for unused data" - -- InAnnex, not InRepository because if a direct mode - -- file exists, it is obviously not unused. - excludeReferenced refspec =<< getKeysPresent InAnnex + excludeReferenced refspec =<< listKeys InAnnex chain _ [] = next $ return True chain v (a:as) = do v' <- a v diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index a7ea4efb64..98ec5df091 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -13,9 +13,9 @@ import Config import Config.Smudge import Annex.InodeSentinal import Annex.Link -import Annex.Content import Annex.CatFile import Annex.WorkTree +import qualified Annex.Content as Content import qualified Database.Keys import qualified Annex.Direct as Direct import qualified Annex.Content.Direct as Direct @@ -109,7 +109,7 @@ upgradeDirectWorkTree = do -- is recorded as an associated file, things will still -- work that way, it's just not ideal. ic <- withTSDelta (liftIO . genInodeCache f) - void $ linkToAnnex k f ic + void $ Content.linkToAnnex k f ic writepointer f k = liftIO $ do nukeFile f @@ -117,7 +117,7 @@ upgradeDirectWorkTree = do {- Remove all direct mode bookkeeping files. -} removeDirectCruft :: Annex () -removeDirectCruft = mapM_ go =<< getKeysPresent InAnywhere +removeDirectCruft = mapM_ go =<< Content.listKeys Content.InAnywhere where go k = do Direct.removeInodeCache k