packages feed

git-annex 10.20221212 → 10.20230126

raw patch · 54 files changed

+791/−225 lines, 54 files

Files

Annex/Content.hs view
@@ -139,7 +139,8 @@  -  - If locking fails, throws an exception rather than running the action.  -- - If locking fails because the the content is not present, runs the+ - When the content file itself is used as the lock file, + - and locking fails because the the content is not present, runs the  - fallback action instead. However, the content is not guaranteed to be  - present when this succeeds.  -}
Annex/MetaData.hs view
@@ -26,6 +26,7 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX+import Text.Read  {- Adds metadata for a file that has just been ingested into the  - annex, but has not yet been committed to git.@@ -104,15 +105,17 @@ 	(f, op_v) = break (`elem` "=<>") p 	matcher = case op_v of 		('=':v) -> checkglob v-		('<':'=':v) -> checkcmp (<=) v-		('<':v) -> checkcmp (<) v-		('>':'=':v) -> checkcmp (>=) v-		('>':v) -> checkcmp (>) v+		('<':'=':v) -> checkcmp (<=) (<=) v+		('<':v) -> checkcmp (<) (<) v+		('>':'=':v) -> checkcmp (>=) (>=) v+		('>':v) -> checkcmp (>) (>) v 		_ -> checkglob "" 	checkglob v = 		let cglob = compileGlob v CaseInsensative (GlobFilePath False) 		in matchGlob cglob . decodeBS . fromMetaValue-	checkcmp cmp v v' = case (doubleval v, doubleval (decodeBS (fromMetaValue v'))) of-		(Just d, Just d') -> d' `cmp` d-		_ -> False-	doubleval v = readish v :: Maybe Double+	checkcmp cmp cmp' v mv' = +		let v' = decodeBS (fromMetaValue mv')+		in case (doubleval v, doubleval v') of+			(Just d, Just d') -> d' `cmp` d+			_ -> v' `cmp'` v+	doubleval v = readMaybe v :: Maybe Double
Annex/SpecialRemote/Config.hs view
@@ -1,6 +1,6 @@ {- git-annex special remote configuration  -- - Copyright 2019-2020 Joey Hess <id@joeyh.name>+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,9 +17,11 @@ import Types.ProposedAccepted import Types.RemoteConfig import Types.GitConfig+import Config.Cost  import qualified Data.Map as M import qualified Data.Set as S+import Text.Read import Data.Typeable import GHC.Stack @@ -56,6 +58,9 @@ autoEnableField :: RemoteConfigField autoEnableField = Accepted "autoenable" +costField :: RemoteConfigField+costField = Accepted "cost"+ encryptionField :: RemoteConfigField encryptionField = Accepted "encryption" @@ -106,6 +111,8 @@ 		(FieldDesc "type of special remote") 	, trueFalseParser autoEnableField (Just False) 		(FieldDesc "automatically enable special remote")+	, costParser costField+		(FieldDesc "default cost of this special remote") 	, yesNoParser exportTreeField (Just False) 		(FieldDesc "export trees of files to this remote") 	, yesNoParser importTreeField (Just False)@@ -251,6 +258,13 @@ trueFalseParser' "true" = Just True trueFalseParser' "false" = Just False trueFalseParser' _ = Nothing++costParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser+costParser f fd = genParser readcost f Nothing fd+	(Just (ValueDesc "a number"))+  where+	readcost :: String -> Maybe Cost+	readcost = readMaybe  genParser 	:: Typeable t
Annex/Transfer.hs view
@@ -29,7 +29,6 @@ import Annex.Content import Annex.Perms import Annex.Action-import Logs.Location import Utility.Metered import Utility.ThreadScheduler import Annex.LockPool@@ -73,7 +72,7 @@  -- Download, supporting canceling detected stalls. download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool-download r key f d witness = logStatusAfter key $+download r key f d witness =  	case remoteAnnexStallDetection (Remote.gitconfig r) of 		Nothing -> go (Just ProbeStallDetection) 		Just StallDetectionDisabled -> go Nothing@@ -121,7 +120,7 @@  runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v runTransfer' ignorelock t afile stalldetection retrydecider transferaction =-	enteringStage TransferStage $+	enteringStage (TransferStage (transferDirection t)) $ 		debugLocks $ 			preCheckSecureHashes (transferKey t) go   where@@ -245,7 +244,7 @@ 	-> NotifyWitness 	-> Annex Bool runTransferrer sd r k afile retrydecider direction _witness =-	enteringStage TransferStage $ preCheckSecureHashes k $ do+	enteringStage (TransferStage direction) $ preCheckSecureHashes k $ do 		info <- liftIO $ startTransferInfo afile 		go 0 info   where
Annex/YoutubeDl.hs view
@@ -144,7 +144,7 @@ 	res <- withTmpWorkDir key $ \workdir -> 		youtubeDl url (fromRawFilePath workdir) p >>= \case 			Right (Just mediafile) -> do-				liftIO $ renameFile mediafile dest+				liftIO $ moveFile (toRawFilePath mediafile) (toRawFilePath dest) 				return (Just True) 			Right Nothing -> return (Just False) 			Left msg -> do
CHANGELOG view
@@ -1,3 +1,34 @@+git-annex (10.20230126) upstream; urgency=medium++  * Change --metadata comparisons < > <= and >= to fall back to+    lexicographical comparisons when one or both values being compared+    are not numbers.+  * Improve handling of some .git/annex/ subdirectories being on other+    filesystems, in the bittorrent special remote, and youtube-dl+    integration, and git-annex addurl.+  * Added --anything (and --nothing). Eg, git-annex find --anything+    will list all annexed files whether or not the content is present.+    This is slightly faster and clearer than --include=* or --exclude=*+  * Speed up git-annex upgrade (from v5) and init in a repository that has+    submodules.+  * Added libgcc_s.so.1 to the linux standalone build so pthread_cancel+    will work.+  * Speed up initial scanning for annexed files when built+    with persistent-2.14.4.1+  * Allow initremote of additional special remotes with type=web,+    in addition to the default web special remote. When --sameas=web is used,+    these provide additional names for the web special remote, and may+    also have their own additional configuration and cost.+  * web: Add urlinclude and urlexclude configuration settings.+  * Added an optional cost= configuration to all special remotes.+  * adb: Support the remote.name.cost and remote.name.cost-command configs.+  * findkeys: New command, very similar to git-annex find but operating on+    keys.+  * move, copy: Support combining --from and --to, which will send content+    from one remote across to another remote.++ -- Joey Hess <id@joeyh.name>  Thu, 26 Jan 2023 15:26:22 -0400+ git-annex (10.20221212) upstream; urgency=medium    * Fix a hang that occasionally occurred during commands such as move,
@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2022 Joey Hess <id@joeyh.name>+Copyright: © 2010-2023 Joey Hess <id@joeyh.name> License: AGPL-3+  Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*
CmdLine/GitAnnex.hs view
@@ -70,6 +70,7 @@ import qualified Command.PostReceive import qualified Command.FilterBranch import qualified Command.Find+import qualified Command.FindKeys import qualified Command.FindRef import qualified Command.Whereis import qualified Command.WhereUsed@@ -208,6 +209,7 @@ 	, Command.AddUnused.cmd 	, Command.FilterBranch.cmd 	, Command.Find.cmd+	, Command.FindKeys.cmd 	, Command.FindRef.cmd 	, Command.Whereis.cmd 	, Command.WhereUsed.cmd
CmdLine/GitAnnex/Options.hs view
@@ -1,6 +1,6 @@ {- git-annex command-line option parsing  -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -134,7 +134,7 @@ 	<> help "don't make changes, but show what would be done" 	) --- | From or To a remote.+-- | From or To a remote but not both. data FromToOptions 	= FromRemote (DeferredParse Remote) 	| ToRemote (DeferredParse Remote)@@ -162,23 +162,34 @@ 	<> completeRemotes 	) --- | Like FromToOptions, but with a special --to=here-type FromToHereOptions = Either ToHere FromToOptions--data ToHere = ToHere+-- | From or to a remote, or both, or a special --to=here+data FromToHereOptions +	= FromOrToRemote FromToOptions+	| ToHere+	| FromRemoteToRemote (DeferredParse Remote) (DeferredParse Remote) -parseFromToHereOptions :: Parser FromToHereOptions-parseFromToHereOptions = parsefrom <|> parseto+parseFromToHereOptions :: Parser (Maybe FromToHereOptions)+parseFromToHereOptions = go+	<$> optional parseFromOption+	<*> optional parseToOption   where-	parsefrom = Right . FromRemote . parseRemoteOption <$> parseFromOption-	parseto = herespecialcase <$> parseToOption-	  where-		herespecialcase "here" = Left ToHere-		herespecialcase "." = Left ToHere-		herespecialcase n = Right $ ToRemote $ parseRemoteOption n+	go (Just from) (Just to) = Just $ FromRemoteToRemote+		(parseRemoteOption from)+		(parseRemoteOption to)+	go (Just from) Nothing = Just $ FromOrToRemote+		(FromRemote $ parseRemoteOption from)+	go Nothing (Just to) = Just $ case to of+		"here" -> ToHere+		"." -> ToHere+		_ -> FromOrToRemote $ ToRemote $ parseRemoteOption to+	go Nothing Nothing = Nothing  instance DeferredParseClass FromToHereOptions where-	finishParse = either (pure . Left) (Right <$$> finishParse)+	finishParse (FromOrToRemote v) = FromOrToRemote <$> finishParse v+	finishParse ToHere = pure ToHere+	finishParse (FromRemoteToRemote v1 v2) = FromRemoteToRemote+		<$> finishParse v1+		<*> finishParse v2  -- Options for acting on keys, rather than work tree files. data KeyOptions@@ -239,15 +250,23 @@ annexedMatchingOptions = concat 	[ keyMatchingOptions' 	, fileMatchingOptions' Limit.LimitAnnexFiles+	, anythingNothingOptions 	, combiningOptions 	, timeLimitOption 	, sizeLimitOption 	] --- Matching options that can operate on keys as well as files.+-- Options to match properties of keys. keyMatchingOptions :: [AnnexOption]-keyMatchingOptions = keyMatchingOptions' ++ combiningOptions ++ timeLimitOption ++ sizeLimitOption+keyMatchingOptions = concat+	[ keyMatchingOptions'+	, anythingNothingOptions+	, combiningOptions +	, timeLimitOption +	, sizeLimitOption+	] +-- Matching options that can operate on keys as well as files. keyMatchingOptions' :: [AnnexOption] keyMatchingOptions' =  	[ annexOption (setAnnexState . Limit.addIn) $ strOption@@ -376,6 +395,20 @@ 	, annexOption (setAnnexState . Limit.addSmallerThan lb) $ strOption 		( long "smallerthan" <> metavar paramSize 		<> help "match files smaller than a size"+		<> hidden+		)+	]++anythingNothingOptions :: [AnnexOption]+anythingNothingOptions =+	[ annexFlag (setAnnexState Limit.addAnything)+		( long "anything"+		<> help "match all files"+		<> hidden+		)+	, annexFlag (setAnnexState Limit.addNothing)+		( long "nothing"+		<> help "don't match any files" 		<> hidden 		) 	]
CmdLine/Seek.hs view
@@ -234,7 +234,7 @@ 	bare <- fromRepo Git.repoIsLocalBare 	when (auto && bare) $ 		giveup "Cannot use --auto in a bare repository"-	case (noworktreeitems, ko) of+	case (nospecifiedworktreeitems, ko) of 		(True, Nothing) 			| bare -> nofilename $ noauto runallkeys 			| otherwise -> fallbackaction worktreeitems@@ -260,7 +260,7 @@ 		, a 		) -	noworktreeitems = case worktreeitems of+	nospecifiedworktreeitems = case worktreeitems of 		WorkTreeItems [] -> True 		WorkTreeItems _ -> False 		NoWorkTreeItems -> False
Command/AddUrl.hs view
@@ -467,9 +467,7 @@ 		-- Move to final location for large file check. 		pruneTmpWorkDirBefore tmp $ \_ -> do 			createWorkTreeDirectory (P.takeDirectory file)-			liftIO $ renameFile -				(fromRawFilePath tmp)-				(fromRawFilePath file)+			liftIO $ moveFile tmp file 		largematcher <- largeFilesMatcher 		large <- checkFileMatcher largematcher file 		if large@@ -477,9 +475,7 @@ 				-- Move back to tmp because addAnnexedFile 				-- needs the file in a different location 				-- than the work tree file.-				liftIO $ renameFile-					(fromRawFilePath file)-					(fromRawFilePath tmp)+				liftIO $ moveFile file tmp 				go 			else Command.Add.addSmall (DryRun False) file s 				>>= maybe noop void
Command/Copy.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -21,7 +21,7 @@  data CopyOptions = CopyOptions 	{ copyFiles :: CmdParams-	, fromToOptions :: FromToHereOptions+	, fromToOptions :: Maybe FromToHereOptions 	, keyOptions :: Maybe KeyOptions 	, autoMode :: Bool 	, batchOption :: BatchMode@@ -38,13 +38,19 @@ instance DeferredParseClass CopyOptions where 	finishParse v = CopyOptions 		<$> pure (copyFiles v)-		<*> finishParse (fromToOptions v)+		<*> maybe (pure Nothing) (Just <$$> finishParse)+			(fromToOptions v) 		<*> pure (keyOptions v) 		<*> pure (autoMode v) 		<*> pure (batchOption v)  seek :: CopyOptions -> CommandSeek-seek o = startConcurrency commandStages $ do+seek o = case fromToOptions o of+	Just fto -> seek' o fto+	Nothing -> giveup "Specify --from or --to"++seek' :: CopyOptions -> FromToHereOptions -> CommandSeek+seek' o fto = startConcurrency (Command.Move.stages fto) $ do 	case batchOption o of 		NoBatch -> withKeyOptions 			(keyOptions o) (autoMode o) seeker@@ -57,30 +63,33 @@ 	ww = WarnUnmatchLsFiles 	 	seeker = AnnexedFileSeeker-		{ startAction = start o-		, checkContentPresent = case fromToOptions o of-			Right (FromRemote _) -> Just False-			Right (ToRemote _) -> Just True-			Left ToHere -> Just False+		{ startAction = start o fto+		, checkContentPresent = case fto of+			FromOrToRemote (FromRemote _) -> Just False+			FromOrToRemote (ToRemote _) -> Just True+			ToHere -> Just False+			FromRemoteToRemote _ _ -> Just False 		, usesLocationLog = True 		}-	keyaction = Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever+	keyaction = Command.Move.startKey fto Command.Move.RemoveNever  {- A copy is just a move that does not delete the source file.  - However, auto mode avoids unnecessary copies, and avoids getting or  - sending non-preferred content. -}-start :: CopyOptions -> SeekInput -> RawFilePath -> Key -> CommandStart-start o si file key = stopUnless shouldCopy $ -	Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key+start :: CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart+start o fto si file key = stopUnless shouldCopy $ +	Command.Move.start fto Command.Move.RemoveNever si file key   where 	shouldCopy 		| autoMode o = want <||> numCopiesCheck file key (<) 		| otherwise = return True-	want = case fromToOptions o of-		Right (ToRemote dest) ->+	want = case fto of+		FromOrToRemote (ToRemote dest) -> 			(Remote.uuid <$> getParsed dest) >>= checkwantsend-		Right (FromRemote _) -> checkwantget-		Left ToHere -> checkwantget+		FromOrToRemote (FromRemote _) -> checkwantget+		ToHere -> checkwantget+		FromRemoteToRemote _ dest ->+			(Remote.uuid <$> getParsed dest) >>= checkwantsend 			 	checkwantsend = wantGetBy False (Just key) (AssociatedFile (Just file)) 	checkwantget = wantGet False (Just key) (AssociatedFile (Just file))
Command/Find.hs view
@@ -43,28 +43,26 @@ 	<*> parseBatchOption False  parseFormatOption :: Parser Utility.Format.Format-parseFormatOption = +parseFormatOption = parseFormatOption' "${file}\0"++parseFormatOption' :: String -> Parser Utility.Format.Format+parseFormatOption' print0format =  	option (Utility.Format.gen <$> str) 		( long "format" <> metavar paramFormat 		<> help "control format of output" 		)-	<|> flag' (Utility.Format.gen "${file}\0")+	<|> flag' (Utility.Format.gen print0format) 		( long "print0"-		<> help "output filenames terminated with nulls"+		<> help "use nulls to separate output rather than lines" 		)  seek :: FindOptions -> CommandSeek seek o = do 	unless (isJust (keyOptions o)) $ 		checkNotBareRepo-	islimited <- limited-	let seeker = AnnexedFileSeeker+	seeker <- contentPresentUnlessLimited $ AnnexedFileSeeker 		{ startAction = start o-		-- only files with content present are shown, unless-		-- the user has requested others via a limit-		, checkContentPresent = if islimited-			then Nothing-			else Just True+		, checkContentPresent = Nothing 		, usesLocationLog = False 		} 	case batchOption o of@@ -76,6 +74,17 @@ 			batchAnnexedFiles fmt seeker   where 	ww = WarnUnmatchLsFiles++-- Default to needing content to be present, but if the user specified a+-- limit, content does not need to be present.+contentPresentUnlessLimited :: AnnexedFileSeeker -> Annex AnnexedFileSeeker+contentPresentUnlessLimited s = do+	islimited <- limited+	return $ s+		{ checkContentPresent = if islimited+			then Nothing+			else Just True+		}  start :: FindOptions -> SeekInput -> RawFilePath -> Key -> CommandStart start o _ file key = startingCustomOutput key $ do
+ Command/FindKeys.hs view
@@ -0,0 +1,47 @@+{- git-annex command+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.FindKeys where++import Command+import qualified Utility.Format+import qualified Command.Find++cmd :: Command+cmd = withAnnexOptions [keyMatchingOptions] $ Command.Find.mkCommand $+	command "findkeys" SectionQuery "lists available keys"+		paramNothing (seek <$$> optParser)++data FindKeysOptions = FindKeysOptions+	{ formatOption :: Maybe Utility.Format.Format+	}++optParser :: CmdParamsDesc -> Parser FindKeysOptions+optParser _ = FindKeysOptions+	<$> optional (Command.Find.parseFormatOption' "${key}\0")++seek :: FindKeysOptions -> CommandSeek+seek o = do+	seeker <- Command.Find.contentPresentUnlessLimited $ AnnexedFileSeeker+		{ checkContentPresent = Nothing+		, usesLocationLog = False+		-- startAction is not actually used since this+		-- is not used to seek files+		, startAction = \_ _ key -> start' o key+		}+	withKeyOptions (Just WantAllKeys) False seeker+		(commandAction . start o)+		(const noop) (WorkTreeItems [])++start :: FindKeysOptions -> (SeekInput, Key, ActionItem) -> CommandStart+start o (_si, key, _ai) = start' o key++start' :: FindKeysOptions -> Key -> CommandStart+start' o key = startingCustomOutput key $ do+	Command.Find.showFormatted (formatOption o) (serializeKey' key)+		(Command.Find.formatVars key (AssociatedFile Nothing))+	next $ return True
Command/Get.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010, 2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -13,6 +13,7 @@ import Annex.NumCopies import Annex.Wanted import qualified Command.Move+import Logs.Location  cmd :: Command cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ @@ -37,7 +38,7 @@ 	<*> parseBatchOption True  seek :: GetOptions -> CommandSeek-seek o = startConcurrency downloadStages $ do+seek o = startConcurrency transferStages $ do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) 	let seeker = AnnexedFileSeeker 		{ startAction = start o from@@ -116,4 +117,5 @@ 		| otherwise = return True 	docopy r witness = do 		showAction $ "from " ++ Remote.name r-		download r key afile stdRetry witness+		logStatusAfter key $+			download r key afile stdRetry witness
Command/Mirror.hs view
@@ -48,7 +48,7 @@ 		=<< workTreeItems ww (mirrorFiles o)   where 	stages = case fromToOptions o of-		FromRemote _ -> downloadStages+		FromRemote _ -> transferStages 		ToRemote _ -> commandStages 	ww = WarnUnmatchLsFiles 	seeker = AnnexedFileSeeker
Command/Move.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - 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.  -}@@ -19,6 +19,7 @@ import Logs.Presence import Logs.Trust import Logs.File+import Logs.Location import Annex.NumCopies  import qualified Data.ByteString.Char8 as B8@@ -32,7 +33,7 @@  data MoveOptions = MoveOptions 	{ moveFiles :: CmdParams-	, fromToOptions :: FromToHereOptions+	, fromToOptions :: Maybe FromToHereOptions 	, removeWhen :: RemoveWhen 	, keyOptions :: Maybe KeyOptions 	, batchOption :: BatchMode@@ -49,7 +50,8 @@ instance DeferredParseClass MoveOptions where 	finishParse v = MoveOptions 		<$> pure (moveFiles v)-		<*> finishParse (fromToOptions v)+		<*> maybe (pure Nothing) (Just <$$> finishParse)+			(fromToOptions v) 		<*> pure (removeWhen v) 		<*> pure (keyOptions v) 		<*> pure (batchOption v)@@ -58,7 +60,12 @@ 	deriving (Show, Eq)  seek :: MoveOptions -> CommandSeek-seek o = startConcurrency stages $ do+seek o = case fromToOptions o of+	Just fto -> seek' o fto+	Nothing -> giveup "Specify --from or --to"++seek' :: MoveOptions -> FromToHereOptions -> CommandSeek+seek' o fto = startConcurrency (stages fto) $ do 	case batchOption o of 		NoBatch -> withKeyOptions (keyOptions o) False seeker 			(commandAction . keyaction)@@ -68,20 +75,23 @@ 			batchAnnexed fmt seeker keyaction   where 	seeker = AnnexedFileSeeker-		{ startAction = start (fromToOptions o) (removeWhen o)-		, checkContentPresent = case fromToOptions o of-			Right (FromRemote _) -> Nothing-			Right (ToRemote _) -> Just True-			Left ToHere -> Nothing+		{ startAction = start fto (removeWhen o)+		, checkContentPresent = case fto of+			FromOrToRemote (FromRemote _) -> Nothing+			FromOrToRemote (ToRemote _) -> Just True+			ToHere -> Nothing+			FromRemoteToRemote _ _ -> Nothing 		, usesLocationLog = True 		}-	stages = case fromToOptions o of-		Right (FromRemote _) -> downloadStages-		Right (ToRemote _) -> commandStages-		Left ToHere -> downloadStages-	keyaction = startKey (fromToOptions o) (removeWhen o)+	keyaction = startKey fto (removeWhen o) 	ww = WarnUnmatchLsFiles +stages :: FromToHereOptions -> UsedStages+stages (FromOrToRemote (FromRemote _)) = transferStages+stages (FromOrToRemote (ToRemote _)) = commandStages+stages ToHere = transferStages+stages (FromRemoteToRemote _ _) = transferStages+ start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart start fromto removewhen si f k = start' fromto removewhen afile si k ai   where@@ -95,15 +105,19 @@ start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart start' fromto removewhen afile si key ai = 	case fromto of-		Right (FromRemote src) ->+		FromOrToRemote (FromRemote src) -> 			checkFailedTransferDirection ai Download $ 				fromStart removewhen afile key ai si =<< getParsed src-		Right (ToRemote dest) ->+		FromOrToRemote (ToRemote dest) -> 			checkFailedTransferDirection ai Upload $ 				toStart removewhen afile key ai si =<< getParsed dest-		Left ToHere ->+		ToHere -> 			checkFailedTransferDirection ai Download $ 				toHereStart removewhen afile key ai si+		FromRemoteToRemote src dest -> do+			src' <- getParsed src+			dest' <- getParsed dest+			fromToStart removewhen afile key ai si src' dest'  describeMoveAction :: RemoveWhen -> String describeMoveAction RemoveNever = "copy"@@ -136,7 +150,10 @@ 	return $ dest `elem` remotes  toPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform-toPerform dest removewhen key afile fastcheck isthere = do+toPerform = toPerform' Nothing++toPerform' :: Maybe ContentRemovalLock -> Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform+toPerform' mcontentlock dest removewhen key afile fastcheck isthere = do 	srcuuid <- getUUID 	case isthere of 		Left err -> do@@ -165,7 +182,7 @@ 			setpresentremote 			logMoveCleanup deststartedwithcopy 			next $ return True-		RemoveSafe -> lockContentForRemoval key lockfailed $ \contentlock -> do+		RemoveSafe -> lockcontentforremoval $ \contentlock -> do 			srcuuid <- getUUID 			r <- willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case 				DropAllowed -> drophere setpresentremote contentlock "moved"@@ -200,6 +217,10 @@ 			() <- setpresentremote 			return False 	+	lockcontentforremoval a = case mcontentlock of+		Nothing -> lockContentForRemoval key lockfailed a+		Just contentlock -> a contentlock+	 	-- This occurs when, for example, two files are being dropped 	-- and have the same content. The seek stage checks if the content 	-- is present, but due to buffering, may find it present for the@@ -233,39 +254,54 @@  fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform fromPerform src removewhen key afile = do-	showAction $ "from " ++ Remote.name src 	present <- inAnnex key+	finish <- fromPerform' present True src key afile+	finish removewhen++fromPerform' :: Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform)+fromPerform' present updatelocationlog src key afile = do+	showAction $ "from " ++ Remote.name src 	destuuid <- getUUID-	logMove srcuuid destuuid present key $ \deststartedwithcopy ->+	logMove (Remote.uuid src) destuuid present key $ \deststartedwithcopy -> 		if present-			then dispatch removewhen deststartedwithcopy True-			else dispatch removewhen deststartedwithcopy =<< get+			then return $ finish deststartedwithcopy True+			else do+				got <- get+				return $ finish deststartedwithcopy got   where 	get = notifyTransfer Download afile $-		download src key afile stdRetry+		logdownload .+			download src key afile stdRetry 	-	dispatch _ deststartedwithcopy False = do+	logdownload a+		| updatelocationlog = logStatusAfter key a+		| otherwise = a++	finish deststartedwithcopy False _ = do 		logMoveCleanup deststartedwithcopy 		stop -- copy failed-	dispatch RemoveNever deststartedwithcopy True = do+	finish deststartedwithcopy True RemoveNever = do 		logMoveCleanup deststartedwithcopy 		next $ return True -- copy complete-	dispatch RemoveSafe deststartedwithcopy True = lockContentShared key $ \_lck -> do+	finish deststartedwithcopy True RemoveSafe = do 		destuuid <- getUUID-		willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case-			DropAllowed -> dropremote deststartedwithcopy "moved"-			DropCheckNumCopies -> do-				(numcopies, mincopies) <- getSafestNumMinCopies afile key-				(tocheck, verified) <- verifiableCopies key [Remote.uuid src]-				verifyEnoughCopiesToDrop "" key Nothing numcopies mincopies [Remote.uuid src] verified-					tocheck (dropremote deststartedwithcopy . showproof) (faileddropremote deststartedwithcopy)-			DropWorse -> faileddropremote deststartedwithcopy-	-	srcuuid = Remote.uuid src-	+		lockContentShared key $ \_lck ->+			fromDrop src destuuid deststartedwithcopy key afile id++fromDrop :: Remote -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> ([UnVerifiedCopy] -> [UnVerifiedCopy])-> CommandPerform+fromDrop src destuuid deststartedwithcopy key afile adjusttocheck =+	willDropMakeItWorse (Remote.uuid src) destuuid deststartedwithcopy key afile >>= \case+		DropAllowed -> dropremote "moved"+		DropCheckNumCopies -> do+			(numcopies, mincopies) <- getSafestNumMinCopies afile key+			(tocheck, verified) <- verifiableCopies key [Remote.uuid src]+			verifyEnoughCopiesToDrop "" key Nothing numcopies mincopies [Remote.uuid src] verified+				(adjusttocheck tocheck) (dropremote . showproof) faileddropremote+		DropWorse -> faileddropremote+  where 	showproof proof = "proof: " ++ show proof-	-	dropremote deststartedwithcopy reason = do++	dropremote reason = do 		fastDebug "Command.Move" $ unwords 			[ "Dropping from remote" 			, show src@@ -275,8 +311,8 @@ 		when ok $ 			logMoveCleanup deststartedwithcopy 		next $ Command.Drop.cleanupRemote key src (Command.Drop.DroppingUnused False) ok-	-	faileddropremote deststartedwithcopy = do++	faileddropremote = do 		showLongNote "(Use --force to override this check, or adjust numcopies.)" 		showLongNote $ "Content not dropped from " ++ Remote.name src ++ "." 		logMoveCleanup deststartedwithcopy@@ -297,6 +333,124 @@ 					fromPerform r removewhen key afile 		next $ return True +fromToStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> Remote -> CommandStart+fromToStart removewhen afile key ai si src dest = do+	if Remote.uuid src == Remote.uuid dest+		then stop+		else do+			u <- getUUID+			if u == Remote.uuid src+				then toStart removewhen afile key ai si dest+				else if u == Remote.uuid dest+					then fromStart removewhen afile key ai si src+					else stopUnless (fromOk src key) $+						starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $+							fromToPerform src dest removewhen key afile++{- When there is a local copy, transfer it to the dest, and drop from the src.+ -+ - When the dest has a copy, drop it from the src.+ -+ - Otherwise, download a copy from the dest, populating the local annex+ - copy, but not updating location logs. Then transfer that to the dest,+ - drop the local copy, and finally drop from the src.+ -+ - Using a regular download of the local copy, rather than download to+ - some other file makes resuming an interruped download work as usual,+ - and simplifies implementation. It does mean that, if `git-annex get` of+ - the same content is being run at the same time as this move, the content+ - may end up locally present, or not. This is similar to the behavior + - when running `git-annex move --to` concurrently with git-annex get.+ -}+fromToPerform :: Remote -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform+fromToPerform src dest removewhen key afile = do+	hereuuid <- getUUID+	loggedpresent <- any (== hereuuid)+		<$> loggedLocations key+	ispresent <- inAnnex key+	go ispresent loggedpresent+  where+	-- The content is present, and is logged as present, so it+	-- can be sent to dest and dropped from src.+	--+	-- When resuming an interrupted move --from --to, where the content+	-- was not present but got downloaded from src, it will not be+	-- logged present, and so this won't be used. Instead, the local+	-- content will get dropped after being copied to dest.+	go True True = do+		haskey <- Remote.hasKey dest key+		-- Prepare to drop from src later. Doing this first+		-- makes "from src" be shown consistently before+		-- "to dest"+		dropsrc <- fromsrc True+		combinecleanups +			-- Send to dest, preserve local copy.+			(todest Nothing RemoveNever haskey)+			(\senttodest -> if senttodest+				then dropsrc removewhen+				else stop+			)+	go ispresent _loggedpresent = do+		haskey <- Remote.hasKey dest key+		case haskey of+                	Left err -> do                   +				showNote err       +				stop+			Right True -> do+				showAction $ "from " ++ Remote.name src+				showAction $ "to " ++ Remote.name dest+				-- Drop from src, checking copies including+				-- the one already in dest.+				dropfromsrc id+			Right False -> do+				-- Get local copy from src, defer dropping+				-- from src until later. Note that fromsrc+				-- does not update the location log.+				cleanupfromsrc <- if ispresent+					then return $ const $ next (return True)+					else fromsrc False+				-- Lock the local copy for removal early,+				-- to avoid other processes relying on it+				-- as a copy, and removing other copies+				-- (such as the one in src), that prevents+				-- dropping the local copy later.+				lockContentForRemoval key stop $ \contentlock ->+					combinecleanups+						-- Send to dest and remove local copy.+						(todest (Just contentlock) RemoveSafe haskey)+						(\senttodest ->+							-- Drop from src, checking+							-- copies including dest.+							combinecleanups+								(cleanupfromsrc RemoveNever)+								(\_ -> if senttodest+									then dropfromsrc (\l -> UnVerifiedRemote dest : l)+									else stop+								)+						)++	fromsrc present = fromPerform' present False src key afile++	todest mcontentlock removewhen' = toPerform' mcontentlock dest removewhen' key afile False++	dropfromsrc adjusttocheck = case removewhen of+		RemoveSafe -> logMove (Remote.uuid src) (Remote.uuid dest) True key $ \deststartedwithcopy ->+			fromDrop src (Remote.uuid dest) deststartedwithcopy key afile adjusttocheck+		RemoveNever -> next (return True)++	combinecleanups a b = a >>= \case+		Just cleanupa -> b True >>= \case+			Just cleanupb -> return $ Just $ do+				oka <- cleanupa+				okb <- cleanupb+				return (oka && okb)+			Nothing -> return (Just cleanupa)+		Nothing -> b False >>= \case+			Just cleanupb -> return $ Just $ do+				void cleanupb+				return False+			Nothing -> return Nothing+ {- The goal of this command is to allow the user maximum freedom to move  - files as they like, while avoiding making bad situations any worse  - than they already were.@@ -306,9 +460,10 @@  - repository reduces the number of copies, and should fail if  - that would violate numcopies settings.  -- - On the other hand, when the destination repository does not already- - have a copy of a file, it can be dropped without making numcopies- - worse, so the move is allowed even if numcopies is not met.+ - On the other hand, when the destination repository did not start+ - with a copy of a file, it can be dropped from the source without+ - making numcopies worse, so the move is allowed even if numcopies+ - is not met.  -  - Similarly, a file can move from an untrusted repository to another  - untrusted repository, even if that is the only copy of the file.
Command/Sync.hs view
@@ -212,7 +212,7 @@ seek :: SyncOptions -> CommandSeek seek o = do 	prepMerge-	startConcurrency downloadStages (seek' o)+	startConcurrency transferStages (seek' o) 	 seek' :: SyncOptions -> CommandSeek seek' o = do
Config.hs view
@@ -1,6 +1,6 @@ {- Git configuration  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -24,7 +24,9 @@ import Config.DynamicConfig import Types.Availability import Types.GitConfig+import Types.RemoteConfig import Git.Types+import Annex.SpecialRemote.Config  {- Looks up a setting in git config. This is not as efficient as using the  - GitConfig type. -}@@ -51,14 +53,17 @@ unsetConfig :: ConfigKey -> Annex () unsetConfig key = void $ inRepo $ Git.Config.unset key -{- Calculates cost for a remote. Either the specific default, or as configured - - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command- - is set and prints a number, that is used. -}-remoteCost :: RemoteGitConfig -> Cost -> Annex Cost-remoteCost c d = fromMaybe d <$> remoteCost' c+{- Gets cost for a remote. As configured by+ - remote.<name>.annex-cost, or if remote.<name>.annex-cost-command+ - is set and prints a number, that is used. If neither is set,+ - using the cost field from the ParsedRemoteConfig, and if it is not set,+ - the specified default. -}+remoteCost :: RemoteGitConfig -> ParsedRemoteConfig -> Cost -> Annex Cost+remoteCost gc pc d = fromMaybe d <$> remoteCost' gc pc -remoteCost' :: RemoteGitConfig -> Annex (Maybe Cost)-remoteCost' = liftIO . getDynamicConfig . remoteAnnexCost+remoteCost' :: RemoteGitConfig -> ParsedRemoteConfig -> Annex (Maybe Cost)+remoteCost' gc pc = maybe (getRemoteConfigValue costField pc) Just+	<$> liftIO (getDynamicConfig $ remoteAnnexCost gc)  setRemoteCost :: Git.Repo -> Cost -> Annex () setRemoteCost r c = setConfig (remoteAnnexConfig r "cost") (show c)
Config/Smudge.hs view
@@ -29,7 +29,11 @@ 	-- unexpected changes when the file is checked into git or annex 	-- counter to the annex.largefiles configuration. 	-- Avoid that problem by running git status now.-	inRepo $ Git.Command.runQuiet [Param "status", Param "--porcelain"]+	inRepo $ Git.Command.runQuiet+		[ Param "status"+		, Param "--porcelain"+		, Param "--ignore-submodules"+		]  	setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge -- %f" 	setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean -- %f"
Database/Keys/SQL.hs view
@@ -93,7 +93,7 @@ -- any old key. newAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO () newAssociatedFile k f = queueDb $-	void $ insert $ Associated k af+	insert_ $ Associated k af   where 	af = SFilePath (getTopFilePath f)
Limit.hs view
@@ -1,6 +1,6 @@ {- user-specified limits on files to act on  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -431,6 +431,10 @@ 	 	isunused k = S.member k <$> unusedKeys +{- Adds a limit that matches anything. -}+addAnything :: Annex ()+addAnything = addLimit (Right limitAnything)+ {- Limit that matches any version of any file or key. -} limitAnything :: MatchFiles Annex limitAnything = MatchFiles@@ -440,6 +444,10 @@ 	, matchNeedsKey = False 	, matchNeedsLocationLog = False 	}++{- Adds a limit that never matches. -}+addNothing :: Annex ()+addNothing = addLimit (Right limitNothing)  {- Limit that never matches. -} limitNothing :: MatchFiles Annex
Remote/Adb.hs view
@@ -15,6 +15,7 @@ import Types.Export import Types.Import import qualified Git+import Config import Config.Cost import Remote.Helper.Special import Remote.Helper.ExportImport@@ -70,11 +71,12 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc+	-- adb operates over USB or wifi, so is not as cheap+	-- as local, but not too expensive+	cst <- remoteCost gc c semiExpensiveRemoteCost 	let this = Remote 		{ uuid = u-		-- adb operates over USB or wifi, so is not as cheap-		-- as local, but not too expensive-		, cost = semiExpensiveRemoteCost+		, cost = cst 		, name = Git.repoDescribe r 		, storeKey = storeKeyDummy 		, retrieveKeyFile = retrieveKeyFileDummy
Remote/BitTorrent.hs view
@@ -60,8 +60,8 @@  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r _ rc gc rs = do-	cst <- remoteCost gc expensiveRemoteCost 	c <- parsedRemoteConfig remote rc+	cst <- remoteCost gc c expensiveRemoteCost 	return $ Just Remote 		{ uuid = bitTorrentUUID 		, cost = cst@@ -217,7 +217,7 @@ 						ok <- Url.withUrlOptions $  							Url.download nullMeterUpdate Nothing u f 						when ok $-							liftIO $ renameFile f (fromRawFilePath torrent)+							liftIO $ moveFile (toRawFilePath f) torrent 						return ok 		) @@ -228,7 +228,7 @@ 			<$> dirContents metadir 		case ts of 			(t:[]) -> do-				renameFile t dest+				moveFile (toRawFilePath t) (toRawFilePath dest) 				return True 			_ -> return False 	, return False@@ -256,7 +256,7 @@ 		showOutput 		ifM (download torrent downloaddir <&&> liftIO (doesFileExist dlf)) 			( do-				liftIO $ renameFile dlf dest+				liftIO $ moveFile (toRawFilePath dlf) (toRawFilePath dest) 				-- The downloaddir is not removed here, 				-- so if aria downloaded parts of other 				-- files, and this is called again, it will
Remote/Borg.hs view
@@ -75,7 +75,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc $+	cst <- remoteCost gc c $ 		if borgLocal borgrepo 			then nearlyCheapRemoteCost 			else expensiveRemoteCost
Remote/Bup.hs view
@@ -65,7 +65,7 @@ gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc 	bupr <- liftIO $ bup2GitRemote buprepo-	cst <- remoteCost gc $+	cst <- remoteCost gc c $ 		if bupLocal buprepo 			then nearlyCheapRemoteCost 			else expensiveRemoteCost
Remote/Ddar.hs view
@@ -55,7 +55,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc $+	cst <- remoteCost gc c $ 		if ddarLocal ddarrepo 			then nearlyCheapRemoteCost 			else expensiveRemoteCost
Remote/Directory.hs view
@@ -73,7 +73,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc cheapRemoteCost+	cst <- remoteCost gc c cheapRemoteCost 	let chunkconfig = getChunkConfig c 	cow <- liftIO newCopyCoWTried 	let ii = IgnoreInodes $ fromMaybe True $
Remote/External.hs view
@@ -67,7 +67,7 @@ 	-- readonly mode only downloads urls; does not use external program 	| externaltype == "readonly" = do 		c <- parsedRemoteConfig remote rc-		cst <- remoteCost gc expensiveRemoteCost+		cst <- remoteCost gc c expensiveRemoteCost 		let rmt = mk c cst GloballyAvailable 			Nothing 			(externalInfo externaltype)@@ -86,7 +86,7 @@ 		external <- newExternal externaltype (Just u) c (Just gc) 			(Git.remoteName r) (Just rs) 		Annex.addCleanupAction (RemoteCleanup u) $ stopExternal external-		cst <- getCost external r gc+		cst <- getCost external r gc c 		avail <- getAvailability external r gc 		exportsupported <- if exportTree c 			then checkExportSupported' external@@ -755,9 +755,9 @@ {- Caches the cost in the git config to avoid needing to start up an  - external special remote every time time just to ask it what its  - cost is. -}-getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost-getCost external r gc =-	(go =<< remoteCost' gc) `catchNonAsync` const (pure defcst)+getCost :: External -> Git.Repo -> RemoteGitConfig -> ParsedRemoteConfig -> Annex Cost+getCost external r gc pc =+	(go =<< remoteCost' gc pc) `catchNonAsync` const (pure defcst)   where 	go (Just c) = return c 	go Nothing = do
Remote/GCrypt.hs view
@@ -127,8 +127,10 @@  gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen' r u c gc rs = do-	cst <- remoteCost gc $-		if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost+	cst <- remoteCost gc c $+		if repoCheap r+			then nearlyCheapRemoteCost+			else expensiveRemoteCost 	let (rsynctransport, rsyncurl, accessmethod) = rsyncTransportToObjects r gc 	protectsargs <- liftIO Remote.Rsync.probeRsyncProtectsArgs 	let rsyncopts = Remote.Rsync.genRsyncOpts protectsargs c gc rsynctransport rsyncurl
Remote/Git.hs view
@@ -174,7 +174,7 @@ 		Nothing -> do 			st <- mkState r u gc 			c <- parsedRemoteConfig remote rc-			go st c <$> remoteCost gc defcst+			go st c <$> remoteCost gc c defcst 		Just addr -> Remote.P2P.chainGen addr r u rc gc rs   where 	defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
Remote/GitLFS.hs view
@@ -93,7 +93,7 @@ 		else pure r 	sem <- liftIO $ MSemN.new 1 	h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc-	cst <- remoteCost gc expensiveRemoteCost+	cst <- remoteCost gc c expensiveRemoteCost 	let specialcfg = (specialRemoteCfg c) 		-- chunking would not improve git-lfs 		{ chunkConfig = NoChunks
Remote/Glacier.hs view
@@ -63,9 +63,10 @@ fileprefixField = Accepted "fileprefix"  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u rc gc rs = new -	<$> parsedRemoteConfig remote rc-	<*> remoteCost gc veryExpensiveRemoteCost+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc+	cst <- remoteCost gc c veryExpensiveRemoteCost+	return (new c cst)   where 	new c cst = Just $ specialRemote' specialcfg c 		(store this)
Remote/Hook.hs view
@@ -50,7 +50,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc expensiveRemoteCost+	cst <- remoteCost gc c expensiveRemoteCost 	return $ Just $ specialRemote c 		(store hooktype) 		(retrieve hooktype)
Remote/HttpAlso.hs view
@@ -50,7 +50,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc expensiveRemoteCost+	cst <- remoteCost gc c expensiveRemoteCost 	let url = getRemoteConfigValue urlField c 	ll <- liftIO newLearnedLayout 	return $ Just $ this url ll c cst
Remote/P2P.hs view
@@ -48,7 +48,7 @@ chainGen addr r u rc gc rs = do 	c <- parsedRemoteConfig remote rc 	connpool <- mkConnectionPool-	cst <- remoteCost gc veryExpensiveRemoteCost+	cst <- remoteCost gc c veryExpensiveRemoteCost 	let protorunner = runProto u addr connpool 	let withconn = withConnection u addr connpool 	let this = Remote
Remote/Rsync.hs view
@@ -75,7 +75,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc expensiveRemoteCost+	cst <- remoteCost gc c expensiveRemoteCost 	(transport, url) <- rsyncTransport gc $ 		fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc 	protectsargs <- liftIO probeRsyncProtectsArgs
Remote/S3.hs view
@@ -187,7 +187,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc expensiveRemoteCost+	cst <- remoteCost gc c expensiveRemoteCost 	info <- extractS3Info c 	hdl <- mkS3HandleVar c gc u 	magic <- liftIO initMagicMime
Remote/Tahoe.hs view
@@ -79,7 +79,7 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc expensiveRemoteCost+	cst <- remoteCost gc c expensiveRemoteCost 	hdl <- liftIO $ TahoeHandle 		<$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc) 		<*> newEmptyTMVarIO
Remote/Web.hs view
@@ -1,6 +1,6 @@ {- Web remote.  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -9,6 +9,9 @@  import Annex.Common import Types.Remote+import Types.ProposedAccepted+import Types.Creds+import Remote.Helper.Special import Remote.Helper.ExportImport import qualified Git import qualified Git.Construct@@ -19,47 +22,64 @@ import Logs.Web import Annex.UUID import Utility.Metered+import Utility.Glob import qualified Annex.Url as Url import Annex.YoutubeDl import Annex.SpecialRemote.Config+import Logs.Remote +import qualified Data.Map as M+ remote :: RemoteType remote = RemoteType 	{ typename = "web" 	, enumerate = list 	, generate = gen-	, configParser = mkRemoteConfigParser []-	, setup = error "not supported"+	, configParser = mkRemoteConfigParser+		[ optionalStringParser urlincludeField+			(FieldDesc "only use urls matching this glob")+		, optionalStringParser urlexcludeField+			(FieldDesc "don't use urls that match this glob")+		]+	, setup = setupInstance 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported 	, thirdPartyPopulated = False 	} --- There is only one web remote, and it always exists.+-- The web remote always exists. -- (If the web should cease to exist, remove this module and redistribute -- a new release to the survivors by carrier pigeon.)+--+-- There may also be other instances of the web remote, which can be+-- limited to accessing particular urls, and have different costs. list :: Bool -> Annex [Git.Repo] list _autoinit = do 	r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown)-	return [r]+	others <- findSpecialRemotes "web"+	-- List the main one last, this makes its name be used instead+	-- of the other names when git-annex is referring to content on the+	-- web.+	return (others++[r])  gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r _ rc gc rs = do+gen r u rc gc rs = do 	c <- parsedRemoteConfig remote rc-	cst <- remoteCost gc expensiveRemoteCost+	cst <- remoteCost gc c expensiveRemoteCost+ 	urlincludeexclude <- mkUrlIncludeExclude c 	return $ Just Remote-		{ uuid = webUUID+		{ uuid = if u == NoUUID then webUUID else u 		, cost = cst 		, name = Git.repoDescribe r 		, storeKey = uploadKey-		, retrieveKeyFile = downloadKey+		, retrieveKeyFile = downloadKey urlincludeexclude 		, retrieveKeyFileCheap = Nothing 		-- HttpManagerRestricted is used here, so this is 		-- secure. 		, retrievalSecurityPolicy = RetrievalAllKeysSecure-		, removeKey = dropKey+		, removeKey = dropKey urlincludeexclude 		, lockContent = Nothing-		, checkPresent = checkKey+		, checkPresent = checkKey urlincludeexclude 		, checkPresentCheap = False 		, exportActions = exportUnsupported 		, importActions = importUnsupported@@ -77,13 +97,23 @@ 		, remotetype = remote 		, mkUnavailable = return Nothing 		, getInfo = return []-		, claimUrl = Nothing -- implicitly claims all urls+		-- claimingUrl makes the web special remote claim+		-- urls that are not claimed by other remotes,+		-- so no need to claim anything here.+		, claimUrl = Nothing 		, checkUrl = Nothing 		, remoteStateHandle = rs 		} -downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification-downloadKey key _af dest p vc = go =<< getWebUrls key+setupInstance :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+setupInstance _ mu _ c _ = do+	u <- maybe (liftIO genUUID) return mu+	gitConfigSpecialRemote u c [("web", "true")]+	return (c, u)++downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification+downloadKey urlincludeexclude key _af dest p vc = +	go =<< getWebUrls' urlincludeexclude key   where 	go [] = giveup "no known url" 	go urls = dl (partition (not . isyoutube) (map getDownloader urls)) >>= \case@@ -114,12 +144,12 @@ uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () uploadKey _ _ _ = giveup "upload to web not supported" -dropKey :: Key -> Annex ()-dropKey k = mapM_ (setUrlMissing k) =<< getWebUrls k+dropKey :: UrlIncludeExclude -> Key -> Annex ()+dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k -checkKey :: Key -> Annex Bool-checkKey key = do-	us <- getWebUrls key+checkKey :: UrlIncludeExclude -> Key -> Annex Bool+checkKey urlincludeexclude key = do+	us <- getWebUrls' urlincludeexclude key 	if null us 		then return False 		else either giveup return =<< checkKey' key us@@ -139,7 +169,65 @@ 			_ -> firsthit rest r a  getWebUrls :: Key -> Annex [URLString]-getWebUrls key = filter supported <$> getUrls key+getWebUrls key = getWebUrls' alwaysInclude key++getWebUrls' :: UrlIncludeExclude -> Key -> Annex [URLString]+getWebUrls' urlincludeexclude key = +	filter supported <$> getUrls key   where-	supported u = snd (getDownloader u) +	supported u = supporteddownloader u +		&& checkUrlIncludeExclude urlincludeexclude u+	supporteddownloader u = snd (getDownloader u)  		`elem` [WebDownloader, YoutubeDownloader]++urlincludeField :: RemoteConfigField+urlincludeField = Accepted "urlinclude"++urlexcludeField :: RemoteConfigField+urlexcludeField = Accepted "urlexclude"++data UrlIncludeExclude = UrlIncludeExclude+	{ checkUrlIncludeExclude :: URLString -> Bool+	}++alwaysInclude :: UrlIncludeExclude+alwaysInclude = UrlIncludeExclude { checkUrlIncludeExclude = const True }++mkUrlIncludeExclude :: ParsedRemoteConfig -> Annex UrlIncludeExclude+mkUrlIncludeExclude = go fallback+  where+	go b pc = case (getglob urlincludeField pc, getglob urlexcludeField pc) of+		(Nothing, Nothing) -> b+		(minclude, mexclude) -> mk minclude mexclude++	getglob f pc = do+		glob <- getRemoteConfigValue f pc+		Just $ compileGlob glob CaseInsensative (GlobFilePath False)+	+	mk minclude mexclude = pure $ UrlIncludeExclude+			{ checkUrlIncludeExclude = \u -> and+				[ case minclude of+					Just glob -> matchGlob glob u+					Nothing -> True+				, case mexclude of+					Nothing -> True+					Just glob -> not (matchGlob glob u)+				]+			}++	-- When nothing to include or exclude is specified, only include+	-- urls that are not explicitly included by other web special remotes.+	fallback = do+		rcs <- M.elems . M.filter iswebremote <$> remoteConfigMap+		l <- forM rcs $ \rc ->+			parsedRemoteConfig remote rc+				>>= go (pure neverinclude)+		pure $ UrlIncludeExclude+			{ checkUrlIncludeExclude = \u ->+				not (any (\c -> checkUrlIncludeExclude c u) l)+			}+	+	iswebremote rc = (fromProposedAccepted <$> M.lookup typeField rc)+		== Just (typename remote)++	neverinclude = UrlIncludeExclude { checkUrlIncludeExclude = const False }
Remote/WebDAV.hs view
@@ -72,7 +72,7 @@ 	c <- parsedRemoteConfig remote rc 	new 		<$> pure c-		<*> remoteCost gc expensiveRemoteCost+		<*> remoteCost gc c expensiveRemoteCost 		<*> mkDavHandleVar c gc u   where 	new c cst hdl = Just $ specialRemote c
+ Types/Direction.hs view
@@ -0,0 +1,25 @@+{- git-annex transfer direction types+ -+ - Copyright 2012 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Types.Direction where++import qualified Data.ByteString as B++data Direction = Upload | Download+	deriving (Eq, Ord, Show, Read)++formatDirection :: Direction -> B.ByteString+formatDirection Upload = "upload"+formatDirection Download = "download"++parseDirection :: String -> Maybe Direction+parseDirection "upload" = Just Upload+parseDirection "download" = Just Download+parseDirection _ = Nothing+
Types/Transfer.hs view
@@ -5,20 +5,22 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module Types.Transfer where+module Types.Transfer (+	module Types.Transfer,+	module Types.Direction+) where  import Types import Types.Remote (Verification(..)) import Types.Key+import Types.Direction import Utility.PID import Utility.QuickCheck import Utility.Url import Utility.FileSystemEncoding -import qualified Data.ByteString as B import Data.Time.Clock.POSIX import Control.Concurrent import Control.Applicative@@ -54,18 +56,6 @@  stubTransferInfo :: TransferInfo stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (AssociatedFile Nothing) False--data Direction = Upload | Download-	deriving (Eq, Ord, Show, Read)--formatDirection :: Direction -> B.ByteString-formatDirection Upload = "upload"-formatDirection Download = "download"--parseDirection :: String -> Maybe Direction-parseDirection "upload" = Just Upload-parseDirection "download" = Just Download-parseDirection _ = Nothing  instance Arbitrary TransferInfo where 	arbitrary = TransferInfo
Types/WorkerPool.hs view
@@ -1,12 +1,14 @@ {- Worker thread pool.  -- - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  module Types.WorkerPool where +import Types.Direction+ import Control.Concurrent import Control.Concurrent.Async import qualified Data.Set as S@@ -49,7 +51,7 @@ 	-- ^ Running a CommandPerform action. 	| CleanupStage 	-- ^ Running a CommandCleanup action.-	| TransferStage+	| TransferStage Direction 	-- ^ Transferring content to or from a remote. 	| VerifyStage 	-- ^ Verifying content, eg by calculating a checksum.@@ -82,15 +84,24 @@ 	, stageSet = S.fromList [PerformStage, CleanupStage] 	} --- | When a command is downloading content, it can use this instead.--- Downloads are often bottlenecked on the network or another disk--- than the one containing the repository, while verification bottlenecks--- on the disk containing the repository or on the CPU. So, run the--- transfer and verify stage separately.-downloadStages :: UsedStages-downloadStages = UsedStages-	{ initialStage = TransferStage-	, stageSet = S.fromList [TransferStage, VerifyStage]+-- | This is mostly useful for downloads, not for uploads. A download+-- is often bottlenecked on the network or another disk than the one+-- containing the repository. When verification is not done incrementally,+-- it bottlenecks on the disk containing the repository or on the CPU.+-- So it makes sense to run the download and verify stages separately.+-- +-- For uploads, there is no separate verify step to this is less likely+-- to be useful than commandStages. However, a separate stage is provided+-- for Uploads. That can be useful when a command downloads from one remote+-- (eg using the network) and uploads to another remote (eg using a disk).+transferStages :: UsedStages+transferStages = UsedStages+	{ initialStage = TransferStage Download+	, stageSet = S.fromList+		[ TransferStage Download+		, TransferStage Upload+		, VerifyStage+		] 	}  workerStage :: Worker t -> WorkerStage
Utility/LinuxMkLibs.hs view
@@ -64,12 +64,16 @@   where 	getlib l = headMaybe . words =<< lastMaybe (split " => " l) -{- Get all glibc libs.+{- Get all glibc libs, and also libgcc_s  -  - XXX Debian specific. -} glibcLibs :: IO [FilePath]-glibcLibs = lines <$> readProcess "sh"-	["-c", "dpkg -L libc6:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"]+glibcLibs = do+	ls <- lines <$> readProcess "sh"+		["-c", "dpkg -L libc6:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"]+	ls2 <- lines <$> readProcess "sh"+		["-c", "dpkg -L libgcc-s1:$(dpkg --print-architecture) | egrep '\\.so'"]+	return (ls++ls2)  {- Get gblibc's gconv libs, which are handled specially.. -} gconvLibs :: IO [FilePath]
doc/git-annex-copy.mdwn view
@@ -32,12 +32,24 @@   Copy the content of files from all reachable remotes to the local   repository. +* `--from=remote1 --to=remote2`++  Copy the content of files that are in remote1 to remote2.++  This is implemented by first downloading the content from remote1 to the+  local repository (if not already present), then sending it to remote2, and+  then deleting the content from the local repository (if it was not present+  to start with).+ * `--jobs=N` `-JN`    Enables parallel transfers with up to the specified number of jobs   running at once. For example: `-J10`    Setting this to "cpus" will run one job per CPU core.++  Note that when using --from with --to, twice this many jobs will+  run at once, evenly split between the two remotes.  * `--auto`
doc/git-annex-drop.mdwn view
@@ -1,4 +1,4 @@-#a NAME+# NAME  git-annex drop - remove content of files from repository
doc/git-annex-find.mdwn view
@@ -22,7 +22,7 @@   currently present. Specifying any of the matching options will override   this default behavior. -  To list all annexed files, present or not, specify `--include "*"`.+  To list all annexed files, present or not, specify `--anything`.    To list annexed files whose content is not present, specify `--not --in=here` @@ -85,7 +85,7 @@  [[git-annex-whereis]](1) -[[git-annex-list]](1)+[[git-annex-findkeys]](1)  # AUTHOR
+ doc/git-annex-findkeys.mdwn view
@@ -0,0 +1,73 @@+# NAME++git-annex findkeys - lists available keys++# SYNOPSIS++git annex findkeys++# DESCRIPTION++Outputs a list of keys known to git-annex.++# OPTIONS++* matching options+    +  The [[git-annex-matching-options]](1)+  can be used to specify which keys to list.++  By default, the findkeys command only lists keys whose content is+  currently present. Specifying any of the matching options will override+  this default behavior and match on all keys that git-annex knows about.++  To list all keys, present or not, specify `--anything`.++  To list keys whose content is not present, specify `--not --in=here`++* `--print0`++  Output keys terminated with nulls, for use with `xargs -0`++* `--format=value`++  Use custom output formatting.++  The value is a format string, in which '${var}' is expanded to the+  value of a variable. To right-justify a variable with whitespace,+  use '${var;width}' ; to left-justify a variable, use '${var;-width}';+  to escape unusual characters in a variable, use '${escaped_var}'++  These variables are available for use in formats: key, backend,+  bytesize, humansize, keyname, hashdirlower, hashdirmixed, mtime (for+  the mtime field of a WORM key).++  Also, '\\n' is a newline, '\\000' is a NULL, etc.++  The default output format is the same as `--format='${key}\\n'`++* `--json`++  Output the list of keys in JSON format.++  This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.++* Also the [[git-annex-common-options]](1) can be used.++# SEE ALSO++[[git-annex]](1)++[[git-annex-find]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex-initremote.mdwn view
@@ -106,6 +106,12 @@   when the special remote does not need anything special to be done to get   it enabled. +* `cost`++  Specify this to override the default cost of the special remote.+  This configuration can be overridden by the local git config,+  eg remote.name.annex-cost.+ * `uuid`    Normally, git-annex initremote generates a new UUID for the new special
doc/git-annex-matching-options.mdwn view
@@ -142,12 +142,16 @@   matches the glob. The values of metadata fields are matched case   insensitively. -* `--metadata field<number` / `--metadata field>number`-* `--metadata field<=number` / `--metadata field>=number`+* `--metadata field<value` / `--metadata field>value`+* `--metadata field<=value` / `--metadata field>=value` -  Matches only when there is a metadata field attached with a value that-  is a number and is less than or greater than the specified number.+  Matches only when there is a metadata field attached with a value+  that is less then or greater than the specified value, respectively. +  When both values are numbers, the comparison is done numerically.+  When one value is not a number, the values are instead compared+  lexicographically.+   (Note that you will need to quote the second parameter to avoid   the shell doing redirection.) @@ -240,6 +244,15 @@    This is only available to use when git-annex was built with the   MagicMime build flag.++* `--anything`++  Always matches. One way this can be useful is `git-annex find --anything`+  will list all annexed files, whether their content is present or not.++* `--nothing`++  Never matches. (Same as `--not --anything`)  * `--not`
doc/git-annex-move.mdwn view
@@ -28,6 +28,16 @@   Move the content of files from all reachable remotes to the local   repository. +* `--from=remote1 --to=remote2`++  Move the content of files that are in remote1 to remote2. Does not change+  what is stored in the local repository.++  This is implemented by first downloading the content from remote1 to the+  local repository (if not already present), then sending it to remote2, and+  then deleting the content from the local repository (if it was not present+  to start with).+ * `--force`    Override numcopies and required content checking, and always remove@@ -45,6 +55,9 @@    Setting this to "cpus" will run one job per CPU core. +  Note that when using --from with --to, twice this many jobs will+  run at once, evenly split between the two remotes.+ * `--all` `-A`    Rather than specifying a filename or path to move, this option can be@@ -67,12 +80,6 @@ * `--key=keyname`    Use this option to move a specified key.--* `--fast`--  When moving content to a remote, avoid a round trip to check if the remote-  already has content. This can be faster, but might skip moving content-  to the remote in some cases.  * matching options
doc/git-annex.mdwn view
@@ -487,6 +487,12 @@    See [[git-annex-inprogress]](1) for details. +* `findkeys`++  Similar to `git-annex find`, but operating on keys.++  See [[git-annex-findkeys]](1) for details.+ # METADATA COMMANDS  * `metadata [path ...]`@@ -1653,6 +1659,11 @@ * `remote.<name>.annex-glacier`    Used to identify Amazon Glacier special remotes.+  Normally this is automatically set up by `git annex initremote`.++* `remote.<name>.annex-web`++  Used to identify web special remotes.   Normally this is automatically set up by `git annex initremote`.  * `remote.<name>.annex-webdav`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20221212+Version: 10.20230126 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -67,6 +67,7 @@   doc/git-annex-export.mdwn   doc/git-annex-filter-branch.mdwn   doc/git-annex-find.mdwn+  doc/git-annex-findkeys.mdwn   doc/git-annex-findref.mdwn   doc/git-annex-fix.mdwn   doc/git-annex-forget.mdwn@@ -293,13 +294,13 @@   location: git://git-annex.branchable.com/  custom-setup-  Setup-Depends: base (>= 4.11.1.0), split, unix-compat, +  Setup-Depends: base (>= 4.11.1.0 && < 5.0), split, unix-compat,      filepath, exceptions, bytestring, IfElse, data-default,     filepath-bytestring (>= 1.4.2.1.4),     process (>= 1.6.3),     time (>= 1.5.0),     directory (>= 1.2.7.0),-    async, utf8-string, transformers, Cabal+    async, utf8-string, transformers, Cabal (< 4.0)  Executable git-annex   Main-Is: git-annex.hs@@ -727,6 +728,7 @@     Command.FilterBranch     Command.FilterProcess     Command.Find+    Command.FindKeys     Command.FindRef     Command.Fix     Command.Forget@@ -1007,6 +1009,7 @@     Types.DeferredParse     Types.DesktopNotify     Types.Difference+    Types.Direction     Types.Distribution     Types.Export     Types.FileMatcher