packages feed

git-annex 8.20210621 → 8.20210630

raw patch · 27 files changed

+277/−137 lines, 27 files

Files

Annex/Content.hs view
@@ -1,6 +1,6 @@ {- git-annex file content managing  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -36,6 +36,7 @@ 	linkOrCopy', 	sendAnnex, 	prepSendAnnex,+	prepSendAnnex', 	removeAnnex, 	moveBad, 	KeyLocation(..),@@ -446,14 +447,15 @@  - The rollback action should remove the data that was transferred.  -} sendAnnex :: Key -> Annex () -> (FilePath -> Annex a) -> Annex a-sendAnnex key rollback sendobject = go =<< prepSendAnnex key+sendAnnex key rollback sendobject = go =<< prepSendAnnex' key   where-	go (Just (f, checksuccess)) = do+	go (Just (f, check)) = do 		r <- sendobject f-		unlessM checksuccess $ do-			rollback-			giveup "content changed while it was being sent"-		return r+		check >>= \case+			Nothing -> return r+			Just err -> do+				rollback+				giveup err 	go Nothing = giveup "content not available to send"  {- Returns a file that contains an object's content,@@ -482,6 +484,16 @@ 	return $ if null cache' 		then Nothing 		else Just (fromRawFilePath f, sameInodeCache f cache')++prepSendAnnex' :: Key -> Annex (Maybe (FilePath, Annex (Maybe String)))+prepSendAnnex' key = prepSendAnnex key >>= \case+	Just (f, checksuccess) -> +		let checksuccess' = ifM checksuccess+			( return Nothing+			, return (Just "content changed while it was being sent")+			)+		in return (Just (f, checksuccess'))+	Nothing -> return Nothing  cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do
Annex/CopyFile.hs view
@@ -113,7 +113,9 @@ 			( case iv of 				Just x -> ifM (liftIO $ finalizeIncremental x) 					( return (True, Verified)-					, return (False, UnVerified)+					, do+						warning "verification of content failed"+						return (False, UnVerified) 					) 				Nothing -> return (True, UnVerified) 			, return (False, UnVerified)
Annex/Drop.hs view
@@ -10,7 +10,6 @@ module Annex.Drop where  import Annex.Common-import qualified Annex import Logs.Trust import Annex.NumCopies import Types.Remote (uuid, appendonly, config, remotetype, thirdPartyPopulated)@@ -119,10 +118,10 @@  	dropl fs n = checkdrop fs n Nothing $ \pcc numcopies mincopies -> 		stopUnless (inAnnex key) $-			Command.Drop.startLocal pcc afile ai si numcopies mincopies key preverified+			Command.Drop.startLocal pcc afile ai si numcopies mincopies key preverified (Command.Drop.DroppingUnused False)  	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \pcc numcopies mincopies ->-		Command.Drop.startRemote pcc afile ai si numcopies mincopies key r+		Command.Drop.startRemote pcc afile ai si numcopies mincopies key (Command.Drop.DroppingUnused False) r  	ai = mkActionItem (key, afile)
Annex/Init.hs view
@@ -1,6 +1,6 @@ {- git-annex repository initialization  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -51,14 +51,15 @@ import Utility.UserInfo import qualified Utility.RawFilePath as R import Utility.ThreadScheduler-#ifndef mingw32_HOST_OS import Annex.Perms+#ifndef mingw32_HOST_OS import Utility.FileMode import System.Posix.User import qualified Utility.LockFile.Posix as Posix #endif  import qualified Data.Map as M+import Control.Monad.IO.Class (MonadIO) #ifndef mingw32_HOST_OS import Data.Either import qualified System.FilePath.ByteString as P@@ -241,32 +242,40 @@  - or removing write access from files. -} probeCrippledFileSystem :: Annex Bool probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do-	(r, warnings) <- liftIO $ probeCrippledFileSystem' tmp+	(r, warnings) <- probeCrippledFileSystem' tmp+		(Just freezeContent)+		(Just thawContent) 	mapM_ warning warnings 	return r -probeCrippledFileSystem' :: RawFilePath -> IO (Bool, [String])+probeCrippledFileSystem'+	:: (MonadIO m, MonadCatch m)+	=> RawFilePath+	-> Maybe (RawFilePath -> m ())+	-> Maybe (RawFilePath -> m ())+	-> m (Bool, [String]) #ifdef mingw32_HOST_OS-probeCrippledFileSystem' _ = return (True, [])+probeCrippledFileSystem' _ _ _ = return (True, []) #else-probeCrippledFileSystem' tmp = do-	let f = fromRawFilePath (tmp P.</> "gaprobe")-	writeFile f ""-	r <- probe f-	void $ tryIO $ allowWrite (toRawFilePath f)-	removeFile f+probeCrippledFileSystem' tmp freezecontent thawcontent = do+	let f = tmp P.</> "gaprobe"+	let f' = fromRawFilePath f+	liftIO $ writeFile f' ""+	r <- probe f'+	void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f+	liftIO $ removeFile f' 	return r   where 	probe f = catchDefaultIO (True, []) $ do 		let f2 = f ++ "2"-		removeWhenExistsWith R.removeLink (toRawFilePath f2)-		createSymbolicLink f f2-		removeWhenExistsWith R.removeLink (toRawFilePath f2)-		preventWrite (toRawFilePath f)+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)+		liftIO $ createSymbolicLink f f2+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f2)+		(fromMaybe (liftIO . preventWrite) freezecontent) (toRawFilePath f) 		-- Should be unable to write to the file, unless 		-- running as root, but some crippled 		-- filesystems ignore write bit removals.-		ifM ((== 0) <$> getRealUserID)+		liftIO $ ifM ((== 0) <$> getRealUserID) 			( return (False, []) 			, do 				r <- catchBoolIO $ do@@ -283,7 +292,8 @@ 	warning "Detected a crippled filesystem." 	setCrippledFileSystem True -	{- Normally git disables core.symlinks itself when the+	{- Normally git disables core.symlinks itself when the:w+	 - 	 - filesystem does not support them. But, even if symlinks are 	 - supported, we don't use them by default in a crippled 	 - filesystem. -}
Annex/Perms.hs view
@@ -1,6 +1,6 @@ {- git-annex file permissions  -- - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,7 +17,6 @@ 	freezeContent, 	isContentWritePermOk, 	thawContent,-	chmodContent, 	createContentDir, 	freezeContentDir, 	thawContentDir,@@ -132,8 +131,9 @@  - owned by another user, so failure to set this mode is ignored.  -} freezeContent :: RawFilePath -> Annex ()-freezeContent file = unlessM crippledFileSystem $+freezeContent file = unlessM crippledFileSystem $ do 	withShared go+	freezeHook file   where 	go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $ 		addModes [ownerReadMode, groupReadMode, ownerWriteMode, groupWriteMode]@@ -157,22 +157,10 @@ 			Nothing -> True 			Just havemode -> havemode == combineModes (havemode:wantmode) -{- Adjusts read mode of annexed file per core.sharedRepository setting. -}-chmodContent :: RawFilePath -> Annex ()-chmodContent file = unlessM crippledFileSystem $-	withShared go-  where-	go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $-		addModes [ownerReadMode, groupReadMode]-	go AllShared = liftIO $ void $ tryIO $ modifyFileMode file $-		addModes readModes-	go _ = liftIO $ modifyFileMode file $-		addModes [ownerReadMode]- {- Allows writing to an annexed file that freezeContent was called on  - before. -} thawContent :: RawFilePath -> Annex ()-thawContent file = thawPerms $ withShared go+thawContent file = thawPerms (withShared go) (thawHook file)   where 	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file 	go AllShared = liftIO $ void $ tryIO $ groupWriteRead file@@ -180,11 +168,12 @@  {- Runs an action that thaws a file's permissions. This will probably  - fail on a crippled filesystem. But, if file modes are supported on a- - crippled filesystem, the file may be frozen, so try to thaw it. -}-thawPerms :: Annex () -> Annex ()-thawPerms a = ifM crippledFileSystem-	( void $ tryNonAsync a-	, a+ - crippled filesystem, the file may be frozen, so try to thaw its+ - permissions. -}+thawPerms :: Annex () -> Annex () -> Annex ()+thawPerms a hook = ifM crippledFileSystem+	( void (tryNonAsync a)+	, hook >> a 	)  {- Blocks writing to the directory an annexed file is in, to prevent the@@ -193,8 +182,9 @@  - file.  -} freezeContentDir :: RawFilePath -> Annex ()-freezeContentDir file = unlessM crippledFileSystem $+freezeContentDir file = unlessM crippledFileSystem $ do 	withShared go+	freezeHook dir   where 	dir = parentDir file 	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir@@ -202,8 +192,9 @@ 	go _ = liftIO $ preventWrite dir  thawContentDir :: RawFilePath -> Annex ()-thawContentDir file = -	thawPerms $ liftIO $ allowWrite $ parentDir file+thawContentDir file = thawPerms (liftIO $ allowWrite dir) (thawHook dir)+  where+	dir = parentDir file  {- Makes the directory tree to store an annexed file's content,  - with appropriate permissions on each level. -}@@ -212,7 +203,8 @@ 	unlessM (liftIO $ R.doesPathExist dir) $ 		createAnnexDirectory dir  	-- might have already existed with restricted perms-	unlessM crippledFileSystem $+	unlessM crippledFileSystem $ do+		thawHook dir 		liftIO $ allowWrite dir   where 	dir = parentDir dest@@ -226,3 +218,17 @@ 	v <- tryNonAsync a 	freezeContentDir f 	either throwM return v++freezeHook :: RawFilePath -> Annex ()+freezeHook p = maybe noop go =<< annexFreezeContentCommand <$> Annex.getGitConfig+  where+	go basecmd = void $ liftIO $+		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]+	gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ]++thawHook :: RawFilePath -> Annex ()+thawHook p = maybe noop go =<< annexThawContentCommand <$> Annex.getGitConfig+  where+	go basecmd = void $ liftIO $+		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]+	gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ]
Annex/Transfer.hs view
@@ -205,13 +205,8 @@ 				, return observeFailure 				) -	getbytescomplete metervar-		| transferDirection t == Upload =-			liftIO $ maybe 0 fromBytesProcessed -				<$> readTVarIO metervar-		| otherwise = do-			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)-			liftIO $ catchDefaultIO 0 $ getFileSize f+	getbytescomplete metervar = liftIO $+		maybe 0 fromBytesProcessed <$> readTVarIO metervar  detectStallsAndSuggestConfig :: Maybe StallDetection -> TVar (Maybe BytesProcessed) -> Annex a -> Annex a detectStallsAndSuggestConfig Nothing _ a = a
Annex/TransferrerPool.hs view
@@ -133,12 +133,8 @@ 	ifM (catchBoolIO $ bracket setup cleanup (go bpv)) 		( return (Right ()) 		, do-			n <- case transferDirection t of-				Upload -> liftIO $ atomically $ -					fromBytesProcessed <$> readTVar bpv-				Download -> do-					f <- runannex $ fromRepo $ gitAnnexTmpObjectLocation (transferKey t)-					liftIO $ catchDefaultIO 0 $ getFileSize f+			n <- liftIO $ atomically $+				fromBytesProcessed <$> readTVar bpv 			return $ Left $ info { bytesComplete = Just n } 		)   where
Build/Configure.hs view
@@ -1,6 +1,7 @@ {- Checks system configuration and generates Build/SysConfig and Build/Version. -}  {-# OPTIONS_GHC -fno-warn-tabs #-}+{-# LANGUAGE CPP #-}  module Build.Configure where @@ -23,7 +24,7 @@ 	, testCp "cp_a" "-a" 	, testCp "cp_p" "-p" 	, testCp "cp_preserve_timestamps" "--preserve=timestamps"-	, testCp "cp_reflink_supported" "--reflink=auto"+	, testCpReflinkAuto 	, TestCase "xargs -0" $ testCmd "xargs_0" "xargs -0 </dev/null" 	, TestCase "rsync" $ testCmd "rsync" "rsync --version >/dev/null" 	, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null"@@ -50,6 +51,16 @@   where 	cmd = "cp " ++ option 	cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new"++testCpReflinkAuto :: TestCase+#ifdef mingw32_HOST_OS+-- Windows does not support reflink so don't even try to use the option.+testCpReflinkAuto = TestCase k (Config k (BoolConfig False))+#else+testCpReflinkAuto = testCp k "--reflink=auto"+#endif+  where+	k = "cp_reflink_supported"  getUpgradeLocation :: Test getUpgradeLocation = do
CHANGELOG view
@@ -1,3 +1,27 @@+git-annex (8.20210630) upstream; urgency=medium++  * Fixed bug that interrupting git-annex repair (or assistant) while+    it was fixing repository corruption would lose objects that were+    contained in pack files. Also the assistant might sometimes have+    crashed with the same result.+  * repair: Fix reversion in version 8.20200522 that prevented fetching+    missing objects from remotes.+  * sync: Partly work around github behavior that first branch to be pushed+    to a new repository is assumed to be the head branch, by not pushing+    synced/git-annex first.+  * Added annex.freezecontent-command and annex.thawcontent-command+    configs.+  * Improve display of errors when transfers fail.+  * Dropping an unused object with drop --unused or dropunused will+    mark it as dead, preventing fsck --all from complaining about it+    after it's been dropped from all repositories.+  * addurl, importfeed: Added --no-raw option that forces download+    with youtube-dl or a special remote. In particular this can avoid+    falling back to raw download when youtube-dl is blocked for some+    reason.++ -- Joey Hess <id@joeyh.name>  Wed, 30 Jun 2021 11:48:16 -0400+ git-annex (8.20210621) upstream; urgency=medium    * New matching options --excludesamecontent and --includesamecontent
Command/AddUrl.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -54,6 +54,7 @@ data DownloadOptions = DownloadOptions 	{ relaxedOption :: Bool 	, rawOption :: Bool+	, noRawOption :: Bool 	, fileOption :: Maybe FilePath 	, preserveFilenameOption :: Bool 	, checkGitIgnoreOption :: CheckGitIgnore@@ -91,6 +92,10 @@ 		( long "raw" 		<> help "disable special handling for torrents, youtube-dl, etc" 		)+	<*> switch+		( long "no-raw"+		<> help "prevent downloading raw url content, must use special handling"+		) 	<*> (if withfileoptions 		then optional (strOption 			( long "file" <> metavar paramFile@@ -265,7 +270,7 @@ 	addurl = addUrlChecked o url file webUUID $ \k -> 		ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url) 			( return (True, True, setDownloader url YoutubeDownloader)-			, return (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url)+			, checkRaw (downloadOptions o) $ return (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url) 			)  {- Check that the url exists, and has the same size as the key,@@ -326,7 +331,7 @@ 			in ifAnnexed f 				(alreadyannexed (fromRawFilePath f)) 				(dl f)-		Left _ -> normalfinish tmp+		Left _ -> checkRaw o (normalfinish tmp) 	  where 		dl dest = withTmpWorkDir mediakey $ \workdir -> do 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)@@ -340,7 +345,7 @@ 								showDestinationFile (fromRawFilePath dest) 								addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile)) 								return $ Just mediakey-						Right Nothing -> normalfinish tmp+						Right Nothing -> checkRaw o (normalfinish tmp) 						Left msg -> do 							cleanuptmp 							warning msg@@ -356,6 +361,11 @@ 				else do 					warning $ dest ++ " already exists; not overwriting" 					return Nothing+	+checkRaw :: DownloadOptions -> Annex a -> Annex a+checkRaw o a+	| noRawOption o = giveup "Unable to use youtube-dl or a special remote and --no-raw was specified."+	| otherwise = a  {- The destination file is not known at start time unless the user provided  - a filename. It's not displayed then for output consistency, @@ -464,8 +474,9 @@ nodownloadWeb addunlockedmatcher o url urlinfo file 	| Url.urlExists urlinfo = if rawOption o 		then nomedia-		else either (const nomedia) (usemedia . toRawFilePath)-			=<< youtubeDlFileName url+		else youtubeDlFileName url >>= \case+			Right mediafile -> usemedia (toRawFilePath mediafile)+			Left _ -> checkRaw o nomedia 	| otherwise = do 		warning $ "unable to access url: " ++ url 		return Nothing
Command/Drop.hs view
@@ -86,29 +86,32 @@ 	checkDropAuto (autoMode o) from afile key $ \numcopies mincopies -> 		stopUnless wantdrop $ 			case from of-				Nothing -> startLocal pcc afile ai si numcopies mincopies key []-				Just remote -> startRemote pcc afile ai si numcopies mincopies key remote+				Nothing -> startLocal pcc afile ai si numcopies mincopies key [] ud+				Just remote -> startRemote pcc afile ai si numcopies mincopies key ud remote   where 	wantdrop 		| autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile Nothing 		| otherwise = return True 	pcc = PreferredContentChecked (autoMode o)+	ud = case (batchOption o, keyOptions o) of+		(NoBatch, Just WantUnusedKeys) -> DroppingUnused True+		_ -> DroppingUnused False  startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si -startLocal :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> CommandStart-startLocal pcc afile ai si numcopies mincopies key preverified =+startLocal :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> DroppingUnused -> CommandStart+startLocal pcc afile ai si numcopies mincopies key preverified ud = 	starting "drop" (OnlyActionOn key ai) si $-		performLocal pcc key afile numcopies mincopies preverified+		performLocal pcc key afile numcopies mincopies preverified ud -startRemote :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> Remote -> CommandStart-startRemote pcc afile ai si numcopies mincopies key remote = +startRemote :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> DroppingUnused -> Remote -> CommandStart+startRemote pcc afile ai si numcopies mincopies key ud remote =  	starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) si $-		performRemote pcc key afile numcopies mincopies remote+		performRemote pcc key afile numcopies mincopies remote ud -performLocal :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> CommandPerform-performLocal pcc key afile numcopies mincopies preverified = lockContentForRemoval key fallback $ \contentlock -> do+performLocal :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> DroppingUnused -> CommandPerform+performLocal pcc key afile numcopies mincopies preverified ud = lockContentForRemoval key fallback $ \contentlock -> do 	u <- getUUID 	(tocheck, verified) <- verifiableCopies key [u] 	doDrop pcc u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck@@ -120,7 +123,7 @@ 				] 			removeAnnex contentlock 			notifyDrop afile True-			next $ cleanupLocal key+			next $ cleanupLocal key ud 		, do  			notifyDrop afile False 			stop@@ -131,10 +134,10 @@ 	-- is present, but due to buffering, may find it present for the 	-- second file before the first is dropped. If so, nothing remains 	-- to be done except for cleaning up.-	fallback = next $ cleanupLocal key+	fallback = next $ cleanupLocal key ud -performRemote :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> CommandPerform-performRemote pcc key afile numcopies mincopies remote = do+performRemote :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> DroppingUnused -> CommandPerform+performRemote pcc key afile numcopies mincopies remote ud = do 	-- Filter the uuid it's being dropped from out of the lists of 	-- places assumed to have the key, and places to check. 	(tocheck, verified) <- verifiableCopies key [uuid]@@ -147,22 +150,35 @@ 				, show proof 				] 			ok <- Remote.action (Remote.removeKey remote key)-			next $ cleanupRemote key remote ok+			next $ cleanupRemote key remote ud ok 		, stop 		)   where 	uuid = Remote.uuid remote -cleanupLocal :: Key -> CommandCleanup-cleanupLocal key = do-	logStatus key InfoMissing+cleanupLocal :: Key -> DroppingUnused -> CommandCleanup+cleanupLocal key ud = do+	logStatus key (dropStatus ud) 	return True -cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup-cleanupRemote key remote ok = do+cleanupRemote :: Key -> Remote -> DroppingUnused -> Bool -> CommandCleanup+cleanupRemote key remote ud ok = do 	when ok $-		Remote.logStatus remote key InfoMissing+		Remote.logStatus remote key (dropStatus ud) 	return ok++{- Set when the user explicitly chose to operate on unused content.+ - Presumably the user still expects the last git-annex unused to be+ - correct at this point. -}+newtype DroppingUnused = DroppingUnused Bool++{- When explicitly dropping unused content, mark the key as dead, at least+ - in the repository it was dropped from. It may still be in other+ - repositories, and will not be treated as dead until dropped from all of+ - them. -}+dropStatus :: DroppingUnused -> LogStatus+dropStatus (DroppingUnused False) = InfoMissing+dropStatus (DroppingUnused True) = InfoDead  {- Before running the dropaction, checks specified remotes to  - verify that enough copies of a key exist to allow it to be
Command/DropUnused.hs view
@@ -49,7 +49,7 @@ perform from numcopies mincopies key = case from of 	Just r -> do 		showAction $ "from " ++ Remote.name r-		Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r+		Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r ud 	Nothing -> ifM (inAnnex key) 		( droplocal 		, ifM (objectFileExists key)@@ -63,8 +63,9 @@ 			) 		)   where-	droplocal = Command.Drop.performLocal pcc key (AssociatedFile Nothing) numcopies mincopies []+	droplocal = Command.Drop.performLocal pcc key (AssociatedFile Nothing) numcopies mincopies [] ud 	pcc = Command.Drop.PreferredContentChecked False+	ud = Command.Drop.DroppingUnused True  performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform performOther filespec key = do
Command/ImportFeed.hs view
@@ -42,7 +42,7 @@ import Logs.MetaData import Annex.MetaData import Annex.FileMatcher-import Command.AddUrl (addWorkTree)+import Command.AddUrl (addWorkTree, checkRaw) import Annex.UntrustedFilePath import qualified Annex.Branch import Logs@@ -185,7 +185,7 @@ 			let f' = fromRawFilePath f 			r <- Remote.claimingUrl url 			if Remote.uuid r == webUUID || rawOption (downloadOptions opts)-				then do+				then checkRaw (downloadOptions opts) $ do 					let dlopts = (downloadOptions opts) 						-- force using the filename 						-- chosen here@@ -326,8 +326,9 @@ 			, downloadlink 			) 	  where-		downloadlink = performDownload addunlockedmatcher opts cache todownload-			{ location = Enclosure linkurl }+		downloadlink = checkRaw (downloadOptions opts) $+			performDownload addunlockedmatcher opts cache todownload+				{ location = Enclosure linkurl }  	addmediafast linkurl mediaurl mediakey = 		ifM (pure (not (rawOption (downloadOptions opts)))
Command/Mirror.hs view
@@ -69,7 +69,8 @@ 		( Command.Move.toStart Command.Move.RemoveNever afile key ai si =<< getParsed r 		, do 			(numcopies, mincopies) <- getSafestNumMinCopies afile key-			Command.Drop.startRemote pcc afile ai si numcopies mincopies key =<< getParsed r+			Command.Drop.startRemote pcc afile ai si numcopies mincopies key (Command.Drop.DroppingUnused False)+				=<< getParsed r 		) 	FromRemote r -> checkFailedTransferDirection ai Download $ do 		haskey <- flip Remote.hasKey key =<< getParsed r@@ -82,7 +83,7 @@ 			Right False -> ifM (inAnnex key) 				( do 					(numcopies, mincopies) <- getSafestNumMinCopies afile key-					Command.Drop.startLocal pcc afile ai si numcopies mincopies key []+					Command.Drop.startLocal pcc afile ai si numcopies mincopies key [] (Command.Drop.DroppingUnused False) 				, stop 				)   where
Command/Move.hs view
@@ -186,7 +186,7 @@ 		removeAnnex contentlock 		next $ do 			() <- setpresentremote-			Command.Drop.cleanupLocal key+			Command.Drop.cleanupLocal key (Command.Drop.DroppingUnused False) 	faileddrophere setpresentremote = do 		showLongNote "(Use --force to override this check, or adjust numcopies.)" 		showLongNote "Content not dropped from here."@@ -199,7 +199,7 @@ 	-- is present, but due to buffering, may find it present for the 	-- second file before the first is dropped. If so, nothing remains 	-- to be done except for cleaning up.-	lockfailed = next $ Command.Drop.cleanupLocal key+	lockfailed = next $ Command.Drop.cleanupLocal key (Command.Drop.DroppingUnused False)  fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart fromStart removewhen afile key ai si src = @@ -262,7 +262,7 @@ 			, "(" ++ reason ++ ")" 			] 		ok <- Remote.action (Remote.removeKey src key)-		next $ Command.Drop.cleanupRemote key src ok+		next $ Command.Drop.cleanupRemote key src (Command.Drop.DroppingUnused False) ok 	 	faileddropremote = do 		showLongNote "(Use --force to override this check, or adjust numcopies.)"
Command/Sync.hs view
@@ -604,8 +604,15 @@  - direct push is tried, with stderr discarded, to update the branch ref  - on the remote.  -- - The sync push forces the update of the remote synced/git-annex branch.- - This is necessary if a transition has rewritten the git-annex branch.+ - The sync push first sends the synced/master branch,+ - and then forces the update of the remote synced/git-annex branch.+ -+ - Since some providers like github may treat the first branch sent+ - as the default branch, it's better to make that be synced/master than+ - synced/git-annex. (Although neither is ideal, it's the best that+ - can be managed given the constraints on order.)+ -+ - The forcing is necessary if a transition has rewritten the git-annex branch.  - Normally any changes to the git-annex branch get pulled and merged before  - this push, so this forcing is unlikely to overwrite new data pushed  - in from another repository that is also syncing.@@ -618,8 +625,8 @@ pushBranch remote mbranch g = directpush `after` annexpush `after` syncpush   where 	syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes-		[ Just $ Git.Branch.forcePush $ refspec Annex.Branch.name-		, (refspec . fromAdjustedBranch) <$> mbranch+		[ (refspec . fromAdjustedBranch) <$> mbranch+		, Just $ Git.Branch.forcePush $ refspec Annex.Branch.name 		] 	annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams 		[ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ]
Git/Repair.hs view
@@ -1,6 +1,6 @@ {- git repository recovery  -- - Copyright 2013-2014 Joey Hess <id@joeyh.name>+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -29,6 +29,7 @@ import Git.Types import Git.Fsck import Git.Index+import Git.Env import qualified Git.Config as Config import qualified Git.Construct as Construct import qualified Git.LsTree as LsTree@@ -61,15 +62,14 @@ 		whenM (isMissing s r) $ 			removeLoose s -{- Explodes all pack files, and deletes them.- -- - First moves all pack files to a temp dir, before unpacking them each in- - turn.+{- Explodes all pack files to loose objects, and deletes the pack files.  -- - This is because unpack-objects will not unpack a pack file if it's in the- - git repo.+ - git unpack-objects will not unpack objects from a pack file that are+ - in the git repo. So, GIT_OBJECT_DIRECTORY is pointed to a temporary+ - directory, and the loose objects then are moved into place, before+ - deleting the pack files.  -- - Also, this prevents unpack-objects from possibly looking at corrupt+ - Also, that prevents unpack-objects from possibly looking at corrupt  - pack files to see if they contain an object, while unpacking a  - non-corrupt pack file.  -}@@ -78,18 +78,28 @@   where 	go [] = return False 	go packs = withTmpDir "packs" $ \tmpdir -> do+		r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir 		putStrLn "Unpacking all pack files." 		forM_ packs $ \packfile -> do-			moveFile packfile (tmpdir </> takeFileName packfile)-			removeWhenExistsWith R.removeLink-				(packIdxFile (toRawFilePath packfile))-		forM_ packs $ \packfile -> do-			let tmp = tmpdir </> takeFileName packfile-			allowRead (toRawFilePath tmp)+			-- Just in case permissions are messed up.+			allowRead (toRawFilePath packfile) 			-- May fail, if pack file is corrupt. 			void $ tryIO $-				pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->-				L.hPut h =<< L.readFile tmp+				pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->+				L.hPut h =<< L.readFile packfile+		objs <- dirContentsRecursive tmpdir+		forM_ objs $ \objfile -> do+			f <- relPathDirToFile+				(toRawFilePath tmpdir)+				(toRawFilePath objfile)+			let dest = objectsDir r P.</> f+			createDirectoryIfMissing True+				(fromRawFilePath (parentDir dest))+			moveFile objfile (fromRawFilePath dest)+		forM_ packs $ \packfile -> do+			let f = toRawFilePath packfile+			removeWhenExistsWith R.removeLink f+			removeWhenExistsWith R.removeLink (packIdxFile f) 		return True  {- Try to retrieve a set of missing objects, from the remotes of a@@ -106,6 +116,9 @@ 		unlessM (boolSystem "git" [Param "init", File tmpdir]) $ 			error $ "failed to create temp repository in " ++ tmpdir 		tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)+		let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config")+		whenM (doesFileExist (repoconfig r)) $+			L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr) 		rs <- Construct.fromRemotes r 		stillmissing <- pullremotes tmpr rs fetchrefstags missing 		if S.null (knownMissing stillmissing)
Messages/Serialized.hs view
@@ -32,7 +32,7 @@ 	-> (SerializedOutputResponse -> m ()) 	-- ^ Send response to child process. 	-> (Maybe BytesProcessed -> m ())-	-- ^ When a progress meter is running, is updated with+	-- ^ When a progress meter is running, it is updated with 	-- progress meter values sent by the process. 	-- When a progress meter is stopped, Nothing is sent. 	-> (forall a. Annex a -> m a)
Remote/Git.hs view
@@ -549,8 +549,11 @@ 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote-		onLocalFast st $ Annex.Content.prepSendAnnex key >>= \case-			Just (object, checksuccess) -> do+		onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case+			Just (object, check) -> do+				let checksuccess = check >>= \case+					Just err -> giveup err+					Nothing -> return True 				let verify = Annex.Content.RemoteVerify r 				copier <- mkFileCopier hardlink st 				(ok, v) <- runTransfer (Transfer Download u (fromKey id key))@@ -673,7 +676,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate 	| not $ Git.repoIsUrl repo = ifM duc 		( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $-			copylocal =<< Annex.Content.prepSendAnnex key+			copylocal =<< Annex.Content.prepSendAnnex' key 		, giveup "remote does not have expected annex.uuid value" 		) 	| Git.repoIsSsh repo = commitOnCleanup repo r st $@@ -684,11 +687,11 @@ 	| otherwise = giveup "copying to non-ssh repo not supported"   where 	copylocal Nothing = giveup "content not available"-	copylocal (Just (object, checksuccess)) = do-		-- The checksuccess action is going to be run in+	copylocal (Just (object, check)) = do+		-- The check action is going to be run in 		-- the remote's Annex, but it needs access to the local 		-- Annex monad's state.-		checksuccessio <- Annex.withCurrentState checksuccess+		checkio <- Annex.withCurrentState check 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote@@ -698,9 +701,12 @@ 				let verify = Annex.Content.RemoteVerify r 				copier <- mkFileCopier hardlink st 				let rsp = RetrievalAllKeysSecure+				let checksuccess = liftIO checkio >>= \case+					Just err -> giveup err+					Nothing -> return True 				res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> 					metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> -						copier object (fromRawFilePath dest) key p' (liftIO checksuccessio) verify+						copier object (fromRawFilePath dest) key p' checksuccess verify 				Annex.Content.saveState True 				return res 			)
Test.hs view
@@ -142,7 +142,9 @@ 		exitWith exitcode 	runsubprocesstests (Just _) = isolateGitConfig $ do 		ensuretmpdir-		crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' (toRawFilePath tmpdir)+		crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'+			(toRawFilePath tmpdir)+			Nothing Nothing 		adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported 		case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of 			Nothing -> error "No tests found!?"
Types/GitConfig.hs view
@@ -104,6 +104,8 @@ 	, annexFsckNudge :: Bool 	, annexAutoUpgrade :: AutoUpgrade 	, annexExpireUnused :: Maybe (Maybe Duration)+	, annexFreezeContentCommand :: Maybe String+	, annexThawContentCommand :: Maybe String 	, annexSecureEraseCommand :: Maybe String 	, annexGenMetaData :: Bool 	, annexListen :: Maybe String@@ -191,6 +193,8 @@ 		getmaybe (annexConfig "autoupgrade") 	, annexExpireUnused = either (const Nothing) Just . parseDuration 		<$> getmaybe (annexConfig "expireunused")+	, annexFreezeContentCommand = getmaybe (annexConfig "freezecontent-command")+	, annexThawContentCommand = getmaybe (annexConfig "thawcontent-command") 	, annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command") 	, annexGenMetaData = getbool (annexConfig "genmetadata") False 	, annexListen = getmaybe (annexConfig "listen")
doc/git-annex-addurl.mdwn view
@@ -49,6 +49,12 @@   special remotes. This will for example, make addurl   download the .torrent file and not the contents it points to. +* `--no-raw`++  Require content pointed to by the url to be downloaded using youtube-dl+  or a special remote, rather than the raw content of the url. if that+  cannot be done, the add will fail.+ * `--file=name`    Use with a filename that does not yet exist to add a new file
doc/git-annex-dead.mdwn view
@@ -18,7 +18,7 @@  When a key is specified, indicates that the content of that key has been irretrievably lost. This prevents commands like `git annex fsck --all`-from complaining about it; `--all` will not operate on the key anymore.+from complaining about it.  (To undo, add the key's content back to the repository,  by using eg, `git-annex reinject`.)
doc/git-annex-dropunused.mdwn view
@@ -9,7 +9,7 @@ # DESCRIPTION  Drops the data corresponding to the numbers, as listed by the last-git annex unused`+`git annex unused`  You can also specify ranges of numbers, such as "1-1000". Or, specify "all" to drop all unused data.
doc/git-annex-importfeed.mdwn view
@@ -58,6 +58,13 @@   special remotes. This will for example, make importfeed   download a .torrent file and not the contents it points to. +* `--no-raw`++  Require content pointed to by the url to be downloaded using youtube-dl+  or a special remote, rather than the raw content of the url. if that+  cannot be done, the import will fail, and the next import of the feed+  will retry.+ * `--template`    Controls where the files are stored.
doc/git-annex.mdwn view
@@ -1213,6 +1213,16 @@    For example, to use the wipe command, set it to `wipe -f %file`. +* `annex.freezecontent-command`, `annex.thawcontent-command`++  Usually the write permission bits are unset to protect annexed objects+  from being modified or deleted. The freezecontent-command is run after+  git-annex has removed the write bit. The thawcontent-command should undo+  its effect, and is run before git-annex restores the write bit.++  In the command line, %path is replaced with the file or directory to+  operate on.+ * `annex.tune.objecthash1`, `annex.tune.objecthashlower`, `annex.tune.branchhash1`    These can be passed to `git annex init` to tune the repository.
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20210621+Version: 8.20210630 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>