packages feed

git-annex 10.20230329 → 10.20230407

raw patch · 22 files changed

+189/−63 lines, 22 filesdep ~unix-compat

Dependency ranges changed: unix-compat

Files

Annex/AdjustedBranch.hs view
@@ -253,8 +253,8 @@ 			-- has that have not yet been propigated back to the 			-- origbranch. 			_ <- propigateAdjustedCommits' origbranch adj commitlck-				-			origheadfile <- inRepo $ readFile . Git.Ref.headFile+			+			origheadfile <- inRepo $ readFileStrict . Git.Ref.headFile  			-- Git normally won't do anything when asked to check 			-- out the currently checked out branch, even when its@@ -279,7 +279,7 @@ 		unless ok $ case newheadfile of 			Nothing -> noop 			Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do-				v' <- readFile (Git.Ref.headFile r)+				v' <- readFileStrict (Git.Ref.headFile r) 				when (v == v') $ 					writeFile (Git.Ref.headFile r) origheadfile
Annex/Environment.hs view
@@ -1,13 +1,17 @@ {- git-annex environment  -- - Copyright 2012, 2013 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE OverloadedStrings #-} -module Annex.Environment where+module Annex.Environment (+	checkEnvironment,+	checkEnvironmentIO,+	ensureCommit,+) where  import Annex.Common import Utility.UserInfo@@ -15,21 +19,26 @@ import Config import Utility.Env.Set +import Control.Exception+ {- Checks that the system's environment allows git to function.  - Git requires a GECOS username, or suitable git configuration, or+ - environment variables. When none of those are set, this will set the  - environment variables.  -  - Git also requires the system have a hostname containing a dot.  - Otherwise, it tries various methods to find a FQDN, and will fail if it  - does not. To avoid replicating that code here, which would break if its  - methods change, this function does not check the hostname is valid.- - Instead, code that commits can use ensureCommit.+ - Instead, git-annex init calls ensureCommit, which makes sure that git+ - gets set up to allow committing.  -} checkEnvironment :: Annex () checkEnvironment = do 	gitusername <- fromRepo $ Git.Config.getMaybe "user.name" 	when (isNothing gitusername || gitusername == Just "") $-		liftIO checkEnvironmentIO+		unlessM userConfigOnly $+			liftIO checkEnvironmentIO  checkEnvironmentIO :: IO () checkEnvironmentIO = whenM (isNothing <$> myUserGecos) $ do@@ -41,12 +50,24 @@ 	ensureEnv var val = setEnv var val False  {- Runs an action that commits to the repository, and if it fails, - - sets user.email and user.name to a dummy value and tries the action again. -}+ - sets user.email and user.name to a dummy value and tries the action again.+ -+ - Note that user.email and user.name are left set afterwards, so this only+ - needs to be used once to make sure that future commits will succeed.+ -} ensureCommit :: Annex a -> Annex a ensureCommit a = either retry return =<< tryNonAsync a    where-	retry _ = do-		name <- liftIO $ either (const "unknown") id <$> myUserName-		setConfig "user.name" name-		setConfig "user.email" name-		a+	retry e = ifM userConfigOnly+		( liftIO (throwIO e)+		, do+			name <- liftIO $ either (const "unknown") id <$> myUserName+			setConfig "user.name" name+			setConfig "user.email" name+			a+		)++userConfigOnly :: Annex Bool+userConfigOnly = do+	v <- fromRepo $ Git.Config.getMaybe "user.useconfigonly"+	return (fromMaybe False (Git.Config.isTrueFalse' =<< v))
CHANGELOG view
@@ -1,3 +1,18 @@+git-annex (10.20230407) upstream; urgency=medium++  * Fix laziness bug introduced in last release that breaks use+    of --unlock-present and --hide-missing adjusted branches.+  * Support user.useConfigOnly git config.+  * registerurl, unregisterurl: Added --remote option.+  * registerurl: When an url is claimed by a special remote other than the+    web, update location tracking for that special remote.+    (This was the behavior before version 6.20181011)+  * Sped up sqlite inserts 2x when built with persistent 2.14.5.0+  * git-annex.cabal: Prevent building with unix-compat 0.7 which+    removed System.PosixCompat.User.++ -- Joey Hess <id@joeyh.name>  Fri, 07 Apr 2023 13:36:23 -0400+ git-annex (10.20230329) upstream; urgency=medium    * sync: Fix parsing of gcrypt::rsync:// urls that use a relative path.
CmdLine/GitAnnex/Options.hs view
@@ -119,8 +119,8 @@ 	<> help "automatic mode" 	) -parseRemoteOption :: RemoteName -> DeferredParse Remote-parseRemoteOption = DeferredParse +mkParseRemoteOption :: RemoteName -> DeferredParse Remote+mkParseRemoteOption = DeferredParse  	. (fromJust <$$> Remote.byNameWithUUID) 	. Just @@ -145,8 +145,8 @@  parseFromToOptions :: Parser FromToOptions parseFromToOptions = -	(FromRemote . parseRemoteOption <$> parseFromOption) -	<|> (ToRemote . parseRemoteOption <$> parseToOption)+	(FromRemote . mkParseRemoteOption <$> parseFromOption) +	<|> (ToRemote . mkParseRemoteOption <$> parseToOption)  parseFromOption :: Parser RemoteName parseFromOption = strOption@@ -162,6 +162,12 @@ 	<> completeRemotes 	) +parseRemoteOption :: Parser RemoteName+parseRemoteOption = strOption+	( long "remote" <> metavar paramRemote+	<> completeRemotes+	)+ -- | From or to a remote, or both, or a special --to=here data FromToHereOptions  	= FromOrToRemote FromToOptions@@ -174,14 +180,14 @@ 	<*> optional parseToOption   where 	go (Just from) (Just to) = Just $ FromRemoteToRemote-		(parseRemoteOption from)-		(parseRemoteOption to)+		(mkParseRemoteOption from)+		(mkParseRemoteOption to) 	go (Just from) Nothing = Just $ FromOrToRemote-		(FromRemote $ parseRemoteOption from)+		(FromRemote $ mkParseRemoteOption from) 	go Nothing (Just to) = Just $ case to of 		"here" -> ToHere 		"." -> ToHere-		_ -> FromOrToRemote $ ToRemote $ parseRemoteOption to+		_ -> FromOrToRemote $ ToRemote $ mkParseRemoteOption to 	go Nothing Nothing = Nothing  instance DeferredParseClass FromToHereOptions where
Command/Drop.hs view
@@ -44,7 +44,7 @@ 	<*> parseBatchOption True  parseDropFromOption :: Parser (DeferredParse Remote)-parseDropFromOption = parseRemoteOption <$> strOption+parseDropFromOption = mkParseRemoteOption <$> strOption 	( long "from" <> short 'f' <> metavar paramRemote 	<> help "drop content from a remote" 	<> completeRemotes
Command/Export.hs view
@@ -59,7 +59,7 @@ optParser :: CmdParamsDesc -> Parser ExportOptions optParser _ = ExportOptions 	<$> (Git.Ref <$> parsetreeish)-	<*> (parseRemoteOption <$> parseToOption)+	<*> (mkParseRemoteOption <$> parseToOption) 	<*> parsetracking   where 	parsetreeish = argument str
Command/Fsck.hs view
@@ -74,7 +74,7 @@ optParser :: CmdParamsDesc -> Parser FsckOptions optParser desc = FsckOptions 	<$> cmdParams desc-	<*> optional (parseRemoteOption <$> strOption +	<*> optional (mkParseRemoteOption <$> strOption  		( long "from" <> short 'f' <> metavar paramRemote  		<> help "check remote" 		<> completeRemotes
Command/Get.hs view
@@ -32,7 +32,7 @@ optParser :: CmdParamsDesc -> Parser GetOptions optParser desc = GetOptions 	<$> cmdParams desc-	<*> optional (parseRemoteOption <$> parseFromOption)+	<*> optional (mkParseRemoteOption <$> parseFromOption) 	<*> parseAutoOption 	<*> optional (parseIncompleteOption <|> parseKeyOptions <|> parseFailedTransfersOption) 	<*> parseBatchOption True
Command/Import.hs view
@@ -75,7 +75,7 @@ optParser :: CmdParamsDesc -> Parser ImportOptions optParser desc = do 	ps <- cmdParams desc-	mfromremote <- optional $ parseRemoteOption <$> parseFromOption+	mfromremote <- optional $ mkParseRemoteOption <$> parseFromOption 	content <- invertableSwitch "content" True 		( help "do not get contents of imported files" 		)
Command/RegisterUrl.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - 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.  -}@@ -9,8 +9,10 @@  import Command import Logs.Web+import Logs.Location import Command.FromKey (keyOpt, keyOpt') import qualified Remote+import Annex.UUID  cmd :: Command cmd = withAnnexOptions [jsonOptions] $ command "registerurl"@@ -21,24 +23,26 @@ data RegisterUrlOptions = RegisterUrlOptions 	{ keyUrlPairs :: CmdParams 	, batchOption :: BatchMode+	, remoteOption :: Maybe (DeferredParse Remote) 	}  optParser :: CmdParamsDesc -> Parser RegisterUrlOptions optParser desc = RegisterUrlOptions 	<$> cmdParams desc 	<*> parseBatchOption False+	<*> optional (mkParseRemoteOption <$> parseRemoteOption)  seek :: RegisterUrlOptions -> CommandSeek seek o = case (batchOption o, keyUrlPairs o) of-	(Batch fmt, _) -> seekBatch setUrlPresent o fmt+	(Batch fmt, _) -> seekBatch registerUrl o fmt 	-- older way of enabling batch input, does not support BatchNull-	(NoBatch, []) -> seekBatch setUrlPresent o (BatchFormat BatchLine (BatchKeys False))-	(NoBatch, ps) -> commandAction (start setUrlPresent ps)+	(NoBatch, []) -> seekBatch registerUrl o (BatchFormat BatchLine (BatchKeys False))+	(NoBatch, ps) -> commandAction (start registerUrl o ps) -seekBatch :: (Key -> URLString -> Annex ()) -> RegisterUrlOptions -> BatchFormat -> CommandSeek+seekBatch :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> BatchFormat -> CommandSeek seekBatch a o fmt = batchOnly Nothing (keyUrlPairs o) $ 	batchInput fmt (pure . parsebatch) $-		batchCommandAction . start' a+		batchCommandAction . start' a o   where 	parsebatch l =  		let (keyname, u) = separate (== ' ') l@@ -48,21 +52,39 @@ 				Left e -> Left e 				Right k -> Right (k, u) -start :: (Key -> URLString -> Annex ()) -> [String] -> CommandStart-start a (keyname:url:[]) = start' a (si, (keyOpt keyname, url))+start :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> [String] -> CommandStart+start a o (keyname:url:[]) = start' a o (si, (keyOpt keyname, url))   where 	si = SeekInput [keyname, url]-start _ _ = giveup "specify a key and an url"+start _ _ _ = giveup "specify a key and an url" -start' :: (Key -> URLString -> Annex ()) -> (SeekInput, (Key, URLString)) -> CommandStart-start' a (si, (key, url)) =+start' :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> (SeekInput, (Key, URLString)) -> CommandStart+start' a o (si, (key, url)) = 	starting "registerurl" ai si $-		perform a key url+		perform a o key url   where 	ai = ActionItemOther (Just url) -perform :: (Key -> URLString -> Annex ()) -> Key -> URLString -> CommandPerform-perform a key url = do-	r <- Remote.claimingUrl url-	a key (setDownloader' url r)-	next $ return True+perform :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> Key -> URLString -> CommandPerform+perform a o key url = do+	needremote <- maybe (pure Nothing) (Just <$$> getParsed) (remoteOption o)+	r <- case needremote of+		Just nr | Remote.uuid nr == webUUID -> pure nr+		_ -> Remote.claimingUrl url+	case needremote of+		Just nr | nr /= r -> do+			showNote $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r+			next $ return False+		_ -> do+			a r key (setDownloader' url r)+			next $ return True++registerUrl :: Remote -> Key -> String -> Annex ()+registerUrl remote key url = do+	setUrlPresent key url+	-- setUrlPresent only updates location tracking when the url+	-- does not have an OtherDownloader, but this command needs to do+	-- it for urls claimed by other remotes as well.+	case snd (getDownloader url) of+		OtherDownloader -> logChange key (Remote.uuid remote) InfoPresent+		_ -> return ()
Command/RmUrl.hs view
@@ -62,3 +62,7 @@ 	forM_ [minBound..maxBound] $ \dl ->  		setUrlMissing key (setDownloader url dl) 	return True+	-- Unlike addurl, this does not update location tracking+	-- for remotes other than the web special remote. Doing so with+	-- a remote that git-annex can drop content from would rather+	-- unexpectedly leave content stranded on that remote.
Command/UnregisterUrl.hs view
@@ -22,13 +22,17 @@ seek :: RegisterUrlOptions -> CommandSeek seek o = case (batchOption o, keyUrlPairs o) of 	(Batch fmt, _) -> seekBatch unregisterUrl o fmt-	(NoBatch, ps) -> commandAction (start unregisterUrl ps)+	(NoBatch, ps) -> commandAction (start unregisterUrl o ps) -unregisterUrl :: Key -> String -> Annex ()-unregisterUrl key url = do+unregisterUrl :: Remote -> Key -> String -> Annex ()+unregisterUrl _remote key url = do 	-- Remove the url no matter what downloader; 	-- registerurl can set OtherDownloader, and this should also 	-- be able to remove urls added by addurl, which may use 	-- YoutubeDownloader. 	forM_ [minBound..maxBound] $ \dl -> 		setUrlMissing key (setDownloader url dl)+	-- Unlike unregisterurl, this does not update location tracking+	-- for remotes other than the web special remote. Doing so with+	-- a remote that git-annex can drop content from would rather+	-- unexpectedly leave content stranded on that remote.
Database/ContentIdentifier.hs view
@@ -36,6 +36,7 @@ import Database.Types import qualified Database.Queue as H import Database.Init+import Database.Utility import Annex.Locations import Annex.Common hiding (delete) import qualified Annex.Branch@@ -109,7 +110,7 @@ -- Be sure to also update the git-annex branch when using this. recordContentIdentifier :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> Key -> IO () recordContentIdentifier h (RemoteStateHandle u) cid k = queueDb h $ do-	void $ insertUnique $ ContentIdentifiers u cid k+	void $ insertUniqueFast $ ContentIdentifiers u cid k  getContentIdentifiers :: ContentIdentifierHandle -> RemoteStateHandle -> Key -> IO [ContentIdentifier] getContentIdentifiers (ContentIdentifierHandle h) (RemoteStateHandle u) k = @@ -132,7 +133,7 @@ recordAnnexBranchTree :: ContentIdentifierHandle -> Sha -> IO () recordAnnexBranchTree h s = queueDb h $ do         deleteWhere ([] :: [Filter AnnexBranch])-        void $ insertUnique $ AnnexBranch $ toSSha s+        void $ insertUniqueFast $ AnnexBranch $ toSSha s  getAnnexBranchTree :: ContentIdentifierHandle -> IO Sha getAnnexBranchTree (ContentIdentifierHandle h) = H.queryDbQueue h $ do
Database/Export.hs view
@@ -49,6 +49,7 @@ import Database.Types import qualified Database.Queue as H import Database.Init+import Database.Utility import Annex.Locations import Annex.Common hiding (delete) import Types.Export@@ -124,7 +125,7 @@ recordExportTreeCurrent :: ExportHandle -> Sha -> IO () recordExportTreeCurrent h s = queueDb h $ do 	deleteWhere ([] :: [Filter ExportTreeCurrent])-	void $ insertUnique $ ExportTreeCurrent $ toSSha s+	void $ insertUniqueFast $ ExportTreeCurrent $ toSSha s  getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha) getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do@@ -136,7 +137,7 @@  addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () addExportedLocation h k el = queueDb h $ do-	void $ insertUnique $ Exported k ef+	void $ insertUniqueFast $ Exported k ef 	let edirs = map 		(\ed -> ExportedDirectory (SFilePath (fromExportDirectory ed)) ef) 		(exportDirectories el)@@ -186,7 +187,7 @@  addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $-	void $ insertUnique $ ExportTree k ef+	void $ insertUniqueFast $ ExportTree k ef   where 	ef = SFilePath (fromExportLocation loc)
Database/Fsck.hs view
@@ -29,6 +29,7 @@  import Database.Types import qualified Database.Queue as H+import Database.Utility import Database.Init import Annex.Locations import Utility.Exception@@ -88,7 +89,7 @@  addDb :: FsckHandle -> Key -> IO () addDb (FsckHandle h _) k = H.queueDb h checkcommit $-	void $ insertUnique $ Fscked k+	void $ insertUniqueFast $ Fscked k   where 	-- Commit queue after 1000 changes or 5 minutes, whichever comes first. 	-- The time based commit allows for an incremental fsck to be
Database/Handle.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE TypeFamilies, FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts, OverloadedStrings, CPP #-}  module Database.Handle ( 	DbHandle,@@ -329,4 +329,3 @@  takeMVarSafe :: MVar a -> IO (Either BlockedIndefinitelyOnMVar a) takeMVarSafe = try . takeMVar-
Database/Keys/SQL.hs view
@@ -21,6 +21,7 @@  import Database.Types import Database.Handle+import Database.Utility import qualified Database.Queue as H import Utility.InodeCache import Git.FilePath@@ -121,7 +122,7 @@  addInodeCaches :: Key -> [InodeCache] -> WriteHandle -> IO () addInodeCaches k is = queueDb $-	forM_ is $ \i -> insertUnique $ Content k i +	forM_ is $ \i -> insertUniqueFast $ Content k i  		(inodeCacheToFileSize i) 		(inodeCacheToEpochTime i)
+ Database/Utility.hs view
@@ -0,0 +1,27 @@+{- Persistent sqlite database utilities.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE TypeFamilies, CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Database.Utility (+	insertUniqueFast,+) where++import Control.Monad+import Database.Persist.Class++{- insertUnique_ is 2x as fast as insertUnique, so use when available.+ -+ - It would be difficult to write the type signature here, since older+ - versions of persistent have different constraints on insertUnique.+ -}+#if MIN_VERSION_persistent(2,14,5)+insertUniqueFast x = void (insertUnique_ x)+#else+insertUniqueFast x = void (insertUnique x)+#endif
doc/git-annex-registerurl.mdwn view
@@ -17,7 +17,18 @@ to use this to add urls, if the key cannot be parsed as a key, and is a valid url, an URL key is constructed from the url. +Registering an url also makes git-annex treat the key as present in the+special remote that claims it. (Usually the web special remote.)+ # OPTIONS++* `--remote=name|uuid`++  Indicate that the url is expected to be claimed by the specified remote.+  If some other remote claims the url instead, registering it will fail.++  Note that `--remote=web` will prevent any other remote from claiming+  the url.  * `--batch`
doc/git-annex-rmurl.mdwn view
@@ -11,7 +11,9 @@ Record that the file is no longer available at the url.  Removing the last web url will make git-annex no longer treat content as being-present in the web special remote.+present in the web special remote. If some other special remote+claims the url, unregistering the url will not update presence information+for it, because the content may still be present on the remote.  # OPTIONS
doc/git-annex-unregisterurl.mdwn view
@@ -11,13 +11,23 @@ This plumbing-level command can be used to unregister urls when keys can no longer be downloaded from them. -Unregistering a key's last web url will make git-annex no longer treat content-as being present in the web special remote.- Normally the key is a git-annex formatted key. However, if the key cannot be parsed as a key, and is a valid url, an URL key is constructed from the url. +Unregistering a key's last web url will make git-annex no longer treat content+as being present in the web special remote. If some other special remote+claims the url, unregistering the url will not update presence information+for it, because the content may still be present on the remote.+ # OPTIONS++* `--remote=name|uuid`++  Indicate that the url is expected to be claimed by the specified remote.+  If some other remote claims the url instead, unregistering it will fail.++  Note that `--remote=web` will prevent any other remote from claiming+  the url.  * `--batch`
git-annex.cabal view
@@ -1,11 +1,11 @@ Name: git-annex-Version: 10.20230329+Version: 10.20230407 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable-Copyright: 2010-2022 Joey Hess+Copyright: 2010-2023 Joey Hess License-File: COPYRIGHT Homepage: http://git-annex.branchable.com/ Build-type: Custom@@ -294,7 +294,7 @@   location: git://git-annex.branchable.com/  custom-setup-  Setup-Depends: base (>= 4.11.1.0 && < 5.0), split, unix-compat, +  Setup-Depends: base (>= 4.11.1.0 && < 5.0), split, unix-compat (< 0.7),      filepath, exceptions, bytestring, IfElse, data-default,     filepath-bytestring (>= 1.4.2.1.4),     process (>= 1.6.3),@@ -318,7 +318,7 @@    case-insensitive,    random,    dlist,-   unix-compat (>= 0.5),+   unix-compat (>= 0.5 && < 0.7),    SafeSemaphore,    async,    directory (>= 1.2.7.0),@@ -836,6 +836,7 @@     Database.Keys.SQL     Database.Queue     Database.Types+    Database.Utility     Git     Git.AutoCorrect     Git.Branch