git-annex 10.20231129 → 10.20231227
raw patch · 60 files changed
+902/−252 lines, 60 files
Files
- Annex/Branch.hs +11/−5
- Annex/Content.hs +25/−2
- Annex/Content/Presence.hs +2/−1
- Annex/FileMatcher.hs +11/−33
- Annex/Import.hs +9/−7
- Annex/Ingest.hs +7/−2
- Annex/Locations.hs +18/−0
- Annex/NumCopies.hs +6/−4
- Annex/VectorClock/Utility.hs +11/−1
- Assistant/TransferQueue.hs +1/−1
- CHANGELOG +32/−0
- COPYRIGHT +6/−0
- CmdLine/Batch.hs +1/−1
- CmdLine/GitAnnex/Options.hs +24/−9
- CmdLine/Seek.hs +13/−10
- Command/CheckPresentKey.hs +1/−1
- Command/Copy.hs +9/−7
- Command/Drop.hs +1/−1
- Command/FilterBranch.hs +1/−1
- Command/Find.hs +1/−1
- Command/FindKeys.hs +1/−1
- Command/Fix.hs +1/−1
- Command/Fsck.hs +1/−1
- Command/Get.hs +3/−2
- Command/Inprogress.hs +1/−1
- Command/List.hs +1/−1
- Command/Lock.hs +1/−1
- Command/Log.hs +11/−10
- Command/MetaData.hs +1/−1
- Command/Migrate.hs +109/−28
- Command/Mirror.hs +1/−1
- Command/Move.hs +33/−4
- Command/ReKey.hs +25/−15
- Command/Sync.hs +19/−12
- Command/Unannex.hs +1/−1
- Command/Unlock.hs +1/−1
- Command/WhereUsed.hs +1/−1
- Command/Whereis.hs +1/−1
- Database/ContentIdentifier.hs +11/−1
- Database/Handle.hs +5/−3
- Database/Init.hs +11/−4
- Database/RawFilePath.hs +95/−0
- Git/Log.hs +29/−21
- Git/Tree.hs +22/−11
- Logs.hs +6/−1
- Logs/Export.hs +1/−1
- Logs/Location.hs +8/−1
- Logs/Migrate.hs +203/−0
- Logs/PreferredContent.hs +7/−6
- Logs/Presence.hs +8/−7
- Logs/Presence/Pure.hs +6/−2
- Logs/Web.hs +1/−1
- Remote.hs +12/−6
- Types/GitConfig.hs +2/−0
- Utility/CoProcess.hs +27/−13
- Utility/Matcher.hs +21/−0
- Utility/TimeStamp.hs +15/−1
- Utility/Tmp.hs +6/−1
- git-annex.cabal +3/−1
- stack.yaml +1/−1
Annex/Branch.hs view
@@ -14,6 +14,7 @@ hasSibling, siblingBranches, create,+ getBranch, UpdateMade(..), update, forceUpdate,@@ -120,7 +121,7 @@ create :: Annex () create = void getBranch -{- Returns the ref of the branch, creating it first if necessary. -}+{- Returns the sha of the branch, creating it first if necessary. -} getBranch :: Annex Git.Ref getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha where@@ -920,10 +921,14 @@ {- Grafts a treeish into the branch at the specified location, - and then removes it. This ensures that the treeish won't get garbage - collected, and will always be available as long as the git-annex branch- - is available. -}-rememberTreeish :: Git.Ref -> TopFilePath -> Annex ()-rememberTreeish treeish graftpoint = lockJournal $ rememberTreeishLocked treeish graftpoint-rememberTreeishLocked :: Git.Ref -> TopFilePath -> JournalLocked -> Annex ()+ - is available.+ -+ - Returns the sha of the git commit made to the git-annex branch.+ -}+rememberTreeish :: Git.Ref -> TopFilePath -> Annex Git.Sha+rememberTreeish treeish graftpoint = lockJournal $+ rememberTreeishLocked treeish graftpoint+rememberTreeishLocked :: Git.Ref -> TopFilePath -> JournalLocked -> Annex Git.Sha rememberTreeishLocked treeish graftpoint jl = do branchref <- getBranch updateIndex jl branchref@@ -940,6 +945,7 @@ -- and the index was updated to that above, so it's safe to -- say that the index contains c'. setIndexSha c'+ return c' {- Runs an action on the content of selected files from the branch. - This is much faster than reading the content of each file in turn,
Annex/Content.hs view
@@ -1,6 +1,6 @@ {- git-annex file content managing -- - Copyright 2010-2022 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -66,6 +66,7 @@ getKeyStatus, getKeyFileStatus, cleanObjectDirs,+ contentSize, ) where import System.IO.Unsafe (unsafeInterleaveIO)@@ -449,7 +450,7 @@ checkSecureHashes' key = checkSecureHashes key >>= \case Nothing -> return True Just msg -> do- warning $ UnquotedString $ msg ++ "to annex objects"+ warning $ UnquotedString $ msg ++ " to annex objects" return False data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop@@ -916,3 +917,25 @@ ) _ -> return s +{- Gets the size of the content of a key when it is present.+ - Useful when the key does not have keySize set. + -+ - When the object file appears possibly modified with annex.thin set, does+ - not do an expensive verification that the content is good, just returns+ - Nothing.+ -}+contentSize :: Key -> Annex (Maybe FileSize)+contentSize key = catchDefaultIO Nothing $+ withObjectLoc key $ \loc ->+ withTSDelta (liftIO . genInodeCache loc) >>= \case+ Just ic -> ifM (unmodified ic)+ ( return (Just (inodeCacheFileSize ic))+ , return Nothing+ )+ Nothing -> return Nothing+ where+ unmodified ic =+ ifM (annexThin <$> Annex.getGitConfig)+ ( isUnmodifiedCheap' key ic+ , return True+ )
Annex/Content/Presence.hs view
@@ -18,6 +18,7 @@ isUnmodified, isUnmodified', isUnmodifiedCheap,+ isUnmodifiedCheap', withContentLockFile, contentLockFile, ) where@@ -206,7 +207,7 @@ - within a small time window (eg 1 second). -} isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool-isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key) +isUnmodifiedCheap key f = maybe (pure False) (isUnmodifiedCheap' key) =<< withTSDelta (liftIO . genInodeCache f) isUnmodifiedCheap' :: Key -> InodeCache -> Annex Bool
Annex/FileMatcher.hs view
@@ -16,7 +16,6 @@ matchAll, PreferredContentData(..), preferredContentTokens,- preferredContentKeylessTokens, preferredContentParser, ParseToken, parsedToMatcher,@@ -139,19 +138,15 @@ where splitparens = segmentDelim (`elem` "()") -commonKeylessTokens :: LimitBy -> [ParseToken (MatchFiles Annex)]-commonKeylessTokens lb =+commonTokens :: LimitBy -> [ParseToken (MatchFiles Annex)]+commonTokens lb = [ SimpleToken "anything" (simply limitAnything) , SimpleToken "nothing" (simply limitNothing) , ValueToken "include" (usev limitInclude) , ValueToken "exclude" (usev limitExclude) , ValueToken "largerthan" (usev $ limitSize lb "largerthan" (>)) , ValueToken "smallerthan" (usev $ limitSize lb "smallerthan" (<))- ]--commonKeyedTokens :: [ParseToken (MatchFiles Annex)]-commonKeyedTokens = - [ SimpleToken "unused" (simply limitUnused)+ , SimpleToken "unused" (simply limitUnused) ] data PreferredContentData = PCD@@ -162,25 +157,12 @@ , repoUUID :: Maybe UUID } --- Tokens of preferred content expressions that do not need a Key to be--- known. ------ When importing from a special remote, this is used to match--- some preferred content expressions before the content is downloaded,--- so the Key is not known.-preferredContentKeylessTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)]-preferredContentKeylessTokens pcd =+preferredContentTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)]+preferredContentTokens pcd = [ SimpleToken "standard" (call "standard" $ matchStandard pcd) , SimpleToken "groupwanted" (call "groupwanted" $ matchGroupWanted pcd) , SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir "inpreferreddir")- ] ++ commonKeylessTokens LimitAnnexFiles- where- preferreddir = maybe "public" fromProposedAccepted $- M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd--preferredContentKeyedTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)]-preferredContentKeyedTokens pcd =- [ SimpleToken "present" (simply $ limitPresent $ repoUUID pcd)+ , SimpleToken "present" (simply $ limitPresent $ repoUUID pcd) , SimpleToken "securehash" (simply limitSecureHash) , ValueToken "copies" (usev limitCopies) , ValueToken "lackingcopies" (usev $ limitLackingCopies "lackingcopies" False)@@ -189,13 +171,10 @@ , ValueToken "metadata" (usev limitMetaData) , ValueToken "inallgroup" (usev $ limitInAllGroup $ getGroupMap pcd) , ValueToken "onlyingroup" (usev $ limitOnlyInGroup $ getGroupMap pcd)- ] ++ commonKeyedTokens--preferredContentTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)]-preferredContentTokens pcd = concat- [ preferredContentKeylessTokens pcd- , preferredContentKeyedTokens pcd- ]+ ] ++ commonTokens LimitAnnexFiles+ where+ preferreddir = maybe "public" fromProposedAccepted $+ M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)] preferredContentParser tokens = map (parseToken tokens) . tokenizeMatcher@@ -210,8 +189,7 @@ const $ Left $ "\""++n++"\" not supported; not built with MagicMime support" #endif let parse = parseToken $- commonKeyedTokens ++- commonKeylessTokens LimitDiskFiles +++ commonTokens LimitDiskFiles ++ #ifdef WITH_MAGICMIME [ mimer "mimetype" $ matchMagic "mimetype" getMagicMimeType providedMimeType userProvidedMimeType
Annex/Import.hs view
@@ -990,19 +990,21 @@ - - Only keyless tokens are supported, because the keys are not known - until an imported file is downloaded, which is too late to bother- - excluding it from an import.+ - excluding it from an import. So prunes any tokens in the preferred+ - content expression that need keys. -} makeImportMatcher :: Remote -> Annex (Either String (FileMatcher Annex))-makeImportMatcher r = load preferredContentKeylessTokens >>= \case+makeImportMatcher r = load preferredContentTokens >>= \case Nothing -> return $ Right (matchAll, matcherdesc) Just (Right v) -> return $ Right (v, matcherdesc)- Just (Left err) -> load preferredContentTokens >>= \case- Just (Left err') -> return $ Left err'- _ -> return $ Left $- "The preferred content expression contains terms that cannot be checked when importing: " ++ err+ Just (Left err) -> return $ Left err where- load t = M.lookup (Remote.uuid r) . fst <$> preferredRequiredMapsLoad' t+ load t = M.lookup (Remote.uuid r) . fst+ <$> preferredRequiredMapsLoad' pruneImportMatcher t matcherdesc = MatcherDesc "preferred content"++pruneImportMatcher :: Utility.Matcher.Matcher (MatchFiles a) -> Utility.Matcher.Matcher (MatchFiles a)+pruneImportMatcher = Utility.Matcher.pruneMatcher matchNeedsKey {- Gets the ImportableContents from the remote. -
Annex/Ingest.hs view
@@ -19,6 +19,7 @@ finishIngestUnlocked, cleanOldKeys, addSymlink,+ genSymlink, makeLink, addUnlocked, CheckGitIgnore(..),@@ -38,6 +39,7 @@ import Annex.CurrentBranch import Annex.CheckIgnore import Logs.Location+import qualified Git import qualified Annex import qualified Database.Keys import Config@@ -320,9 +322,12 @@ {- Creates the symlink to the annexed content, and stages it in git. -} addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex ()-addSymlink file key mcache = do+addSymlink file key mcache = stageSymlink file =<< genSymlink file key mcache++genSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex Git.Sha+genSymlink file key mcache = do linktarget <- makeLink file key mcache- stageSymlink file =<< hashSymlink linktarget+ hashSymlink linktarget {- Parameters to pass to git add, forcing addition of ignored files. -
Annex/Locations.hs view
@@ -54,6 +54,10 @@ gitAnnexRestageLock, gitAnnexAdjustedBranchUpdateLog, gitAnnexAdjustedBranchUpdateLock,+ gitAnnexMigrateLog,+ gitAnnexMigrateLock,+ gitAnnexMigrationsLog,+ gitAnnexMigrationsLock, gitAnnexMoveLog, gitAnnexMoveLock, gitAnnexExportDir,@@ -406,6 +410,20 @@ gitAnnexAdjustedBranchUpdateLock :: Git.Repo -> RawFilePath gitAnnexAdjustedBranchUpdateLock r = gitAnnexDir r P.</> "adjust.lck"++{- .git/annex/migrate.log is used to log migrations before committing them. -}+gitAnnexMigrateLog :: Git.Repo -> RawFilePath+gitAnnexMigrateLog r = gitAnnexDir r P.</> "migrate.log"++gitAnnexMigrateLock :: Git.Repo -> RawFilePath+gitAnnexMigrateLock r = gitAnnexDir r P.</> "migrate.lck"++{- .git/annex/migrations.log is used to log committed migrations. -}+gitAnnexMigrationsLog :: Git.Repo -> RawFilePath+gitAnnexMigrationsLog r = gitAnnexDir r P.</> "migrations.log"++gitAnnexMigrationsLock :: Git.Repo -> RawFilePath+gitAnnexMigrationsLock r = gitAnnexDir r P.</> "migrations.lck" {- .git/annex/move.log is used to log moves that are in progress, - to better support resuming an interrupted move. -}
Annex/NumCopies.hs view
@@ -282,9 +282,11 @@ showNote "unsafe" if length have < fromNumCopies neednum then showLongNote $ UnquotedString $- "Could only verify the existence of " ++- show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++ - " necessary " ++ pluralCopies (fromNumCopies neednum)+ if fromNumCopies neednum == 1+ then "Could not verify the existence of the 1 necessary copy."+ else "Could only verify the existence of " +++ show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++ + " necessary " ++ pluralCopies (fromNumCopies neednum) ++ "." else do showLongNote $ UnquotedString $ "Unable to lock down " ++ show (fromMinCopies needmin) ++ " " ++ pluralCopies (fromMinCopies needmin) ++ @@ -317,7 +319,7 @@ verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy]) verifiableCopies key exclude = do locs <- Remote.keyLocations key- (remotes, trusteduuids) <- Remote.remoteLocations locs+ (remotes, trusteduuids) <- Remote.remoteLocations (Remote.IncludeIgnored False) locs =<< trustGet Trusted untrusteduuids <- trustGet UnTrusted let exclude' = exclude ++ untrusteduuids
Annex/VectorClock/Utility.hs view
@@ -20,4 +20,14 @@ go (Just s) = case parsePOSIXTime s of Just t -> return (pure (CandidateVectorClock t)) Nothing -> timebased- timebased = return (CandidateVectorClock <$> getPOSIXTime)+ -- Avoid using fractional seconds in the CandidateVectorClock.+ -- This reduces the size of the packed git-annex branch by up+ -- to 8%. + --+ -- Due to the use of vector clocks, high resolution timestamps are+ -- not necessary to make clear which information is most recent when+ -- eg, a value is changed repeatedly in the same second. In such a+ -- case, the vector clock will be advanced to the next second after+ -- the last modification.+ timebased = return $+ CandidateVectorClock . truncateResolution 0 <$> getPOSIXTime
Assistant/TransferQueue.hs view
@@ -93,7 +93,7 @@ filter (\r -> not (inset s r || Remote.readonly r)) (syncDataRemotes st) where- locs = S.fromList . map Remote.uuid <$> Remote.keyPossibilities k+ locs = S.fromList . map Remote.uuid <$> Remote.keyPossibilities (Remote.IncludeIgnored False) k inset s r = S.member (Remote.uuid r) s gentransfer r = Transfer { transferDirection = direction
CHANGELOG view
@@ -1,3 +1,35 @@+git-annex (10.20231227) upstream; urgency=medium++ * migrate: Support distributed migrations by recording each migration,+ and adding a --update option that updates the local repository+ incrementally, hard linking annex objects to their new keys.+ * pull, sync: When operating on content, automatically handle+ distributed migrations.+ * Added annex.syncmigrations config that can be set to false to prevent+ pull and sync from migrating object content.+ * migrate: Added --apply option that (re)applies all recorded + distributed migrations to the objects in repository.+ * migrate: Support adding size to URL keys that were added with+ --relaxed, by running eg: git-annex migrate --backend=URL foo+ * When importing from a special remote, support preferred content+ expressions that use terms that match on keys (eg "present", "copies=1").+ Such terms are ignored when importing, since the key is not known yet.+ Before, such expressions caused the import to fail.+ * Support git-annex copy/move --from-anywhere --to remote.+ * Make git-annex get/copy/move --from foo override configuration of + remote.foo.annex-ignore, as documented.+ * Lower precision of timestamps in git-annex branch, which can reduce the+ size of the branch by up to 8%.+ * sync: Fix locking problems during merge when annex.pidlock is set.+ * Avoid a problem with temp file names ending in "." on certian+ filesystems that have problems with such filenames.+ * sync, push: Avoid trying to send individual files to special remotes+ configured with importtree=yes exporttree=no, which would always fail.+ * Fix a crash opening sqlite databases when run in a non-unicode locale.+ (Needs persistent-sqlite 2.13.3.)++ -- Joey Hess <id@joeyh.name> Wed, 27 Dec 2023 19:27:37 -0400+ git-annex (10.20231129) upstream; urgency=medium * Fix bug in git-annex copy --from --to that skipped files that were
COPYRIGHT view
@@ -64,6 +64,12 @@ The full text of version 2 of the GPL is distributed in /usr/share/common-licenses/GPL-2 on Debian systems. +Files: Database/RawFilePath.hs+Copyright: © 2012 Michael Snoyman, http://www.yesodweb.com/+ © 2023 Joey Hess <id@joeyh.name>+License: Expat+ The text of the Expat license is in the Expat section below.+ Files: doc/tips/automatically_adding_metadata/pre-commit-annex Copyright: 2014 Joey Hess <id@joeyh.name> 2016 Klaus Ethgen <Klaus@Ethgen.ch>
CmdLine/Batch.hs view
@@ -198,7 +198,7 @@ Right f -> lookupKeyStaged f >>= \case Nothing -> return Nothing Just k -> checkpresent k $- startAction seeker si f k+ startAction seeker Nothing si f k Left k -> ifM (matcher (MatchingInfo (mkinfo k))) ( checkpresent k $ keyaction (si, k, mkActionItem k)
CmdLine/GitAnnex/Options.hs view
@@ -162,40 +162,55 @@ <> completeRemotes ) +parseFromAnywhereOption :: Parser Bool+parseFromAnywhereOption = switch+ ( long "from-anywhere"+ <> help "from any remote"+ )+ parseRemoteOption :: Parser RemoteName parseRemoteOption = strOption ( long "remote" <> metavar paramRemote <> completeRemotes ) --- | From or to a remote, or both, or a special --to=here+-- | --from or --to a remote, or both, or a special --to=here,+-- or --from-anywhere --to remote. data FromToHereOptions = FromOrToRemote FromToOptions | ToHere | FromRemoteToRemote (DeferredParse Remote) (DeferredParse Remote)+ | FromAnywhereToRemote (DeferredParse Remote) parseFromToHereOptions :: Parser (Maybe FromToHereOptions) parseFromToHereOptions = go <$> optional parseFromOption <*> optional parseToOption+ <*> parseFromAnywhereOption where- go (Just from) (Just to) = Just $ FromRemoteToRemote+ go _ (Just to) True = Just $ FromAnywhereToRemote+ (mkParseRemoteOption to)+ go (Just from) (Just to) _ = Just $ FromRemoteToRemote (mkParseRemoteOption from) (mkParseRemoteOption to)- go (Just from) Nothing = Just $ FromOrToRemote+ go (Just from) Nothing _ = Just $ FromOrToRemote (FromRemote $ mkParseRemoteOption from)- go Nothing (Just to) = Just $ case to of+ go Nothing (Just to) _ = Just $ case to of "here" -> ToHere "." -> ToHere _ -> FromOrToRemote $ ToRemote $ mkParseRemoteOption to- go Nothing Nothing = Nothing+ go Nothing Nothing _ = Nothing instance DeferredParseClass FromToHereOptions where- finishParse (FromOrToRemote v) = FromOrToRemote <$> finishParse v+ finishParse (FromOrToRemote v) = + FromOrToRemote <$> finishParse v finishParse ToHere = pure ToHere- finishParse (FromRemoteToRemote v1 v2) = FromRemoteToRemote- <$> finishParse v1- <*> finishParse v2+ finishParse (FromRemoteToRemote v1 v2) = + FromRemoteToRemote+ <$> finishParse v1+ <*> finishParse v2+ finishParse (FromAnywhereToRemote v) = + FromAnywhereToRemote <$> finishParse v -- Options for acting on keys, rather than work tree files. data KeyOptions
CmdLine/Seek.hs view
@@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. -- - Copyright 2010-2022 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -58,11 +58,14 @@ import qualified System.FilePath.ByteString as P data AnnexedFileSeeker = AnnexedFileSeeker- { startAction :: SeekInput -> RawFilePath -> Key -> CommandStart+ { startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart , checkContentPresent :: Maybe Bool , usesLocationLog :: Bool } +-- The Sha that was read to get the Key.+newtype KeySha = KeySha Git.Sha+ withFilesInGitAnnex :: WarnUnmatchWhen -> AnnexedFileSeeker -> WorkTreeItems -> CommandSeek withFilesInGitAnnex ww a l = seekFilteredKeys a $ seekHelper fst3 ww LsFiles.inRepoDetails l@@ -375,9 +378,9 @@ propagateLsFilesError cleanup where finisher mi oreader checktimelimit = liftIO oreader >>= \case- Just ((si, f), content) -> checktimelimit (liftIO discard) $ do- keyaction f mi content $ - commandAction . startAction seeker si f+ Just ((si, f, keysha), content) -> checktimelimit (liftIO discard) $ do+ keyaction f mi content $+ commandAction . startAction seeker keysha si f finisher mi oreader checktimelimit Nothing -> return () where@@ -386,12 +389,12 @@ Just _ -> discard precachefinisher mi lreader checktimelimit = liftIO lreader >>= \case- Just ((logf, (si, f), k), logcontent) -> checktimelimit (liftIO discard) $ do+ Just ((logf, (si, f, keysha), k), logcontent) -> checktimelimit (liftIO discard) $ do maybe noop (Annex.Branch.precache logf) logcontent checkMatcherWhen mi (matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) (MatchingFile $ FileInfo f f (Just k))- (commandAction $ startAction seeker si f k)+ (commandAction $ startAction seeker keysha si f k) precachefinisher mi lreader checktimelimit Nothing -> return () where@@ -400,11 +403,11 @@ Just _ -> discard precacher mi config oreader lfeeder lcloser = liftIO oreader >>= \case- Just ((si, f), content) -> do+ Just ((si, f, keysha), content) -> do keyaction f mi content $ \k -> let logf = locationLogFile config k ref = Git.Ref.branchFileRef Annex.Branch.fullname logf- in liftIO $ lfeeder ((logf, (si, f), k), ref)+ in liftIO $ lfeeder ((logf, (si, f, keysha), k), ref) precacher mi config oreader lfeeder lcloser Nothing -> liftIO $ void lcloser @@ -415,7 +418,7 @@ (not ((matcherNeedsKey mi || matcherNeedsLocationLog mi) && not (matcherNeedsFileName mi))) (MatchingFile $ FileInfo f f Nothing)- (liftIO $ ofeeder ((si, f), sha))+ (liftIO $ ofeeder ((si, f, Just (KeySha sha)), sha)) keyaction f mi content a = case parseLinkTargetOrPointerLazy =<< content of
Command/CheckPresentKey.hs view
@@ -51,7 +51,7 @@ check ks mr = case mr of Just r -> go Nothing [r] Nothing -> do- mostlikely <- Remote.keyPossibilities k+ mostlikely <- Remote.keyPossibilities (Remote.IncludeIgnored False) k otherremotes <- flip Remote.remotesWithoutUUID (map Remote.uuid mostlikely) <$> remoteList
Command/Copy.hs view
@@ -63,12 +63,13 @@ ww = WarnUnmatchLsFiles "copy" seeker = AnnexedFileSeeker- { startAction = start o fto+ { startAction = const $ start o fto , checkContentPresent = case fto of FromOrToRemote (FromRemote _) -> Just False FromOrToRemote (ToRemote _) -> Just True ToHere -> Just False FromRemoteToRemote _ _ -> Nothing+ FromAnywhereToRemote _ -> Nothing , usesLocationLog = True } keyaction = Command.Move.startKey fto Command.Move.RemoveNever@@ -84,12 +85,13 @@ | autoMode o = want <||> numCopiesCheck file key (<) | otherwise = return True want = case fto of- FromOrToRemote (ToRemote dest) ->- (Remote.uuid <$> getParsed dest) >>= checkwantsend+ FromOrToRemote (ToRemote dest) -> checkwantsend dest FromOrToRemote (FromRemote _) -> checkwantget ToHere -> checkwantget- FromRemoteToRemote _ dest ->- (Remote.uuid <$> getParsed dest) >>= checkwantsend- - checkwantsend = wantGetBy False (Just key) (AssociatedFile (Just file))+ FromRemoteToRemote _ dest -> checkwantsend dest+ FromAnywhereToRemote dest -> checkwantsend dest++ checkwantsend dest = + (Remote.uuid <$> getParsed dest) >>=+ wantGetBy False (Just key) (AssociatedFile (Just file)) checkwantget = wantGet False (Just key) (AssociatedFile (Just file))
Command/Drop.hs view
@@ -60,7 +60,7 @@ then pure Nothing else pure (Just remote) let seeker = AnnexedFileSeeker- { startAction = start o from+ { startAction = const $ start o from , checkContentPresent = case from of Nothing -> Just True Just _ -> Nothing
Command/FilterBranch.hs view
@@ -157,7 +157,7 @@ =<< Annex.Branch.get f next (return True) let seeker = AnnexedFileSeeker- { startAction = \_ _ k -> addkeyinfo k+ { startAction = \_ _ _ k -> addkeyinfo k , checkContentPresent = Nothing , usesLocationLog = True }
Command/Find.hs view
@@ -63,7 +63,7 @@ checkNotBareRepo isterminal <- liftIO $ checkIsTerminal stdout seeker <- contentPresentUnlessLimited $ AnnexedFileSeeker- { startAction = start o isterminal+ { startAction = const (start o isterminal) , checkContentPresent = Nothing , usesLocationLog = False }
Command/FindKeys.hs view
@@ -33,7 +33,7 @@ , usesLocationLog = False -- startAction is not actually used since this -- is not used to seek files- , startAction = \_ _ key -> start' o isterminal key+ , startAction = \_ _ _ key -> start' o isterminal key } withKeyOptions (Just WantAllKeys) False seeker (commandAction . start o isterminal)
Command/Fix.hs view
@@ -37,7 +37,7 @@ where ww = WarnUnmatchLsFiles "fix" seeker = AnnexedFileSeeker- { startAction = start FixAll+ { startAction = const $ start FixAll , checkContentPresent = Nothing , usesLocationLog = False }
Command/Fsck.hs view
@@ -102,7 +102,7 @@ checkDeadRepo u i <- prepIncremental u (incrementalOpt o) let seeker = AnnexedFileSeeker- { startAction = start from i+ { startAction = const $ start from i , checkContentPresent = Nothing , usesLocationLog = True }
Command/Get.hs view
@@ -41,7 +41,7 @@ seek o = startConcurrency transferStages $ do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) let seeker = AnnexedFileSeeker- { startAction = start o from+ { startAction = const $ start o from , checkContentPresent = Just False , usesLocationLog = True }@@ -87,7 +87,8 @@ {- Try to find a copy of the file in one of the remotes, - and copy it to here. -} getKey :: Key -> AssociatedFile -> Annex Bool-getKey key afile = getKey' key afile =<< Remote.keyPossibilities key+getKey key afile = getKey' key afile+ =<< Remote.keyPossibilities (Remote.IncludeIgnored False) key getKey' :: Key -> AssociatedFile -> [Remote] -> Annex Bool getKey' key afile = dispatch
Command/Inprogress.hs view
@@ -42,7 +42,7 @@ _ -> do let s = S.fromList ts let seeker = AnnexedFileSeeker- { startAction = start isterminal s+ { startAction = const $ start isterminal s , checkContentPresent = Nothing , usesLocationLog = False }
Command/List.hs view
@@ -50,7 +50,7 @@ list <- getList o printHeader list let seeker = AnnexedFileSeeker- { startAction = start list+ { startAction = const $ start list , checkContentPresent = Nothing , usesLocationLog = True }
Command/Lock.hs view
@@ -34,7 +34,7 @@ where ww = WarnUnmatchLsFiles "lock" seeker = AnnexedFileSeeker- { startAction = start+ { startAction = const start , checkContentPresent = Nothing , usesLocationLog = False }
Command/Log.hs view
@@ -138,7 +138,7 @@ zone <- liftIO getCurrentTimeZone outputter <- mkOutputter m zone o <$> jsonOutputEnabled let seeker = AnnexedFileSeeker- { startAction = start o outputter+ { startAction = const $ start o outputter , checkContentPresent = Nothing -- the way this uses the location log would not be -- helped by precaching the current value@@ -165,7 +165,7 @@ void $ liftIO cleanup stop -{- Displays changes made. Only works when all the RefChanges are for the+{- Displays changes made. Only works when all the LoggedFileChanges are for the - same key. The method is to compare each value with the value - after it in the list, which is the old version of the value. -@@ -179,7 +179,7 @@ - This also generates subtly better output when the git-annex branch - got diverged. -}-showLogIncremental :: Outputter -> [RefChange Key] -> Annex ()+showLogIncremental :: Outputter -> [LoggedFileChange Key] -> Annex () showLogIncremental outputter ps = do sets <- mapM (getset newref) ps previous <- maybe (return genesis) (getset oldref) (lastMaybe ps)@@ -196,7 +196,7 @@ {- Displays changes made. Streams, and can display changes affecting - different keys, but does twice as much reading of logged values - as showLogIncremental. -}-showLog :: (ActionItem -> Outputter) -> [RefChange Key] -> Annex ()+showLog :: (ActionItem -> Outputter) -> [LoggedFileChange Key] -> Annex () showLog outputter cs = forM_ cs $ \c -> do let ai = mkActionItem (changed c) new <- S.fromList <$> loggedLocationsRef (newref c)@@ -279,7 +279,7 @@ - once the location log file is gone avoids it checking all the way back - to commit 0 to see if it used to exist, so generally speeds things up a - *lot* for newish files. -}-getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange Key], IO Bool)+getKeyLog :: Key -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool) getKeyLog key os = do top <- fromRepo Git.repoPath p <- liftIO $ relPathCwdToFile top@@ -287,11 +287,12 @@ let logfile = p P.</> locationLogFile config key getGitLogAnnex [fromRawFilePath logfile] (Param "--remove-empty" : os) -getGitLogAnnex :: [FilePath] -> [CommandParam] -> Annex ([RefChange Key], IO Bool)+getGitLogAnnex :: [FilePath] -> [CommandParam] -> Annex ([LoggedFileChange Key], IO Bool) getGitLogAnnex fs os = do config <- Annex.getGitConfig- let fileselector = locationLogFileKey config . toRawFilePath- inRepo $ getGitLog Annex.Branch.fullname fs os fileselector+ let fileselector = \_sha f ->+ locationLogFileKey config (toRawFilePath f)+ inRepo $ getGitLog Annex.Branch.fullname Nothing fs os fileselector showTimeStamp :: TimeZone -> String -> POSIXTime -> String showTimeStamp zone format = formatTime defaultTimeLocale format@@ -321,13 +322,13 @@ -- and to the trust log. getlog = do config <- Annex.getGitConfig- let fileselector = \f -> let f' = toRawFilePath f in+ let fileselector = \_sha f -> let f' = toRawFilePath f in case locationLogFileKey config f' of Just k -> Just (Right k) Nothing | f' == trustLog -> Just (Left ()) | otherwise -> Nothing- inRepo $ getGitLog Annex.Branch.fullname []+ inRepo $ getGitLog Annex.Branch.fullname Nothing [] [ Param "--date-order" , Param "--reverse" ]
Command/MetaData.hs view
@@ -77,7 +77,7 @@ c <- currentVectorClock let ww = WarnUnmatchLsFiles "metadata" let seeker = AnnexedFileSeeker- { startAction = start c o+ { startAction = const $ start c o , checkContentPresent = Nothing , usesLocationLog = False }
Command/Migrate.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -15,9 +15,15 @@ import qualified Command.ReKey import qualified Command.Fsck import qualified Annex+import Logs.Migrate import Logs.MetaData import Logs.Web+import Logs.Location import Utility.Metered+import qualified Database.Keys+import Git.FilePath+import Annex.Link+import Annex.UUID cmd :: Command cmd = withAnnexOptions [backendOption, annexedMatchingOptions, jsonOptions] $@@ -27,6 +33,8 @@ data MigrateOptions = MigrateOptions { migrateThese :: CmdParams+ , updateOption :: Bool+ , applyOption :: Bool , removeSize :: Bool } @@ -34,12 +42,27 @@ optParser desc = MigrateOptions <$> cmdParams desc <*> switch+ ( long "update"+ <> help "incrementally apply migrations performed elsewhere"+ )+ <*> switch+ ( long "apply"+ <> help "(re)apply migrations performed elsewhere"+ )+ <*> switch ( long "remove-size" <> help "remove size field from keys" ) seek :: MigrateOptions -> CommandSeek-seek o = withFilesInGitAnnex ww seeker =<< workTreeItems ww (migrateThese o)+seek o+ | updateOption o || applyOption o = do+ unless (null (migrateThese o)) $+ error "Cannot combine --update or --apply with files to migrate."+ seekDistributedMigrations (not (applyOption o))+ | otherwise = do+ withFilesInGitAnnex ww seeker =<< workTreeItems ww (migrateThese o)+ commitMigration where ww = WarnUnmatchLsFiles "migrate" seeker = AnnexedFileSeeker@@ -48,8 +71,16 @@ , usesLocationLog = False } -start :: MigrateOptions -> SeekInput -> RawFilePath -> Key -> CommandStart-start o si file key = do+seekDistributedMigrations :: Bool -> CommandSeek+seekDistributedMigrations incremental =+ streamNewDistributedMigrations incremental $ \oldkey newkey ->+ -- Not using commandAction because this is not necessarily+ -- concurrency safe, and also is unlikely to be sped up+ -- by multiple jobs.+ void $ includeCommandAction $ update oldkey newkey++start :: MigrateOptions -> Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart+start o ksha si file key = do forced <- Annex.getRead Annex.force v <- Backend.getBackend (fromRawFilePath file) key case v of@@ -57,27 +88,27 @@ Just oldbackend -> do exists <- inAnnex key newbackend <- chooseBackend file- if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists+ if (newbackend /= oldbackend || upgradableKey oldbackend || forced) && exists then go False oldbackend newbackend- else if removeSize o && exists- then go True oldbackend oldbackend+ else if cantweaksize newbackend oldbackend && exists+ then go True oldbackend newbackend else stop where- go onlyremovesize oldbackend newbackend =+ go onlytweaksize oldbackend newbackend = do+ keyrec <- case ksha of+ Just (KeySha s) -> pure (MigrationRecord s)+ Nothing -> error "internal" starting "migrate" (mkActionItem (key, file)) si $- perform onlyremovesize o file key oldbackend newbackend+ perform onlytweaksize o file key keyrec oldbackend newbackend -{- Checks if a key is upgradable to a newer representation.- - - - Reasons for migration:- - - Ideally, all keys have file size metadata. Old keys may not.- - - Something has changed in the backend, such as a bug fix.- -}-upgradableKey :: Backend -> Key -> Bool-upgradableKey backend key = isNothing (fromKey keySize key) || backendupgradable- where- backendupgradable = maybe False (\a -> a key) (canUpgradeKey backend)+ cantweaksize newbackend oldbackend+ | removeSize o = isJust (fromKey keySize key)+ | newbackend /= oldbackend = False+ | isNothing (fromKey keySize key) = True+ | otherwise = False + upgradableKey oldbackend = maybe False (\a -> a key) (canUpgradeKey oldbackend)+ {- Store the old backend's key in the new backend - The old backend's key is not dropped from it, because there may - be other files still pointing at that key.@@ -87,14 +118,14 @@ - data cannot get corrupted after the fsck but before the new key is - generated. -}-perform :: Bool -> MigrateOptions -> RawFilePath -> Key -> Backend -> Backend -> CommandPerform-perform onlyremovesize o file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbackend)+perform :: Bool -> MigrateOptions -> RawFilePath -> Key -> MigrationRecord -> Backend -> Backend -> CommandPerform+perform onlytweaksize o file oldkey oldkeyrec oldbackend newbackend = go =<< genkey (fastMigrate oldbackend) where go Nothing = stop go (Just (newkey, knowngoodcontent))- | knowngoodcontent = finish (removesize newkey)+ | knowngoodcontent = finish =<< tweaksize newkey | otherwise = stopUnless checkcontent $- finish (removesize newkey)+ finish =<< tweaksize newkey checkcontent = Command.Fsck.checkBackend oldbackend oldkey KeyPresent afile finish newkey = ifM (Command.ReKey.linkKey file oldkey newkey) ( do@@ -104,10 +135,11 @@ urls <- getUrls oldkey forM_ urls $ \url -> setUrlPresent newkey url- next $ Command.ReKey.cleanup file newkey+ next $ Command.ReKey.cleanup file newkey $+ logMigration oldkeyrec , giveup "failed creating link from old to new key" )- genkey _ | onlyremovesize = return $ Just (oldkey, False)+ genkey _ | onlytweaksize = return $ Just (oldkey, False) genkey Nothing = do content <- calcRepo $ gitAnnexLocation oldkey let source = KeySource@@ -120,7 +152,56 @@ genkey (Just fm) = fm oldkey newbackend afile >>= \case Just newkey -> return (Just (newkey, True)) Nothing -> genkey Nothing- removesize k- | removeSize o = alterKey k $ \kd -> kd { keySize = Nothing } - | otherwise = k+ tweaksize k+ | removeSize o = pure (removesize k)+ | onlytweaksize = addsize k+ | otherwise = pure k+ removesize k = alterKey k $ \kd -> kd { keySize = Nothing }+ addsize k+ | fromKey keySize k == Nothing = + contentSize k >>= return . \case+ Just sz -> alterKey k $ \kd -> kd { keySize = Just sz }+ Nothing -> k+ | otherwise = return k afile = AssociatedFile (Just file)++update :: Key -> Key -> CommandStart+update oldkey newkey =+ stopUnless (allowed <&&> available <&&> wanted) $ do+ ai <- findworktreefile >>= return . \case+ Just f -> ActionItemAssociatedFile (AssociatedFile (Just f)) newkey+ Nothing -> ActionItemKey newkey+ starting "migrate" ai (SeekInput []) $+ ifM (Command.ReKey.linkKey' v oldkey newkey)+ ( do+ logStatus newkey InfoPresent+ next $ return True+ , next $ return False+ )+ where+ available = (not <$> inAnnex newkey) <&&> inAnnex oldkey++ -- annex.securehashesonly will block adding keys with insecure+ -- hashes, this check is only to avoid doing extra work and+ -- displaying a message when it fails.+ allowed = isNothing <$> checkSecureHashes newkey++ -- If the new key was previous present in this repository, but got+ -- dropped, assume the user still doesn't want it there.+ wanted = loggedPreviousLocations newkey >>= \case+ [] -> pure True+ us -> do+ u <- getUUID+ pure (u `notElem` us)++ findworktreefile = do+ fs <- Database.Keys.getAssociatedFiles newkey+ g <- Annex.gitRepo+ firstM (\f -> (== Just newkey) <$> isAnnexLink f) $+ map (\f -> simplifyPath (fromTopFilePath f g)) fs+ + -- Always verify the content agains the newkey, even if+ -- annex.verify is unset. This is done to prent bad migration+ -- information maliciously injected into the git-annex branch+ -- from populating files with the wrong content.+ v = AlwaysVerify
Command/Mirror.hs view
@@ -52,7 +52,7 @@ ToRemote _ -> commandStages ww = WarnUnmatchLsFiles "mirror" seeker = AnnexedFileSeeker- { startAction = start o+ { startAction = const $ start o , checkContentPresent = Nothing , usesLocationLog = True }
Command/Move.hs view
@@ -75,12 +75,13 @@ batchAnnexed fmt seeker keyaction where seeker = AnnexedFileSeeker- { startAction = start fto (removeWhen o)+ { startAction = const $ start fto (removeWhen o) , checkContentPresent = case fto of FromOrToRemote (FromRemote _) -> Nothing FromOrToRemote (ToRemote _) -> Just True ToHere -> Nothing FromRemoteToRemote _ _ -> Nothing+ FromAnywhereToRemote _ -> Nothing , usesLocationLog = True } keyaction = startKey fto (removeWhen o)@@ -91,6 +92,7 @@ stages (FromOrToRemote (ToRemote _)) = commandStages stages ToHere = transferStages stages (FromRemoteToRemote _ _) = transferStages+stages (FromAnywhereToRemote _) = transferStages start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart start fromto removewhen si f k = start' fromto removewhen afile si k ai@@ -118,6 +120,9 @@ src' <- getParsed src dest' <- getParsed dest fromToStart removewhen afile key ai si src' dest'+ FromAnywhereToRemote dest -> do+ dest' <- getParsed dest+ fromAnywhereToStart removewhen afile key ai si dest' describeMoveAction :: RemoveWhen -> String describeMoveAction RemoveNever = "copy"@@ -146,7 +151,7 @@ expectedPresent :: Remote -> Key -> Annex Bool expectedPresent dest key = do- remotes <- Remote.keyPossibilities key+ remotes <- Remote.keyPossibilities (Remote.IncludeIgnored True) key return $ dest `elem` remotes toPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform@@ -249,7 +254,7 @@ where checklog = do u <- getUUID- remotes <- Remote.keyPossibilities key+ remotes <- Remote.keyPossibilities (Remote.IncludeIgnored True) key return $ u /= Remote.uuid src && elem src remotes fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform@@ -326,7 +331,7 @@ toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart toHereStart removewhen afile key ai si = startingNoMessage (OnlyActionOn key ai) $ do- rs <- Remote.keyPossibilities key+ rs <- Remote.keyPossibilities (Remote.IncludeIgnored False) key forM_ rs $ \r -> includeCommandAction $ starting (describeMoveAction removewhen) ai si $@@ -352,6 +357,30 @@ if fast && removewhen == RemoveNever then not <$> expectedPresent dest key else return True++fromAnywhereToStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart+fromAnywhereToStart removewhen afile key ai si dest =+ stopUnless somethingtodo $ do+ u <- getUUID+ if u == Remote.uuid dest+ then toHereStart removewhen afile key ai si+ else startingNoMessage (OnlyActionOn key ai) $ do+ rs <- filter (/= dest) + <$> Remote.keyPossibilities (Remote.IncludeIgnored False) key+ forM_ rs $ \r ->+ includeCommandAction $+ starting (describeMoveAction removewhen) ai si $+ fromToPerform r dest removewhen key afile+ whenM (inAnnex key) $+ void $ includeCommandAction $+ toStart removewhen afile key ai si dest + next $ return True+ where+ somethingtodo = do+ fast <- Annex.getRead Annex.fast+ if fast && removewhen == RemoveNever+ then not <$> expectedPresent dest key+ else return True {- When there is a local copy, transfer it to the dest, and drop from the src. -
Command/ReKey.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2012-2016 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -19,6 +19,7 @@ import Logs.Location import Annex.InodeSentinal import Annex.WorkTree+import Logs.Migrate import Utility.InodeCache import qualified Utility.RawFilePath as R @@ -88,20 +89,13 @@ giveup $ decodeBS $ quote qp $ QuotedPath file <> " is not available (use --force to override)" )- next $ cleanup file newkey+ next $ cleanup file newkey $ const noop {- Make a hard link to the old key content (when supported), - to avoid wasting disk space. -} linkKey :: RawFilePath -> Key -> Key -> Annex Bool linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)- {- If the object file is already hardlinked to elsewhere, a hard- - link won't be made by getViaTmpFromDisk, but a copy instead.- - This avoids hard linking to content linked to an- - unlocked file, which would leave the new key unlocked- - and vulnerable to corruption. -}- ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey (AssociatedFile Nothing) $ \tmp -> unVerified $ do- oldobj <- calcRepo (gitAnnexLocation oldkey)- isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing+ ( linkKey' DefaultVerify oldkey newkey , do {- The file being rekeyed is itself an unlocked file; if - it's hard linked to the old key, that link must be broken. -}@@ -127,18 +121,34 @@ LinkAnnexNoop -> True ) -cleanup :: RawFilePath -> Key -> CommandCleanup-cleanup file newkey = do- ifM (isJust <$> isAnnexLink file)+ {- If the object file is already hardlinked to elsewhere, a hard+ - link won't be made by getViaTmpFromDisk, but a copy instead.+ - This avoids hard linking to content linked to an+ - unlocked file, which would leave the new key unlocked+ - and vulnerable to corruption. -}+linkKey' :: VerifyConfig -> Key -> Key -> Annex Bool+linkKey' v oldkey newkey =+ getViaTmpFromDisk RetrievalAllKeysSecure v newkey (AssociatedFile Nothing) $ \tmp -> unVerified $ do+ oldobj <- calcRepo (gitAnnexLocation oldkey)+ isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing++cleanup :: RawFilePath -> Key -> (MigrationRecord -> Annex ()) -> CommandCleanup+cleanup file newkey a = do+ newkeyrec <- ifM (isJust <$> isAnnexLink file) ( do -- Update symlink to use the new key.- addSymlink file newkey Nothing+ sha <- genSymlink file newkey Nothing+ stageSymlink file sha+ return (MigrationRecord sha) , do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file liftIO $ whenM (isJust <$> isPointerFile file) $ writePointerFile file newkey mode- stagePointerFile file mode =<< hashPointerFile newkey+ sha <- hashPointerFile newkey+ stagePointerFile file mode sha+ return (MigrationRecord sha) ) whenM (inAnnex newkey) $ logStatus newkey InfoPresent+ a newkeyrec return True
Command/Sync.hs view
@@ -58,6 +58,7 @@ import qualified Command.Move import qualified Command.Export import qualified Command.Import+import qualified Command.Migrate import Annex.Drop import Annex.UUID import Logs.UUID@@ -76,6 +77,7 @@ import Annex.CurrentBranch import Annex.Import import Annex.CheckIgnore+import Annex.PidLock import Types.FileMatcher import Types.GitConfig import Types.Availability@@ -293,6 +295,10 @@ content <- shouldSyncContent o + when content $+ whenM (annexSyncMigrations <$> Annex.getGitConfig) $+ Command.Migrate.seekDistributedMigrations True+ forM_ (filter isImport contentremotes) $ withbranch . importRemote content o forM_ (filter isThirdPartyPopulated contentremotes) $@@ -352,15 +358,16 @@ ] merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> [Git.Branch] -> Annex Bool-merge currbranch mergeconfig o commitmode tomergel = do- canresolvemerge <- if resolveMergeOverride o- then getGitConfigVal annexResolveMerge- else return False- and <$> case currbranch of- (Just b, Just adj) -> forM tomergel $ \tomerge ->- mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode- (b, _) -> forM tomergel $ \tomerge ->- autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge+merge currbranch mergeconfig o commitmode tomergel = + runsGitAnnexChildProcessViaGit $ do+ canresolvemerge <- if resolveMergeOverride o+ then getGitConfigVal annexResolveMerge+ else return False+ and <$> case currbranch of+ (Just b, Just adj) -> forM tomergel $ \tomerge ->+ mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode+ (b, _) -> forM tomergel $ \tomerge ->+ autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge syncBranch :: Git.Branch -> Git.Branch syncBranch = Git.Ref.underBase "refs/heads/synced" . origBranch@@ -840,7 +847,7 @@ where seekworktree mvar l bloomfeeder = do let seeker = AnnexedFileSeeker- { startAction = gofile bloomfeeder mvar+ { startAction = const $ gofile bloomfeeder mvar , checkContentPresent = Nothing , usesLocationLog = True }@@ -897,7 +904,7 @@ syncFile :: SyncOptions -> Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool syncFile o ebloom rs af k = do inhere <- inAnnex k- locs <- map Remote.uuid <$> Remote.keyPossibilities k+ locs <- map Remote.uuid <$> Remote.keyPossibilities (Remote.IncludeIgnored False) k let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs got <- anyM id =<< handleget have inhere@@ -948,7 +955,7 @@ wantput r | pushOption o == False && operationMode o /= SatisfyMode = return False | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False- | isExport r = return False+ | isExport r || isImport r = return False | isThirdPartyPopulated r = return False | otherwise = wantGetBy True (Just k) af (Remote.uuid r) handleput lack inhere
Command/Unannex.hs view
@@ -34,7 +34,7 @@ seeker :: Bool -> AnnexedFileSeeker seeker fast = AnnexedFileSeeker- { startAction = start fast+ { startAction = const $ start fast , checkContentPresent = Just True , usesLocationLog = False }
Command/Unlock.hs view
@@ -35,7 +35,7 @@ where ww = WarnUnmatchLsFiles "unlock" seeker = AnnexedFileSeeker- { startAction = start+ { startAction = const start , checkContentPresent = Nothing , usesLocationLog = False }
Command/WhereUsed.hs view
@@ -49,7 +49,7 @@ (commandAction . start o) dummyfilecommandseek (WorkTreeItems []) where dummyfileseeker = AnnexedFileSeeker- { startAction = \_ _ _ -> return Nothing+ { startAction = \_ _ _ _ -> return Nothing , checkContentPresent = Nothing , usesLocationLog = False }
Command/Whereis.hs view
@@ -51,7 +51,7 @@ seek o = do m <- remoteMap id let seeker = AnnexedFileSeeker- { startAction = start o m+ { startAction = const $ start o m , checkContentPresent = Nothing , usesLocationLog = True }
Database/ContentIdentifier.hs view
@@ -53,9 +53,14 @@ import Database.Persist.Sql hiding (Key) import Database.Persist.TH-import Database.Persist.Sqlite (runSqlite) import qualified System.FilePath.ByteString as P++#if MIN_VERSION_persistent_sqlite(2,13,3)+import Database.RawFilePath+#else+import Database.Persist.Sqlite (runSqlite) import qualified Data.Text as T+#endif data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue Bool @@ -102,8 +107,13 @@ runMigrationSilent migrateContentIdentifier -- Migrate from old versions of database, which had buggy -- and suboptimal uniqueness constraints.+#if MIN_VERSION_persistent_sqlite(2,13,3)+ else liftIO $ runSqlite' db $ void $+ runMigrationSilent migrateContentIdentifier+#else else liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $ runMigrationSilent migrateContentIdentifier+#endif h <- liftIO $ H.openDbQueue db "content_identifiers" return $ ContentIdentifierHandle h isnew
Database/Handle.hs view
@@ -193,10 +193,12 @@ | otherwise -> rethrow $ errmsg "after successful open" ex opensettle retries ic = do- conn <- Sqlite.open tdb+#if MIN_VERSION_persistent_sqlite(2,13,3)+ conn <- Sqlite.open' db+#else+ conn <- Sqlite.open (T.pack (fromRawFilePath db))+#endif settle conn retries ic-- tdb = T.pack (fromRawFilePath db) settle conn retries ic = do r <- try $ do
Database/Init.hs view
@@ -1,11 +1,11 @@ {- Persistent sqlite database initialization -- - Copyright 2015-2020 Joey Hess <id@joeyh.name>+ - Copyright 2015-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-} module Database.Init where @@ -13,6 +13,9 @@ import Annex.Perms import Utility.FileMode import qualified Utility.RawFilePath as R+#if MIN_VERSION_persistent_sqlite(2,13,3)+import Database.RawFilePath+#endif import Database.Persist.Sqlite import Lens.Micro@@ -32,9 +35,13 @@ let dbdir = P.takeDirectory db let tmpdbdir = dbdir <> ".tmp" let tmpdb = tmpdbdir P.</> "db"- let tdb = T.pack (fromRawFilePath tmpdb)+ let tmpdb' = T.pack (fromRawFilePath tmpdb) createAnnexDirectory tmpdbdir- liftIO $ runSqliteInfo (enableWAL tdb) migration+#if MIN_VERSION_persistent_sqlite(2,13,3)+ liftIO $ runSqliteInfo' tmpdb (enableWAL tmpdb') migration+#else+ liftIO $ runSqliteInfo (enableWAL tmpdb') migration+#endif setAnnexDirPerm tmpdbdir -- Work around sqlite bug that prevents it from honoring -- less restrictive umasks.
+ Database/RawFilePath.hs view
@@ -0,0 +1,95 @@+{- Persistent sqlite RawFilePath support+ -+ - The functions below are copied from persistent-sqlite, but modified to+ - take a RawFilePath and ignore the sqlConnectionStr from the+ - SqliteConnectionInfo. This avoids encoding problems using Text+ - in some situations.+ -+ - This module is expected to eventually be supersceded by+ - persistent-sqlite getting support for OsString.+ -+ - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Permission is hereby granted, free of charge, to any person obtaining+ - a copy of this software and associated documentation files (the+ - "Software"), to deal in the Software without restriction, including+ - without limitation the rights to use, copy, modify, merge, publish,+ - distribute, sublicense, and/or sell copies of the Software, and to+ - permit persons to whom the Software is furnished to do so, subject to+ - the following conditions:+ - + - The above copyright notice and this permission notice shall be+ - included in all copies or substantial portions of the Software.+ - + - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+ - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+ - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+ - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+ - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+ - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+ - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+-}++{-# LANGUAGE OverloadedStrings, CPP #-}++module Database.RawFilePath where++#if MIN_VERSION_persistent_sqlite(2,13,3)+import Database.Persist.Sqlite+import qualified Database.Sqlite as Sqlite+import qualified System.FilePath.ByteString as P+import qualified Control.Exception as E+import Control.Monad.Logger (MonadLoggerIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger (NoLoggingT, runNoLoggingT)+import Control.Monad.Trans.Reader (ReaderT)+import UnliftIO.Resource (ResourceT, runResourceT)++openWith'+ :: P.RawFilePath + -> (SqlBackend -> Sqlite.Connection -> r)+ -> SqliteConnectionInfo+ -> LogFunc+ -> IO r+openWith' db f connInfo logFunc = do+ conn <- Sqlite.open' db+ backend <- wrapConnectionInfo connInfo conn logFunc `E.onException` Sqlite.close conn+ return $ f backend conn++runSqlite' :: (MonadUnliftIO m)+ => P.RawFilePath+ -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a+ -> m a+runSqlite' connstr = runResourceT+ . runNoLoggingT+ . withSqliteConn' connstr+ . runSqlConn++withSqliteConn'+ :: (MonadUnliftIO m, MonadLoggerIO m)+ => P.RawFilePath+ -> (SqlBackend -> m a)+ -> m a+withSqliteConn' connstr = withSqliteConnInfo' connstr $+ mkSqliteConnectionInfo mempty++runSqliteInfo'+ :: (MonadUnliftIO m)+ => P.RawFilePath+ -> SqliteConnectionInfo+ -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a+ -> m a+runSqliteInfo' db conInfo = runResourceT+ . runNoLoggingT+ . withSqliteConnInfo' db conInfo+ . runSqlConn++withSqliteConnInfo'+ :: (MonadUnliftIO m, MonadLoggerIO m)+ => P.RawFilePath+ -> SqliteConnectionInfo+ -> (SqlBackend -> m a)+ -> m a+withSqliteConnInfo' db = withSqlConn . openWith' db const+#endif
Git/Log.hs view
@@ -10,12 +10,13 @@ import Common import Git import Git.Command+import Git.Sha import Data.Time import Data.Time.Clock.POSIX -- A change made to a file.-data RefChange t = RefChange+data LoggedFileChange t = LoggedFileChange { changetime :: POSIXTime , changed :: t , changedfile :: FilePath@@ -24,18 +25,21 @@ } deriving (Show) --- Get the git log. Note that the returned cleanup action should only be+-- Get the git log of changes to files. +-- +-- Note that the returned cleanup action should only be -- run after processing the returned list. getGitLog :: Ref+ -> Maybe Ref -> [FilePath] -> [CommandParam]- -> (FilePath -> Maybe t)+ -> (Sha -> FilePath -> Maybe t) -> Repo- -> IO ([RefChange t], IO Bool)-getGitLog ref fs os fileselector repo = do+ -> IO ([LoggedFileChange t], IO Bool)+getGitLog ref stopref fs os selector repo = do (ls, cleanup) <- pipeNullSplit ps repo- return (parseGitRawLog fileselector (map decodeBL ls), cleanup)+ return (parseGitRawLog selector (map decodeBL ls), cleanup) where ps = [ Param "log"@@ -45,14 +49,16 @@ , Param "--no-abbrev" , Param "--no-renames" ] ++ os ++- [ Param (fromRef ref)+ [ case stopref of+ Just stopref' -> Param $+ fromRef stopref' <> ".." <> fromRef ref+ Nothing -> Param (fromRef ref) , Param "--" ] ++ map Param fs --- The commitinfo is the timestamp of the commit, followed by--- the commit hash and then the commit's parents, separated by spaces.+-- The commitinfo is the commit hash followed by its timestamp. commitinfoFormat :: String-commitinfoFormat = "%ct"+commitinfoFormat = "%H %ct" -- Parses chunked git log --raw output generated by getGitLog, -- which looks something like:@@ -69,22 +75,24 @@ -- -- The commitinfo is not included before all changelines, so -- keep track of the most recently seen commitinfo.-parseGitRawLog :: (FilePath -> Maybe t) -> [String] -> [RefChange t]-parseGitRawLog fileselector = parse epoch+parseGitRawLog :: (Ref -> FilePath -> Maybe t) -> [String] -> [LoggedFileChange t]+parseGitRawLog selector = parse (deleteSha, epoch) where epoch = toEnum 0 :: POSIXTime- parse oldts ([]:rest) = parse oldts rest- parse oldts (c1:c2:rest) = case mrc of- Just rc -> rc : parse ts rest- Nothing -> parse ts (c2:rest)+ parse old ([]:rest) = parse old rest+ parse (oldcommitsha, oldts) (c1:c2:rest) = case mrc of+ Just rc -> rc : parse (commitsha, ts) rest+ Nothing -> parse (commitsha, ts) (c2:rest) where- (ts, cl) = case separate (== '\n') c1 of- (cl', []) -> (oldts, cl')- (tss, cl') -> (parseTimeStamp tss, cl')+ (commitsha, ts, cl) = case separate (== '\n') c1 of+ (cl', []) -> (oldcommitsha, oldts, cl')+ (ci, cl') -> case words ci of+ (css:tss:[]) -> (Ref (encodeBS css), parseTimeStamp tss, cl')+ _ -> (oldcommitsha, oldts, cl') mrc = do (old, new) <- parseRawChangeLine cl- v <- fileselector c2- return $ RefChange+ v <- selector commitsha c2+ return $ LoggedFileChange { changetime = ts , changed = v , changedfile = c2
Git/Tree.hs view
@@ -23,6 +23,8 @@ graftTree', withMkTreeHandle, MkTreeHandle,+ sendMkTree,+ finishMkTree, treeMode, ) where @@ -101,18 +103,27 @@ sha <- mkTree h =<< mapM (recordSubTree h) l return (RecordedSubTree d sha []) recordSubTree _ alreadyrecorded = return alreadyrecorded- ++sendMkTree :: MkTreeHandle -> FileMode -> ObjectType -> Sha -> TopFilePath -> IO ()+sendMkTree (MkTreeHandle cp) fm ot s f =+ CoProcess.send cp $ \h -> + hPutStr h (mkTreeOutput fm ot s f)++finishMkTree :: MkTreeHandle -> IO Sha+finishMkTree (MkTreeHandle cp) = do+ CoProcess.send cp $ \h ->+ -- NUL to signal end of tree to --batch+ hPutStr h "\NUL"+ getSha "mktree" (CoProcess.receive cp S8.hGetLine)+ mkTree :: MkTreeHandle -> [TreeContent] -> IO Sha-mkTree (MkTreeHandle cp) l = CoProcess.query cp send receive- where- send h = do- forM_ l $ \i -> hPutStr h $ case i of- TreeBlob f fm s -> mkTreeOutput fm BlobObject s f- RecordedSubTree f s _ -> mkTreeOutput treeMode TreeObject s f- NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree"- TreeCommit f fm s -> mkTreeOutput fm CommitObject s f- hPutStr h "\NUL" -- signal end of tree to --batch- receive h = getSha "mktree" (S8.hGetLine h)+mkTree h l = do+ forM_ l $ \case+ TreeBlob f fm s -> sendMkTree h fm BlobObject s f+ RecordedSubTree f s _ -> sendMkTree h treeMode TreeObject s f+ NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree"+ TreeCommit f fm s -> sendMkTree h fm CommitObject s f+ finishMkTree h treeMode :: FileMode treeMode = 0o040000
Logs.hs view
@@ -1,6 +1,6 @@ {- git-annex log file names -- - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ - Copyright 2013-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -155,6 +155,11 @@ - the git-annex branch. -} exportTreeGraftPoint :: RawFilePath exportTreeGraftPoint = "export.tree"++{- This is not a log file, it's where migration treeishes get grafted into+ - the git-annex branch. -}+migrationTreeGraftPoint :: RawFilePath+migrationTreeGraftPoint = "migrate.tree" {- The pathname of the location log file for a given key. -} locationLogFile :: GitConfig -> Key -> RawFilePath
Logs/Export.hs view
@@ -78,7 +78,7 @@ -- repository, the tree has to be kept available, even if it -- doesn't end up being merged into the master branch. recordExportTreeish :: Git.Ref -> Annex ()-recordExportTreeish t = +recordExportTreeish t = void $ Annex.Branch.rememberTreeish t (asTopFilePath exportTreeGraftPoint) -- | Record that an export to a special remote is under way.
Logs/Location.hs view
@@ -21,6 +21,7 @@ logStatusAfter, logChange, loggedLocations,+ loggedPreviousLocations, loggedLocationsHistorical, loggedLocationsRef, parseLoggedLocations,@@ -79,7 +80,13 @@ {- Returns a list of repository UUIDs that, according to the log, have - the value of a key. -} loggedLocations :: Key -> Annex [UUID]-loggedLocations = getLoggedLocations currentLogInfo+loggedLocations = getLoggedLocations presentLogInfo++{- Returns a list of repository UUIDs that the location log indicates+ - used to have the vale of a key, but no longer do.+ -}+loggedPreviousLocations :: Key -> Annex [UUID]+loggedPreviousLocations = getLoggedLocations notPresentLogInfo {- Gets the location log on a particular date. -} loggedLocationsHistorical :: RefDate -> Key -> Annex [UUID]
+ Logs/Migrate.hs view
@@ -0,0 +1,203 @@+{- git-annex migration logs+ -+ - To record a migration in the git-annex branch as space efficiently as+ - possible, it is stored as a tree which contains two subtrees 'old' and 'new'.+ - The subtrees each contain the same filenames, which point to the old+ - and new keys respectively.+ -+ - When the user commits the migrated files to their HEAD branch, that will+ - store pointers to the new keys in git. And pointers to the old keys+ - already exist in git. So recording the migration this way avoids+ - injecting any new objects into git, besides the two trees. Note that for+ - this to be the case, care has to be taken to record the migration + - using the same symlink targets or pointer file contents as are used in+ - the HEAD branch.+ -+ - The filenames used in the trees are not the original filenames, to avoid+ - running migrate in a throwaway branch unexpectedly recording that+ - branch's contents.+ -+ - There are two local log files:+ - * migrate.log contains pairs of old and new keys, and is used while+ - performing a new migration, to build up a migration to commit.+ - This allows an interrupted migration to be resumed later.+ - * migrations.log has as its first line a commit to the git-annex branch+ - up to which all migrations have been performed locally (including any+ - migrations in parent commits). Or the first line may be a null sha when+ - this has not been done yet. The rest of the lines in the file+ - are commits that have been made for locally performed migrations,+ - but whose parent commits have not necessarily been checked for+ - migrations yet.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings, BangPatterns #-}++module Logs.Migrate (+ MigrationRecord(..),+ logMigration,+ commitMigration,+ streamNewDistributedMigrations,+) where++import Annex.Common+import qualified Git+import qualified Annex+import qualified Annex.Branch+import Git.Types+import Git.Tree+import Git.FilePath+import Git.Ref+import Git.Sha+import Git.Log+import Logs.File+import Logs+import Annex.CatFile++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Control.Concurrent.STM+import System.FilePath.ByteString as P++-- | What to use to record a migration. This should be the same Sha that is+-- used to as the content of the annexed file in the HEAD branch.+newtype MigrationRecord = MigrationRecord { fromMigrationRecord :: Git.Sha }++-- | Logs a migration from an old to a new key.+logMigration :: MigrationRecord -> MigrationRecord -> Annex ()+logMigration old new = do+ logf <- fromRepo gitAnnexMigrateLog+ lckf <- fromRepo gitAnnexMigrateLock+ appendLogFile logf lckf $ L.fromStrict $+ Git.fromRef' (fromMigrationRecord old)+ <> " "+ <> Git.fromRef' (fromMigrationRecord new)++-- | Commits a migration to the git-annex branch.+commitMigration :: Annex ()+commitMigration = do+ logf <- fromRawFilePath <$> fromRepo gitAnnexMigrateLog+ lckf <- fromRepo gitAnnexMigrateLock+ nv <- liftIO $ newTVarIO (0 :: Integer)+ g <- Annex.gitRepo+ withMkTreeHandle g $ \oldh ->+ withMkTreeHandle g $ \newh ->+ streamLogFile logf lckf + (finalizer nv oldh newh g)+ (processor nv oldh newh)+ where+ processor nv oldh newh s = case words s of+ (old:new:[]) -> do+ fn <- liftIO $ atomically $ do+ n <- readTVar nv+ let !n' = succ n+ writeTVar nv n'+ return (asTopFilePath (encodeBS (show n')))+ let rec h r = liftIO $ sendMkTree h+ (fromTreeItemType TreeFile)+ BlobObject+ (Git.Ref (encodeBS r))+ fn+ rec oldh old+ rec newh new+ _ -> error "migrate.log parse error"+ finalizer nv oldh newh g = do+ oldt <- liftIO $ finishMkTree oldh+ newt <- liftIO $ finishMkTree newh+ n <- liftIO $ atomically $ readTVar nv+ when (n > 0) $ do+ treesha <- liftIO $ flip recordTree g $ Tree+ [ RecordedSubTree (asTopFilePath "old") oldt []+ , RecordedSubTree (asTopFilePath "new") newt []+ ]+ commitsha <- Annex.Branch.rememberTreeish treesha+ (asTopFilePath migrationTreeGraftPoint)+ committedMigration commitsha++-- Streams distributed migrations from the git-annex branch,+-- and runs the provided action on each old and new key pair.+--+-- With the incremental option, only scans as far as the last recorded+-- migration that this has handled before.+streamNewDistributedMigrations :: Bool -> (Key -> Key -> Annex ()) -> Annex ()+streamNewDistributedMigrations incremental a = do+ void Annex.Branch.update+ branchsha <- Annex.Branch.getBranch+ (stoppoint, toskip) <- getPerformedMigrations+ (l, cleanup) <- inRepo $ getGitLog branchsha+ (if incremental then stoppoint else Nothing)+ [fromRawFilePath migrationTreeGraftPoint]+ -- Need to follow because migrate.tree is grafted in + -- and then deleted, and normally git log stops when a file+ -- gets deleted.+ ([Param "--reverse", Param "--follow"])+ (\commit _file -> Just commit)+ forM_ l (go toskip)+ liftIO $ void cleanup+ recordPerformedMigrations branchsha toskip+ where+ go toskip c+ | newref c `elem` nullShas = return ()+ | changed c `elem` toskip = return ()+ | not ("/new/" `B.isInfixOf` newfile) = return ()+ | otherwise = + catKey (newref c) >>= \case+ Nothing -> return ()+ Just newkey -> catKey oldfileref >>= \case+ Nothing -> return ()+ Just oldkey -> a oldkey newkey+ where+ newfile = toRawFilePath (changedfile c)+ oldfile = migrationTreeGraftPoint + P.</> "old" + P.</> P.takeBaseName (fromInternalGitPath newfile)+ oldfileref = branchFileRef (changed c) oldfile++getPerformedMigrations :: Annex (Maybe Sha, [Sha])+getPerformedMigrations = do+ logf <- fromRepo gitAnnexMigrationsLog+ lckf <- fromRepo gitAnnexMigrationsLock+ ls <- calcLogFile logf lckf [] (:)+ return $ case reverse ls of+ [] -> (Nothing, [])+ (stoppoint:toskip) ->+ let stoppoint' = conv stoppoint+ in + ( if stoppoint' `elem` nullShas+ then Nothing+ else Just stoppoint'+ , map conv toskip+ )+ where+ conv = Git.Ref . L.toStrict++-- Record locally that migrations have been performed up to the given+-- commit. The list is additional commits that can be removed from the+-- log file if present.+recordPerformedMigrations :: Sha -> [Sha] -> Annex ()+recordPerformedMigrations commit toremove = do+ logf <- fromRepo gitAnnexMigrationsLog+ lckf <- fromRepo gitAnnexMigrationsLock+ modifyLogFile logf lckf (update . drop 1)+ where+ update l = L.fromStrict (fromRef' commit) : filter (`notElem` toremove') l+ toremove' = map (L.fromStrict . fromRef') toremove++-- Record that a migration was performed locally and committed.+-- Since committing a migration may result in parent migrations that have+-- not yet been processed locally, that commit cannot be the first line of+-- the log file, which is reserved for commits whose parents have also had+-- their migrations handled. So if the log file does not exist or is empty,+-- make the first line a null sha.+committedMigration :: Sha -> Annex ()+committedMigration commitsha = do+ logf <- fromRepo gitAnnexMigrationsLog+ lckf <- fromRepo gitAnnexMigrationsLock+ modifyLogFile logf lckf update+ where+ update [] = [conv deleteSha, conv commitsha]+ update logged = logged ++ [conv commitsha]+ conv = L.fromStrict . fromRef'
Logs/PreferredContent.hs view
@@ -82,7 +82,7 @@ preferredRequiredMapsLoad :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (FileMatcherMap Annex, FileMatcherMap Annex) preferredRequiredMapsLoad mktokens = do- (pc, rc) <- preferredRequiredMapsLoad' mktokens+ (pc, rc) <- preferredRequiredMapsLoad' id mktokens let pc' = handleunknown (MatcherDesc "preferred content") pc let rc' = handleunknown (MatcherDesc "required content") rc Annex.changeState $ \s -> s@@ -94,12 +94,12 @@ handleunknown matcherdesc = M.mapWithKey $ \u v -> (either (const $ unknownMatcher u) id v, matcherdesc) -preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (Matcher (MatchFiles Annex))), M.Map UUID (Either String (Matcher (MatchFiles Annex))))-preferredRequiredMapsLoad' mktokens = do+preferredRequiredMapsLoad' :: (Matcher (MatchFiles Annex) -> Matcher (MatchFiles Annex)) -> (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (Matcher (MatchFiles Annex))), M.Map UUID (Either String (Matcher (MatchFiles Annex))))+preferredRequiredMapsLoad' matcherf mktokens = do groupmap <- groupMap configmap <- remoteConfigMap let genmap l gm = - let mk u = makeMatcher groupmap configmap gm u mktokens+ let mk u = makeMatcher groupmap configmap gm u matcherf mktokens in simpleMap . parseLogOldWithUUID (\u -> mk u . decodeBS <$> A.takeByteString) <$> Annex.Branch.get l@@ -123,13 +123,14 @@ -> M.Map UUID RemoteConfig -> M.Map Group PreferredContentExpression -> UUID+ -> (Matcher (MatchFiles Annex) -> Matcher (MatchFiles Annex)) -> (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> PreferredContentExpression -> Either String (Matcher (MatchFiles Annex))-makeMatcher groupmap configmap groupwantedmap u mktokens = go True True+makeMatcher groupmap configmap groupwantedmap u matcherf mktokens = go True True where go expandstandard expandgroupwanted expr- | null (lefts tokens) = Right $ generate $ rights tokens+ | null (lefts tokens) = Right $ matcherf $ generate $ rights tokens | otherwise = Left $ unwords $ lefts tokens where tokens = preferredContentParser (mktokens pcd) expr
Logs/Presence.hs view
@@ -17,8 +17,8 @@ addLog', maybeAddLog, readLog,- currentLog,- currentLogInfo,+ presentLogInfo,+ notPresentLogInfo, historicalLogInfo, ) where @@ -68,12 +68,13 @@ readLog :: RawFilePath -> Annex [LogLine] readLog = parseLog <$$> Annex.Branch.get -{- Reads a log and returns only the info that is still in effect. -}-currentLogInfo :: RawFilePath -> Annex [LogInfo]-currentLogInfo file = map info <$> currentLog file+{- Reads a log and returns only the info that is still present. -}+presentLogInfo :: RawFilePath -> Annex [LogInfo]+presentLogInfo file = map info . filterPresent <$> readLog file -currentLog :: RawFilePath -> Annex [LogLine]-currentLog file = filterPresent <$> readLog file+{- Reads a log and returns only the info that is no longer present. -}+notPresentLogInfo :: RawFilePath -> Annex [LogInfo]+notPresentLogInfo file = map info . filterNotPresent <$> readLog file {- Reads a historical version of a log and returns the info that was in - effect at that time.
Logs/Presence/Pure.hs view
@@ -70,13 +70,17 @@ genstatus InfoMissing = charUtf8 '0' genstatus InfoDead = charUtf8 'X' -{- Given a log, returns only the info that is are still in effect. -}+{- Given a log, returns only the info that is still present. -} getLog :: L.ByteString -> [LogInfo] getLog = map info . filterPresent . parseLog -{- Returns the info from LogLines that are in effect. -}+{- Returns the info from LogLines that is present. -} filterPresent :: [LogLine] -> [LogLine] filterPresent = filter (\l -> InfoPresent == status l) . compactLog++{- Returns the info from LogLines that is not present. -}+filterNotPresent :: [LogLine] -> [LogLine]+filterNotPresent = filter (\l -> InfoPresent /= status l) . compactLog {- Compacts a set of logs, returning a subset that contains the current - status. -}
Logs/Web.hs view
@@ -55,7 +55,7 @@ where go [] = return [] go (l:ls) = do- us <- currentLogInfo l+ us <- presentLogInfo l if null us then go ls else return $ map fromLogInfo us
Remote.hs view
@@ -47,6 +47,7 @@ remotesWithUUID, remotesWithoutUUID, keyLocations,+ IncludeIgnored(..), keyPossibilities, remoteLocations, nameToUUID,@@ -299,13 +300,16 @@ keyLocations :: Key -> Annex [UUID] keyLocations key = trustExclude DeadTrusted =<< loggedLocations key +{- Whether to include remotes that have annex-ignore set. -}+newtype IncludeIgnored = IncludeIgnored Bool+ {- Cost ordered lists of remotes that the location log indicates - may have a key. - - Also includes remotes with remoteAnnexSpeculatePresent set. -}-keyPossibilities :: Key -> Annex [Remote]-keyPossibilities key = do+keyPossibilities :: IncludeIgnored -> Key -> Annex [Remote]+keyPossibilities ii key = do u <- getUUID -- uuids of all remotes that are recorded to have the key locations <- filter (/= u) <$> keyLocations key@@ -315,19 +319,21 @@ -- there are unlikely to be many speclocations, so building a Set -- is not worth the expense let locations' = speclocations ++ filter (`notElem` speclocations) locations- fst <$> remoteLocations locations' []+ fst <$> remoteLocations ii locations' [] {- Given a list of locations of a key, and a list of all - trusted repositories, generates a cost-ordered list of - remotes that contain the key, and a list of trusted locations of the key. -}-remoteLocations :: [UUID] -> [UUID] -> Annex ([Remote], [UUID])-remoteLocations locations trusted = do+remoteLocations :: IncludeIgnored -> [UUID] -> [UUID] -> Annex ([Remote], [UUID])+remoteLocations (IncludeIgnored ii) locations trusted = do let validtrustedlocations = nub locations `intersect` trusted -- remotes that match uuids that have the key allremotes <- remoteList - >>= filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig)+ >>= if not ii+ then filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig)+ else return let validremotes = remotesWithUUID allremotes locations return (sortBy (comparing cost) validremotes, validtrustedlocations)
Types/GitConfig.hs view
@@ -94,6 +94,7 @@ , annexResolveMerge :: GlobalConfigurable Bool , annexSyncContent :: GlobalConfigurable (Maybe Bool) , annexSyncOnlyAnnex :: GlobalConfigurable Bool+ , annexSyncMigrations :: Bool , annexDebug :: Bool , annexDebugFilter :: Maybe String , annexWebOptions :: [String]@@ -184,6 +185,7 @@ getmaybebool (annexConfig "synccontent") , annexSyncOnlyAnnex = configurable False $ getmaybebool (annexConfig "synconlyannex")+ , annexSyncMigrations = getbool (annexConfig "syncmigrations") True , annexDebug = getbool (annexConfig "debug") False , annexDebugFilter = getmaybe (annexConfig "debugfilter") , annexWebOptions = getwords (annexConfig "web-options")
Utility/CoProcess.hs view
@@ -1,7 +1,7 @@ {- Interface for running a shell command as a coprocess, - sending it queries and getting back results. -- - Copyright 2012-2013 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -14,11 +14,14 @@ start, stop, query,+ send,+ receive, ) where import Common import Control.Concurrent.MVar+import Control.Monad.IO.Class (MonadIO) type CoProcessHandle = MVar CoProcessState @@ -65,12 +68,12 @@ {- To handle a restartable process, any IO exception thrown by the send and - receive actions are assumed to mean communication with the process - failed, and the failed action is re-run with a new process. -}-query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b-query ch send receive = do- s <- readMVar ch- restartable s (send $ coProcessTo s) $ const $- restartable s (hFlush $ coProcessTo s) $ const $- restartable s (receive $ coProcessFrom s)+query :: (MonadIO m, MonadCatch m) => CoProcessHandle -> (Handle -> m a) -> (Handle -> m b) -> m b+query ch sender receiver = do+ s <- liftIO $ readMVar ch+ restartable s (sender $ coProcessTo s) $ const $+ restartable s (liftIO $ hFlush $ coProcessTo s) $ const $+ restartable s (receiver $ coProcessFrom s) return where restartable s a cont@@ -78,12 +81,23 @@ maybe restart cont =<< catchMaybeIO a | otherwise = cont =<< a restart = do- s <- takeMVar ch- void $ catchMaybeIO $ do+ s <- liftIO $ takeMVar ch+ void $ liftIO $ catchMaybeIO $ do hClose $ coProcessTo s hClose $ coProcessFrom s- void $ waitForProcess $ coProcessPid s- s' <- start' $ (coProcessSpec s)+ void $ liftIO $ waitForProcess $ coProcessPid s+ s' <- liftIO $ start' $ (coProcessSpec s) { coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }- putMVar ch s'- query ch send receive+ liftIO $ putMVar ch s'+ query ch sender receiver++send :: MonadIO m => CoProcessHandle -> (Handle -> m a) -> m a+send ch a = do+ s <- liftIO $ readMVar ch+ a (coProcessTo s)++receive :: MonadIO m => CoProcessHandle -> (Handle -> m a) -> m a+receive ch a = do+ s <- liftIO $ readMVar ch+ liftIO $ hFlush $ coProcessTo s+ a (coProcessFrom s)
Utility/Matcher.hs view
@@ -24,6 +24,7 @@ MatchResult(..), syntaxToken, generate,+ pruneMatcher, match, match', matchM,@@ -98,6 +99,26 @@ simplify (MOr x y) = MOr (simplify x) (simplify y) simplify (MNot x) = MNot (simplify x) simplify x = x++{- Prunes selected ops from the Matcher. -}+pruneMatcher :: (op -> Bool) -> Matcher op -> Matcher op+pruneMatcher f = fst . go+ where+ go MAny = (MAny, False)+ go (MAnd a b) = go2 a b MAnd+ go (MOr a b) = go2 a b MOr+ go (MNot a) = case go a of+ (_, True) -> (MAny, True)+ (a', False) -> (MNot a', False)+ go (MOp op)+ | f op = (MAny, True)+ | otherwise = (MOp op, False)++ go2 a b g = case (go a, go b) of+ ((_, True), (_, True)) -> (MAny, True)+ ((a', False), (b', False)) -> (g a' b', False)+ ((_, True), (b', False)) -> (b', False)+ ((a', False), (_, True)) -> (a', False) data TokenGroup op = One (Token op) | Group [TokenGroup op] deriving (Show, Eq)
Utility/TimeStamp.hs view
@@ -1,14 +1,17 @@ {- timestamp parsing and formatting -- - Copyright 2015-2019 Joey Hess <id@joeyh.name>+ - Copyright 2015-2023 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# LANGUAGE CPP #-}+ module Utility.TimeStamp ( parserPOSIXTime, parsePOSIXTime, formatPOSIXTime,+ truncateResolution, ) where import Utility.Data@@ -56,3 +59,14 @@ formatPOSIXTime :: String -> POSIXTime -> String formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)++{- Truncate the resolution to the specified number of decimal places. -}+truncateResolution :: Int -> POSIXTime -> POSIXTime+#if MIN_VERSION_time(1,9,1)+truncateResolution n t = secondsToNominalDiffTime $+ fromIntegral ((truncate (nominalDiffTimeToSeconds t * d)) :: Integer) / d+ where+ d = 10 ^ n+#else+truncateResolution _ t = t+#endif
Utility/Tmp.hs view
@@ -105,7 +105,12 @@ -} relatedTemplate :: FilePath -> FilePath relatedTemplate f- | len > 20 = truncateFilePath (len - 20) f+ | len > 20 = + {- Some filesystems like FAT have issues with filenames+ - ending in ".", so avoid truncating a filename to end+ - that way. -}+ reverse $ dropWhile (== '.') $ reverse $+ truncateFilePath (len - 20) f | otherwise = f where len = length f
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20231129+Version: 10.20231227 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -746,6 +746,7 @@ Database.Keys.Tables Database.Keys.SQL Database.Queue+ Database.RawFilePath Database.Types Database.Utility Git@@ -821,6 +822,7 @@ Logs.MapLog Logs.MetaData Logs.MetaData.Pure+ Logs.Migrate Logs.Multicast Logs.NumCopies Logs.PreferredContent
stack.yaml view
@@ -12,7 +12,7 @@ crypton: false packages: - '.'-resolver: nightly-2023-08-01+resolver: lts-22.3 extra-deps: - git-lfs-1.2.1 - http-client-restricted-0.1.0