packages feed

git-annex 8.20210630 → 8.20210714

raw patch · 18 files changed

+146/−81 lines, 18 files

Files

Annex/Init.hs view
@@ -25,6 +25,7 @@ import qualified Git.Config import qualified Git.Objects import Git.Types (fromConfigValue)+import Git.ConfigTypes (SharedRepository(..)) import qualified Annex.Branch import Logs.UUID import Logs.Trust.Basic@@ -243,8 +244,8 @@ probeCrippledFileSystem :: Annex Bool probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do 	(r, warnings) <- probeCrippledFileSystem' tmp-		(Just freezeContent)-		(Just thawContent)+		(Just (freezeContent' UnShared))+		(Just (thawContent' UnShared)) 	mapM_ warning warnings 	return r
Annex/Perms.hs view
@@ -15,8 +15,10 @@ 	createWorkTreeDirectory, 	noUmask, 	freezeContent,+	freezeContent', 	isContentWritePermOk, 	thawContent,+	thawContent', 	createContentDir, 	freezeContentDir, 	thawContentDir,@@ -131,8 +133,12 @@  - owned by another user, so failure to set this mode is ignored.  -} freezeContent :: RawFilePath -> Annex ()-freezeContent file = unlessM crippledFileSystem $ do-	withShared go+freezeContent file = unlessM crippledFileSystem $+	withShared $ \sr -> freezeContent' sr file++freezeContent' :: SharedRepository -> RawFilePath -> Annex ()+freezeContent' sr file = do+	go sr 	freezeHook file   where 	go GroupShared = liftIO $ void $ tryIO $ modifyFileMode file $@@ -160,7 +166,10 @@ {- Allows writing to an annexed file that freezeContent was called on  - before. -} thawContent :: RawFilePath -> Annex ()-thawContent file = thawPerms (withShared go) (thawHook file)+thawContent file = withShared $ \sr -> thawContent' sr file++thawContent' :: SharedRepository -> RawFilePath -> Annex ()+thawContent' sr file = thawPerms (go sr) (thawHook file)   where 	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file 	go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
Annex/Url.hs view
@@ -73,6 +73,7 @@ 			<*> pure urldownloader 			<*> pure manager 			<*> (annexAllowedUrlSchemes <$> Annex.getGitConfig)+			<*> pure (Just (\u -> "Configuration of annex.security.allowed-url-schemes does not allow accessing " ++ show u)) 			<*> pure U.noBasicAuth 	 	headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case
Assistant/Threads/Committer.hs view
@@ -1,6 +1,6 @@ {- git-annex assistant commit thread  -- - Copyright 2012, 2019 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -33,6 +33,7 @@ import Annex.CatFile import Annex.InodeSentinal import Annex.CurrentBranch+import Annex.FileMatcher import qualified Annex import Utility.InodeCache import qualified Database.Keys@@ -52,6 +53,7 @@ 	havelsof <- liftIO $ inSearchPath "lsof" 	delayadd <- liftAnnex $ 		fmap Seconds . annexDelayAdd <$> Annex.getGitConfig+	largefilematcher <- liftAnnex largeFilesMatcher 	msg <- liftAnnex Command.Sync.commitMsg 	lockdowndir <- liftAnnex $ fromRepo gitAnnexTmpWatcherDir 	liftAnnex $ do@@ -61,7 +63,7 @@ 			(fromRawFilePath lockdowndir) 		void $ createAnnexDirectory lockdowndir 	waitChangeTime $ \(changes, time) -> do-		readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof delayadd $+		readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher delayadd $ 			simplifyChanges changes 		if shouldCommit False time (length readychanges) readychanges 			then do@@ -239,7 +241,7 @@ 			return ok  {- If there are PendingAddChanges, or InProcessAddChanges, the files- - have not yet actually been added to the annex, and that has to be done+ - have not yet actually been added, and that has to be done  - now, before committing.  -  - Deferring the adds to this point causes batches to be bundled together,@@ -257,8 +259,8 @@  - Any pending adds that are not ready yet are put back into the ChangeChan,  - where they will be retried later.  -}-handleAdds :: FilePath -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]-handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do+handleAdds :: FilePath -> Bool -> GetFileMatcher -> Maybe Seconds -> [Change] -> Assistant [Change]+handleAdds lockdowndir havelsof largefilematcher delayadd cs = returnWhen (null incomplete) $ do 	let (pending, inprocess) = partition isPendingAddChange incomplete 	let lockdownconfig = LockDownConfig 		{ lockingFile = False@@ -271,9 +273,12 @@ 		refillChanges postponed  	returnWhen (null toadd) $ do-		added <- addaction toadd $-			catMaybes <$> addunlocked toadd-		return $ added ++ otherchanges+		(toaddannexed, toaddsmall) <- partitionEithers+			<$> mapM checksmall toadd+		addsmall toaddsmall+		addedannexed <- addaction toadd $+			catMaybes <$> addannexed toaddannexed+		return $ addedannexed ++ toaddsmall ++ otherchanges   where 	(incomplete, otherchanges) = partition (\c -> isPendingAddChange c || isInProcessAddChange c) cs @@ -281,25 +286,24 @@ 		| c = return otherchanges 		| otherwise = a -	add :: LockDownConfig -> Change -> Assistant (Maybe Change)-	add lockdownconfig change@(InProcessAddChange { lockedDown = ld }) = -		catchDefaultIO Nothing <~> doadd-	  where-	  	ks = keySource ld-		doadd = sanitycheck ks $ do-			(mkey, _mcache) <- liftAnnex $ do-				showStart "add" (keyFilename ks) (SeekInput [])-				ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing-			maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey-	add _ _ = return Nothing+	checksmall change =+		ifM (liftAnnex $ checkFileMatcher largefilematcher (toRawFilePath (changeFile change)))+			( return (Left change)+			, return (Right change)+			) +	addsmall [] = noop+	addsmall toadd = liftAnnex $ Annex.Queue.addCommand [] "add"+		[ Param "--force", Param "--"] (map changeFile toadd)+ 	{- Avoid overhead of re-injesting a renamed unlocked file, by 	 - examining the other Changes to see if a removed file has the 	 - same InodeCache as the new file. If so, we can just update 	 - bookkeeping, and stage the file in git. 	 -}-	addunlocked :: [Change] -> Assistant [Maybe Change]-	addunlocked toadd = do+	addannexed :: [Change] -> Assistant [Maybe Change]+	addannexed [] = return []+	addannexed toadd = do 		ct <- liftAnnex compareInodeCachesWith 		m <- liftAnnex $ removedKeysMap ct cs 		delta <- liftAnnex getTSDelta@@ -308,15 +312,27 @@ 			, hardlinkFileTmpDir = Just (toRawFilePath lockdowndir) 			} 		if M.null m-			then forM toadd (add cfg)+			then forM toadd (addannexed' cfg) 			else forM toadd $ \c -> do 				mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta 				case mcache of-					Nothing -> add cfg c+					Nothing -> addannexed' cfg c 					Just cache -> 						case M.lookup (inodeCacheToKey ct cache) m of-							Nothing -> add cfg c+							Nothing -> addannexed' cfg c 							Just k -> fastadd c k++	addannexed' :: LockDownConfig -> Change -> Assistant (Maybe Change)+	addannexed' lockdownconfig change@(InProcessAddChange { lockedDown = ld }) = +		catchDefaultIO Nothing <~> doadd+	  where+	  	ks = keySource ld+		doadd = sanitycheck ks $ do+			(mkey, _mcache) <- liftAnnex $ do+				showStart "add" (keyFilename ks) (SeekInput [])+				ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing+			maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey+	addannexed' _ _ = return Nothing  	fastadd :: Change -> Key -> Assistant (Maybe Change) 	fastadd change key = do
Assistant/Threads/Cronner.hs view
@@ -185,7 +185,7 @@ 	g <- liftAnnex gitRepo 	fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do 		void $ batchCommand program (Param "fsck" : annexFsckParams d)-		Git.Fsck.findBroken True g+		Git.Fsck.findBroken True False g 	u <- liftAnnex getUUID 	void $ repairWhenNecessary urlrenderer u Nothing fsckresults 	mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)@@ -214,7 +214,7 @@ 		fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do 			void annexfscker 			if Git.repoIsLocal repo && not (Git.repoIsLocalUnknown repo)-				then Just <$> Git.Fsck.findBroken True repo+				then Just <$> Git.Fsck.findBroken True True repo 				else pure Nothing 		maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults
Assistant/Threads/ProblemFixer.hs view
@@ -60,7 +60,7 @@ 			( do 				fixedlocks <- repairStaleGitLocks repo 				fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $-					Git.Fsck.findBroken True repo+					Git.Fsck.findBroken True True repo 				repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults 				return $ fixedlocks || repaired 			, return False
Assistant/Threads/Watcher.hs view
@@ -34,7 +34,6 @@ import Annex.CatFile import Annex.CheckIgnore import Annex.Link-import Annex.FileMatcher import Annex.Content import Annex.ReplaceFile import Annex.InodeSentinal@@ -89,9 +88,8 @@ runWatcher :: Assistant () runWatcher = do 	startup <- asIO1 startupScan-	matcher <- liftAnnex largeFilesMatcher 	symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig-	addhook <- hook $ onAddUnlocked symlinkssupported matcher+	addhook <- hook $ onAddUnlocked symlinkssupported 	delhook <- hook onDel 	addsymlinkhook <- hook onAddSymlink 	deldirhook <- hook onDelDir@@ -193,24 +191,14 @@ 		| "./" `isPrefixOf` file = drop 2 f 		| otherwise = f -{- Small files are added to git as-is, while large ones go into the annex. -}-add :: GetFileMatcher -> FilePath -> Assistant (Maybe Change)-add largefilematcher file = ifM (liftAnnex $ checkFileMatcher largefilematcher (toRawFilePath file))-	( pendingAddChange file-	, do-		liftAnnex $ Annex.Queue.addCommand [] "add"-			[Param "--force", Param "--"] [file]-		madeChange file AddFileChange-	)- shouldRestage :: DaemonStatus -> Bool shouldRestage ds = scanComplete ds || forceRestage ds -onAddUnlocked :: Bool -> GetFileMatcher -> Handler-onAddUnlocked symlinkssupported matcher f fs = do+onAddUnlocked :: Bool -> Handler+onAddUnlocked symlinkssupported f fs = do 	mk <- liftIO $ isPointerFile $ toRawFilePath f 	case mk of-		Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs+		Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported f fs 		Just k -> addlink f k   where 	addassociatedfile key file = @@ -240,9 +228,8 @@ 	-> (FilePath -> Key -> Assistant (Maybe Change)) 	-> (Key -> FilePath -> FileStatus -> Annex Bool) 	-> Bool-	-> GetFileMatcher 	-> Handler-onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do+onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do 	v <- liftAnnex $ catKeyFile (toRawFilePath file) 	case (v, fs) of 		(Just key, Just filestatus) ->@@ -259,12 +246,12 @@ 				, guardSymlinkStandin (Just key) $ do 					debug ["changed", file] 					liftAnnex $ contentchanged key file-					add matcher file+					pendingAddChange file 				) 		_ -> unlessIgnored file $ 			guardSymlinkStandin Nothing $ do 				debug ["add", file]-				add matcher file+				pendingAddChange file   where 	{- On a filesystem without symlinks, we'll get changes for regular 	 - files that git uses to stand-in for symlinks. Detect when
Build/Configure.hs view
@@ -55,7 +55,7 @@ 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))+testCpReflinkAuto = TestCase k (return $ Config k (BoolConfig False)) #else testCpReflinkAuto = testCp k "--reflink=auto" #endif
CHANGELOG view
@@ -1,3 +1,19 @@+git-annex (8.20210714) upstream; urgency=medium++  * assistant: Avoid unncessary git repository repair in a situation where+    git fsck gets confused about a commit that is made while it's running.+  * addurl: Avoid crashing when used on beegfs.+  * --debug output goes to stderr again, not stdout.+    (Reversion in version 8.20210428)+  * init: Fix misbehavior when core.sharedRepository = group that+    caused it to enter an adjusted branch and set annex.crippledfilesystem+    (Reversion in version 8.20210630)+  * assistant: When adding non-large files to git, honor annex.delayadd+    configuration. Also, don't add non-large files to git when they+    are still being written to.++ -- Joey Hess <id@joeyh.name>  Wed, 14 Jul 2021 12:22:55 -0400+ git-annex (8.20210630) upstream; urgency=medium    * Fixed bug that interrupting git-annex repair (or assistant) while
Command/AddUrl.hs view
@@ -315,7 +315,7 @@ 	urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing 	downloader f p = Url.withUrlOptions $ downloadUrl urlkey p [url] f 	go Nothing = return Nothing-	go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtml <$> readFile (fromRawFilePath tmp)))+	go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtmlFile (fromRawFilePath tmp))) 		( tryyoutubedl tmp 		, normalfinish tmp 		)
Git/Fsck.hs view
@@ -1,4 +1,5 @@ {- git fsck interface+i it is not fully repoducibleI repeated the same steps  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -@@ -69,9 +70,17 @@  - look for anything in its output (both stdout and stderr) that appears  - to be a git sha. Not all such shas are of broken objects, so ask git  - to try to cat the object, and see if it fails.+ -+ - Note that there is a possible false positive: When changes are being+ - made to the repo while this is running, fsck might complain about a+ - missing object that has not made it to disk yet. Catting the object+ - then succeeds, so it's not included in the FsckResults. But, fsck then+ - exits nonzero, and so FsckFailed is returned. Set ignorenonzeroexit+ - to avoid this false positive, at the risk of perhaps missing a problem+ - so bad that fsck crashes without outputting any missing shas.  -}-findBroken :: Bool -> Repo -> IO FsckResults-findBroken batchmode r = do+findBroken :: Bool -> Bool -> Repo -> IO FsckResults+findBroken batchmode ignorenonzeroexit r = do 	let (command, params) = ("git", fsckParams r) 	(command', params') <- if batchmode 		then toBatchCommand (command, params)@@ -90,10 +99,10 @@ 		fsckok <- checkSuccessProcess pid 		case mappend o1 o2 of 			FsckOutput badobjs truncated-				| S.null badobjs && not fsckok -> return FsckFailed+				| S.null badobjs && not fsckok -> return fsckfailed 				| otherwise -> return $ FsckFoundMissing badobjs truncated 			NoFsckOutput-				| not fsckok -> return FsckFailed+				| not fsckok -> return fsckfailed 				| otherwise -> return noproblem 			-- If all fsck output was duplicateEntries warnings, 			-- the repository is not broken, it just has some@@ -104,6 +113,9 @@ 	 	maxobjs = 10000 	noproblem = FsckFoundMissing S.empty False+	fsckfailed+		| ignorenonzeroexit = noproblem+		| otherwise = FsckFailed  foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True
Git/Repair.hs view
@@ -476,7 +476,7 @@ runRepair removablebranch forced g = do 	preRepair g 	putStrLn "Running git fsck ..."-	fsckresult <- findBroken False g+	fsckresult <- findBroken False False g 	if foundBroken fsckresult 		then do 			putStrLn "Fsck found problems, attempting repair."@@ -500,7 +500,7 @@ runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepair' removablebranch fsckresult forced referencerepo g = do 	cleanCorruptObjects fsckresult g-	missing <- findBroken False g+	missing <- findBroken False False g 	stillmissing <- retrieveMissingObjects missing referencerepo g 	case stillmissing of 		FsckFoundMissing s t@@ -529,7 +529,7 @@ 			| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) 				( do 					cleanCorruptObjects FsckFailed g-					stillmissing' <- findBroken False g+					stillmissing' <- findBroken False False g 					case stillmissing' of 						FsckFailed -> return (False, []) 						FsckFoundMissing s t -> forcerepair s t@@ -575,7 +575,7 @@ 		-- the repair process. 		if fscktruncated 			then do-				fsckresult' <- findBroken False g+				fsckresult' <- findBroken False False g 				case fsckresult' of 					FsckFailed -> do 						putStrLn "git fsck is failing"@@ -597,7 +597,7 @@ 		removeWhenExistsWith R.removeLink (indexFile g) 		-- The corrupted index can prevent fsck from finding other 		-- problems, so re-run repair.-		fsckresult' <- findBroken False g+		fsckresult' <- findBroken False False g 		result <- runRepairOf fsckresult' removablebranch forced referencerepo g 		putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate." 		return result
Logs/FsckResults.hs view
@@ -22,14 +22,20 @@ writeFsckResults :: UUID -> FsckResults -> Annex () writeFsckResults u fsckresults = do 	logfile <- fromRepo $ gitAnnexFsckResultsLog u-	case fsckresults of-		FsckFailed -> store S.empty False logfile-		FsckFoundMissing s t-			| S.null s -> liftIO $-				removeWhenExistsWith R.removeLink logfile-			| otherwise -> store s t logfile+	case serializeFsckResults fsckresults of+		Just s -> store s logfile+		Nothing -> liftIO $+			removeWhenExistsWith R.removeLink logfile   where-	store s t logfile = writeLogFile logfile $ serialize s t+	store s logfile = writeLogFile logfile s++serializeFsckResults :: FsckResults -> Maybe String+serializeFsckResults fsckresults = case fsckresults of+	FsckFailed -> Just (serialize S.empty False)+	FsckFoundMissing s t+		| S.null s -> Nothing+		| otherwise -> Just (serialize s t)+  where 	serialize s t = 		let ls = map fromRef (S.toList s) 		in if t@@ -40,7 +46,10 @@ readFsckResults u = do 	logfile <- fromRepo $ gitAnnexFsckResultsLog u 	liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $-		deserialize . lines <$> readFile (fromRawFilePath logfile)+		deserializeFsckResults <$> readFile (fromRawFilePath logfile)++deserializeFsckResults :: String -> FsckResults+deserializeFsckResults = deserialize . lines   where 	deserialize ("truncated":ls) = deserialize' ls True 	deserialize ls = deserialize' ls False
Messages.hs view
@@ -270,7 +270,7 @@ 	-- that are displayed at the same time from mixing together. 	lock <- newMVar () 	return $ \s -> withMVar lock $ \() -> do-		S.putStr (s <> "\n")+		S.hPutStr stderr (s <> "\n") 		hFlush stderr  {- Should commands that normally output progress messages have that
Utility/HtmlDetect.hs view
@@ -1,6 +1,6 @@ {- html detection  -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017-2021 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -8,10 +8,12 @@ module Utility.HtmlDetect ( 	isHtml, 	isHtmlBs,+	isHtmlFile, 	htmlPrefixLength, ) where  import Text.HTML.TagSoup+import System.IO import Data.Char import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as B8@@ -43,6 +45,15 @@ -- The encoding of the ByteString is not known, but isHtml only -- looks for ascii strings. isHtmlBs = isHtml . B8.unpack++-- | Check if the file is html.+--+-- It would be equivilant to use isHtml <$> readFile file,+-- but since that would not read all of the file, the handle+-- would remain open until it got garbage collected sometime later.+isHtmlFile :: FilePath -> IO Bool+isHtmlFile file = withFile file ReadMode $ \h ->+	isHtmlBs <$> B.hGet h htmlPrefixLength  -- | How much of the beginning of a html document is needed to detect it. -- (conservatively)
Utility/Url.hs view
@@ -97,6 +97,7 @@ 	, applyRequest :: Request -> Request 	, httpManager :: Manager 	, allowedSchemes :: S.Set Scheme+	, disallowedSchemeMessage :: Maybe (URI -> String) 	, getBasicAuth :: GetBasicAuth 	} @@ -115,11 +116,12 @@ 	<*> pure id 	<*> newManager tlsManagerSettings 	<*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"])+	<*> pure Nothing 	<*> pure noBasicAuth -mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> GetBasicAuth -> UrlOptions-mkUrlOptions defuseragent reqheaders urldownloader manager getbasicauth =-	UrlOptions useragent reqheaders urldownloader applyrequest manager getbasicauth+mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> Maybe (URI -> String) -> GetBasicAuth -> UrlOptions+mkUrlOptions defuseragent reqheaders urldownloader =+	UrlOptions useragent reqheaders urldownloader applyrequest   where 	applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders } 	addedheaders = uaheader ++ otherheaders@@ -156,8 +158,9 @@ checkPolicy :: UrlOptions -> URI -> IO (Either String a) -> IO (Either String a) checkPolicy uo u a 	| allowedScheme uo u = a-	| otherwise = return $ Left $-		"Configuration does not allow accessing " ++ show u+	| otherwise = return $ Left $ case disallowedSchemeMessage uo of+		Nothing -> "Configuration does not allow accessing" ++ show u+		Just f -> f u  unsupportedUrlScheme :: URI -> String unsupportedUrlScheme u = "Unsupported url scheme " ++ show u
doc/git-annex.mdwn view
@@ -1765,8 +1765,8 @@   to close it.    Note that this only delays adding files created while the daemon is-  running. Changes made when it is not running will be added the next time-  it is started up.+  running. Changes made when it is not running will be added immediately+  the next time it is started up.  * `annex.expireunused`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20210630+Version: 8.20210714 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>