packages feed

git-annex 10.20230214 → 10.20230227

raw patch · 13 files changed

+127/−79 lines, 13 files

Files

Annex/View.hs view
@@ -489,8 +489,8 @@ 		getmetadata gc mdfeeder mdcloser ts  	process uh mdreader = liftIO mdreader >>= \case-		Just ((topf, _, _, Just k), Just mdlog) -> do-			let metadata = parseCurrentMetaData mdlog+		Just ((topf, _, _, Just k), mdlog) -> do+			let metadata = maybe emptyMetaData parseCurrentMetaData mdlog 			let f = fromRawFilePath $ getTopFilePath topf 			let metadata' = getfilemetadata f `unionMetaData` metadata 			forM_ (genviewedfiles f metadata') $ \fv -> do
Assistant/MakeRepo.hs view
@@ -57,7 +57,7 @@ 	initRepo' desc mgroup 	{- Initialize the master branch, so things that expect 	 - to have it will work, before any files are added. -}-	unlessM (Git.Config.isBare <$> gitRepo) $ do+	unlessM (fromMaybe False . Git.Config.isBare <$> gitRepo) $ do 		cmode <- annexCommitMode <$> Annex.getGitConfig 		void $ inRepo $ Git.Branch.commitCommand cmode 			(Git.Branch.CommitQuiet True)
CHANGELOG view
@@ -1,3 +1,18 @@+git-annex (10.20230227) upstream; urgency=medium++  * Fix more breakage caused by git's fix for CVE-2022-24765, this time+    involving a remote that is a local bare repository not owned by the+    current user.+  * info: Fix reversion in last release involving handling of unsupported+    input by continuing to handle any other inputs, before exiting nonzero+    at the end.+  * git-annex.cabal: Move webapp build deps under the Assistant build flag+    so git-annex can be built again without yesod etc installed.+  * Improve error message when unable to read a sqlite database due to+    permissions problem.++ -- Joey Hess <id@joeyh.name>  Mon, 27 Feb 2023 12:23:12 -0400+ git-annex (10.20230214) upstream; urgency=medium    * sync: Fix a bug that caused files to be removed from an
Command/Info.hs view
@@ -182,7 +182,9 @@ noInfo :: String -> SeekInput -> String -> Annex () noInfo s si msg = do 	showStart "info" (encodeBS s) si-	giveup msg+	showNote msg+	showEndFail+	Annex.incError  dirInfo :: InfoOptions -> FilePath -> SeekInput -> Annex () dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do
Database/Handle.hs view
@@ -1,6 +1,6 @@ {- Persistent sqlite database handles.  -- - Copyright 2015-2022 Joey Hess <id@joeyh.name>+ - Copyright 2015-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -38,8 +38,9 @@ import System.IO  {- A DbHandle is a reference to a worker thread that communicates with- - the database. It has a MVar which Jobs are submitted to. -}-data DbHandle = DbHandle RawFilePath (Async ()) (MVar Job)+ - the database. It has a MVar which Jobs are submitted to. + - There is also an MVar which it will fill when there is a fatal error-}+data DbHandle = DbHandle RawFilePath (Async ()) (MVar Job) (MVar String)  {- Name of a table that should exist once the database is initialized. -} type TableName = String@@ -49,17 +50,18 @@ openDb :: RawFilePath -> TableName -> IO DbHandle openDb db tablename = do 	jobs <- newEmptyMVar-	worker <- async (workerThread db tablename jobs)+	errvar <- newEmptyMVar+	worker <- async (workerThread db tablename jobs errvar) 	 	-- work around https://github.com/yesodweb/persistent/issues/474 	liftIO $ fileEncoding stderr -	return $ DbHandle db worker jobs+	return $ DbHandle db worker jobs errvar  {- This is optional; when the DbHandle gets garbage collected it will  - auto-close. -} closeDb :: DbHandle -> IO ()-closeDb (DbHandle _db worker jobs) = do+closeDb (DbHandle _db worker jobs _) = do 	debugLocks $ putMVar jobs CloseJob 	wait worker @@ -74,12 +76,15 @@  - it is able to run.  -} queryDb :: DbHandle -> SqlPersistM a -> IO a-queryDb (DbHandle _db _ jobs) a = do+queryDb (DbHandle _db _ jobs errvar) a = do 	res <- newEmptyMVar 	putMVar jobs $ QueryJob $ 		debugLocks $ liftIO . putMVar res =<< tryNonAsync a-	debugLocks $ (either throwIO return =<< takeMVar res)-		`catchNonAsync` (\e -> error $ "sqlite query crashed: " ++ show e)+	debugLocks $ takeMVarSafe res >>= \case+		Right r -> either throwIO return r+		Left BlockedIndefinitelyOnMVar -> do+			err <- takeMVar errvar+			error $ "sqlite worker thread crashed: " ++ err  {- Writes a change to the database.  -@@ -91,7 +96,7 @@  - process at least once each 30 seconds.  -} commitDb :: DbHandle -> SqlPersistM () -> IO ()-commitDb h@(DbHandle db _ _) wa = +commitDb h@(DbHandle db _ _ _) wa =  	robustly (commitDb' h wa) maxretries emptyDatabaseInodeCache   where 	robustly a retries ic = do@@ -108,7 +113,7 @@ 	maxretries = 300 :: Int -- 30 seconds of briefdelay  commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())-commitDb' (DbHandle _ _ jobs) a = do+commitDb' (DbHandle _ _ jobs _) a = do 	debug "Database.Handle" "commitDb start" 	res <- newEmptyMVar 	putMVar jobs $ ChangeJob $@@ -125,18 +130,17 @@ 	| ChangeJob (SqlPersistM ()) 	| CloseJob -workerThread :: RawFilePath -> TableName -> MVar Job -> IO ()-workerThread db tablename jobs = newconn+workerThread :: RawFilePath -> TableName -> MVar Job -> MVar String -> IO ()+workerThread db tablename jobs errvar = newconn   where 	newconn = do 		v <- tryNonAsync (runSqliteRobustly tablename db loop) 		case v of-			Left e -> giveup $-				"sqlite worker thread crashed: " ++ show e+			Left e -> putMVar errvar (show e) 			Right cont -> cont 	 	loop = do-		job <- liftIO getjob+		job <- liftIO (takeMVarSafe jobs) 		case job of 			-- Exception is thrown when the MVar is garbage 			-- collected, which means the whole DbHandle@@ -149,9 +153,6 @@ 				-- Exit the sqlite connection so the 				-- database gets updated on disk. 				return newconn-	-	getjob :: IO (Either BlockedIndefinitelyOnMVar Job)-	getjob = try $ takeMVar jobs  {- Like runSqlite, but more robust.  -@@ -325,3 +326,7 @@ 	ismodified (Just a) (Just b) = not (compareStrong a b) 	ismodified Nothing Nothing = False 	ismodified _ _ = True++takeMVarSafe :: MVar a -> IO (Either BlockedIndefinitelyOnMVar a)+takeMVarSafe = try . takeMVar+
Database/Keys.hs view
@@ -52,7 +52,7 @@ import Git.CatFile import Git.Branch (writeTreeQuiet, update') import qualified Git.Ref-import qualified Git.Config+import Config import Config.Smudge import qualified Utility.RawFilePath as R @@ -176,7 +176,7 @@  - in a bare repository, but it might happen if a non-bare repo got  - converted to bare. -} emptyWhenBare :: Annex [a] -> Annex [a]-emptyWhenBare a = ifM (Git.Config.isBare <$> gitRepo)+emptyWhenBare a = ifM isBareRepo 	( return [] 	, a 	)@@ -261,7 +261,7 @@  - is an associated file.  -} reconcileStaged :: Bool -> H.DbQueue -> Annex DbTablesChanged-reconcileStaged dbisnew qh = ifM (Git.Config.isBare <$> gitRepo)+reconcileStaged dbisnew qh = ifM isBareRepo 	( return mempty 	, do 		gitindex <- inRepo currentIndexFile
Git/Config.hs view
@@ -133,14 +133,28 @@  - based on the core.bare and core.worktree settings.  -} updateLocation :: Repo -> IO Repo-updateLocation r@(Repo { location = LocalUnknown d })-	| isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit))-			( updateLocation' r $ Local dotgit Nothing-			, updateLocation' r $ Local d Nothing-			)-	| otherwise = updateLocation' r $ Local dotgit (Just d)+updateLocation r@(Repo { location = LocalUnknown d }) = case isBare r of+	Just True -> ifM (doesDirectoryExist (fromRawFilePath dotgit))+		( updateLocation' r $ Local dotgit Nothing+		, updateLocation' r $ Local d Nothing+		)+	Just False -> mknonbare+	{- core.bare not in config, probably because safe.directory+	 - did not allow reading the config -}+	Nothing -> ifM (Git.Construct.isBareRepo (fromRawFilePath d))+		( mkbare+		, mknonbare+		)   where 	dotgit = d P.</> ".git"+	-- git treats eg ~/foo as a bare git repository located in+	-- ~/foo/.git if ~/foo/.git/config has core.bare=true+	mkbare = ifM (doesDirectoryExist (fromRawFilePath dotgit))+		( updateLocation' r $ Local dotgit Nothing+		, updateLocation' r $ Local d Nothing+		)+	mknonbare = updateLocation' r $ Local dotgit (Just d)+ updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -212,8 +226,9 @@ boolConfig' True = "true" boolConfig' False = "false" -isBare :: Repo -> Bool-isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r+{- Note that repoIsLocalBare is often better to use than this. -}+isBare :: Repo -> Maybe Bool+isBare r = isTrueFalse' =<< getMaybe coreBare r  coreBare :: ConfigKey coreBare = "core.bare"
Git/Construct.hs view
@@ -1,6 +1,6 @@ {- Construction of Git Repo objects  -- - 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.  -}@@ -23,6 +23,7 @@ 	checkForRepo, 	newFrom, 	adjustGitDirFile,+	isBareRepo, ) where  #ifndef mingw32_HOST_OS@@ -216,7 +217,7 @@ checkForRepo dir =  	check isRepo $ 		check (checkGitDirFile (toRawFilePath dir)) $-			check isBareRepo $+			check (checkdir (isBareRepo dir)) $ 				return Nothing   where 	check test cont = maybe cont (return . Just) =<< test@@ -225,16 +226,17 @@ 		, return Nothing 		) 	isRepo = checkdir $ -		gitSignature (".git" </> "config")+		doesFileExist (dir </> ".git" </> "config") 			<||> 		-- A git-worktree lacks .git/config, but has .git/gitdir. 		-- (Normally the .git is a file, not a symlink, but it can 		-- be converted to a symlink and git will still work; 		-- this handles that case.)-		gitSignature (".git" </> "gitdir")-	isBareRepo = checkdir $ gitSignature "config"-		<&&> doesDirectoryExist (dir </> "objects")-	gitSignature file = doesFileExist $ dir </> file+		doesFileExist (dir </>  ".git" </> "gitdir")++isBareRepo :: FilePath -> IO Bool+isBareRepo dir = doesFileExist (dir </> "config")+	<&&> doesDirectoryExist (dir </> "objects")  -- Check for a .git file. checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation)
Git/CurrentRepo.hs view
@@ -81,7 +81,7 @@ 			} 		r <- Git.Config.read $ (newFrom loc) 			{ gitDirSpecifiedExplicitly = True }-		return $ if Git.Config.isBare r+		return $ if fromMaybe False (Git.Config.isBare r) 			then r { location = (location r) { worktree = Nothing } } 			else r 	configure Nothing Nothing = giveup "Not in a git repository."
Remote/Git.hs view
@@ -304,7 +304,7 @@ 			Right r' -> do 				-- Cache when http remote is not bare for 				-- optimisation.-				unless (Git.Config.isBare r') $+				unless (fromMaybe False $ Git.Config.isBare r') $ 					setremote setRemoteBare False 				return r' 			Left err -> do
Test.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite  -- - Copyright 2010-2022 oey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -1163,6 +1163,12 @@ test_info = intmpclonerepo $ do 	isjson 	readonly_query isjson+	-- When presented with an input that it does not support,+	-- info does not stop but processess subsequent inputs too.+	git_annex'' (const True)+		(sha1annexedfile `isInfixOf`)+		"info"+		[annexedfile, "dnefile", sha1annexedfile] Nothing "info"   where 	isjson = do 		json <- BU8.fromString <$> git_annex_output "info" ["--json"]@@ -1682,7 +1688,7 @@ 	git_annex "get" [] "get" 	annexed_present annexedfile 	-- any exit status is accepted; does abnormal exit-	git_annex'' (const True) "uninit" [] Nothing "uninit"+	git_annex'' (const True) (const True) "uninit" [] Nothing "uninit" 	checkregularfile annexedfile 	doesDirectoryExist ".git" @? ".git vanished in uninit" @@ -1797,8 +1803,8 @@ 	borgdirparent <- fromRawFilePath <$> (absPath . toRawFilePath =<< tmprepodir) 	let borgdir = borgdirparent </> "borgrepo" 	intmpclonerepo $ do-		testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) "borg init"-		testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) "borg create"+		testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) (const True) "borg init"+		testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) (const True) "borg create"  		git_annex "initremote" (words $ "borg type=borg borgrepo="++borgdir) "initremote" 		git_annex "sync" ["borg"] "sync borg"@@ -1808,7 +1814,7 @@ 		annexed_present annexedfile 		git_annex_expectoutput "find" ["--in=borg"] [] 		-		testProcess "borg" ["create", borgdir++"::backup2", "."] Nothing (== True) "borg create"+		testProcess "borg" ["create", borgdir++"::backup2", "."] Nothing (== True) (const True) "borg create" 		git_annex "sync" ["borg"] "sync borg after getting file" 		git_annex_expectoutput "find" ["--in=borg"] [annexedfile]
Test/Framework.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite framework  -- - 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.  -}@@ -67,27 +67,29 @@ -- displayed if the process does not return the expected value. -- -- In debug mode, the output is allowed to pass through.-testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> String -> Assertion-testProcess command params environ expectedret faildesc = do+-- So the output does not get checked in debug mode.+testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> (String -> Bool) -> String -> Assertion+testProcess command params environ expectedret expectedtranscript faildesc = do 	let p = (proc command params) { env = environ } 	debug <- testDebug . testOptions <$> getTestMode 	if debug 		then do 			ret <- withCreateProcess p $ \_ _ _ pid -> 				waitForProcess pid-			(expectedret (ret == ExitSuccess)) @? (faildesc ++ " failed")+			(expectedret (ret == ExitSuccess)) @? (faildesc ++ " failed with unexpected exit code") 		else do 			(transcript, ret) <- Utility.Process.Transcript.processTranscript' p Nothing-			(expectedret ret) @? (faildesc ++ " failed (transcript follows)\n" ++ transcript)+			(expectedret ret) @? (faildesc ++ " failed with unexpected exit code (transcript follows)\n" ++ transcript)+			(expectedtranscript transcript) @? (faildesc ++ " failed with unexpected output (transcript follows)\n" ++ transcript)  -- Run git. (Do not use to run git-annex as the one being tested -- may not be in path.) git :: String -> [String] -> String -> Assertion-git command params = testProcess "git" (command:params) Nothing (== True)+git command params = testProcess "git" (command:params) Nothing (== True) (const True)  -- For when git is expected to fail. git_shouldfail :: String -> [String] -> String -> Assertion-git_shouldfail command params = testProcess "git" (command:params) Nothing (== False)+git_shouldfail command params = testProcess "git" (command:params) Nothing (== False) (const True)  -- Run git-annex. git_annex :: String -> [String] -> String -> Assertion@@ -95,23 +97,23 @@  -- Runs git-annex with some environment. git_annex' :: String -> [String] -> Maybe [(String, String)] -> String -> Assertion-git_annex' = git_annex'' (== True)+git_annex' = git_annex'' (== True) (const True)  -- For when git-annex is expected to fail. git_annex_shouldfail :: String -> [String] -> String -> Assertion git_annex_shouldfail command params faildesc = git_annex_shouldfail' command params Nothing faildesc  git_annex_shouldfail' :: String -> [String] -> Maybe [(String, String)] -> String -> Assertion-git_annex_shouldfail' = git_annex'' (== False)+git_annex_shouldfail' = git_annex'' (== False) (const True) -git_annex'' :: (Bool -> Bool) -> String -> [String] -> Maybe [(String, String)] -> String -> Assertion-git_annex'' expectedret command params environ faildesc = do+git_annex'' :: (Bool -> Bool) -> (String -> Bool) -> String -> [String] -> Maybe [(String, String)] -> String -> Assertion+git_annex'' expectedret expectedtranscript command params environ faildesc = do 	pp <- Annex.Path.programPath 	debug <- testDebug . testOptions <$> getTestMode 	let params' = if debug 		then "--debug":params 		else params-	testProcess pp (command:params') environ expectedret faildesc+	testProcess pp (command:params') environ expectedret expectedtranscript faildesc  {- Runs git-annex and returns its standard output. -} git_annex_output :: String -> [String] -> IO String
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20230214+Version: 10.20230227 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -377,21 +377,7 @@    aws (>= 0.20),    DAV (>= 1.0),    network (>= 3.0.0.0),-   network-bsd,-   mountpoints,-   yesod (>= 1.4.3), -   yesod-static (>= 1.5.1),-   yesod-form (>= 1.4.8),-   yesod-core (>= 1.6.0),-   path-pieces (>= 0.2.1),-   warp (>= 3.2.8),-   warp-tls (>= 3.2.2),-   wai,-   wai-extra,-   blaze-builder,-   clientsession,-   template-haskell,-   shakespeare (>= 2.0.11)+   network-bsd   CC-Options: -Wall   GHC-Options: -Wall -fno-warn-tabs  -Wincomplete-uni-patterns   Default-Language: Haskell2010@@ -432,6 +418,21 @@      if flag(Assistant) && ! os(solaris) && ! os(gnu)     CPP-Options: -DWITH_ASSISTANT -DWITH_WEBAPP+    Build-Depends:+      mountpoints,+      yesod (>= 1.4.3), +      yesod-static (>= 1.5.1),+      yesod-form (>= 1.4.8),+      yesod-core (>= 1.6.0),+      path-pieces (>= 0.2.1),+      warp (>= 3.2.8),+      warp-tls (>= 3.2.2),+      wai,+      wai-extra,+      blaze-builder,+      clientsession,+      template-haskell,+      shakespeare (>= 2.0.11)     Other-Modules:       Assistant       Assistant.Alert@@ -447,8 +448,6 @@       Assistant.Fsck       Assistant.Gpg       Assistant.Install-      Assistant.Install.AutoStart-      Assistant.Install.Menu       Assistant.MakeRemote       Assistant.MakeRepo       Assistant.Monad@@ -540,7 +539,6 @@       Command.Watch       Command.WebApp       Utility.Mounts-      Utility.OSX       Utility.Yesod       Utility.WebApp     @@ -673,6 +671,8 @@     Annex.WorkerPool     Annex.WorkTree     Annex.YoutubeDl+    Assistant.Install.AutoStart+    Assistant.Install.Menu     Backend     Backend.External     Backend.Hash@@ -1115,6 +1115,7 @@     Utility.Network     Utility.NotificationBroadcaster     Utility.OptParse+    Utility.OSX     Utility.PID     Utility.PartialPrelude     Utility.Path