packages feed

git-annex 10.20230321 → 10.20230329

raw patch · 57 files changed

+345/−185 lines, 57 files

Files

Annex/Action.hs view
@@ -27,8 +27,8 @@ import Annex.TransferrerPool import qualified Database.Keys -import Control.Concurrent.STM #ifndef mingw32_HOST_OS+import Control.Concurrent.STM import System.Posix.Signals #endif
Annex/AdjustedBranch.hs view
@@ -45,7 +45,6 @@ import Types.AdjustedBranch import Annex.AdjustedBranch.Name import qualified Annex-import qualified Annex.Queue import Git import Git.Types import qualified Git.Branch@@ -249,26 +248,42 @@ updateAdjustedBranch :: Adjustment -> AdjBranch -> OrigBranch -> Annex Bool updateAdjustedBranch adj (AdjBranch currbranch) origbranch 	| not (adjustmentIsStable adj) = do-		b <- preventCommits $ \commitlck -> do+		(b, origheadfile, newheadfile) <- preventCommits $ \commitlck -> do 			-- Avoid losing any commits that the adjusted branch 			-- has that have not yet been propigated back to the 			-- origbranch. 			_ <- propigateAdjustedCommits' origbranch adj commitlck+				+			origheadfile <- inRepo $ readFile . Git.Ref.headFile  			-- Git normally won't do anything when asked to check 			-- out the currently checked out branch, even when its 			-- ref has changed. Work around this by writing a raw 			-- sha to .git/HEAD.-			inRepo (Git.Ref.sha currbranch) >>= \case-				Just headsha -> inRepo $ \r ->-					writeFile (Git.Ref.headFile r) (fromRef headsha)-				_ -> noop+			newheadfile <- inRepo (Git.Ref.sha currbranch) >>= \case+				Just headsha -> do+					inRepo $ \r -> do+						let newheadfile = fromRef headsha+						writeFile (Git.Ref.headFile r) newheadfile+						return (Just newheadfile)+				_ -> return Nothing 	-			adjustBranch adj origbranch+			b <- adjustBranch adj origbranch+			return (b, origheadfile, newheadfile) 	 		-- Make git checkout quiet to avoid warnings about 		-- disconnected branch tips being lost.-		checkoutAdjustedBranch b True+		ok <- checkoutAdjustedBranch b True++		-- Avoid leaving repo with detached head.+		unless ok $ case newheadfile of+			Nothing -> noop+			Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do+				v' <- readFile (Git.Ref.headFile r)+				when (v == v') $+					writeFile (Git.Ref.headFile r) origheadfile++		return ok 	| otherwise = preventCommits $ \commitlck -> do 		-- Done for consistency. 		_ <- propigateAdjustedCommits' origbranch adj commitlck@@ -312,22 +327,20 @@ 			    !s' = s { Annex.adjustedbranchrefreshcounter = c' } 			    in pure (s', enough) -	update adj origbranch = do-		-- Flush the queue, to make any pending changes be written-		-- out to disk. But mostly so any pointer files-		-- restagePointerFile was called on get updated so git-		-- checkout won't fall over.-		Annex.Queue.flush-		-- This is slow, it would be better to incrementally-		-- adjust the AssociatedFile, and only call this once-		-- at shutdown to handle cases where not all-		-- AssociatedFiles are known.+	-- This is slow, it would be better to incrementally+	-- adjust the AssociatedFile, and only call this once+	-- at shutdown to handle cases where not all+	-- AssociatedFiles are known.+	update adj origbranch = 		adjustedBranchRefreshFull adj origbranch  {- Slow, but more dependable version of adjustedBranchRefresh that  - does not rely on all AssociatedFiles being known. -} adjustedBranchRefreshFull :: Adjustment -> OrigBranch -> Annex () adjustedBranchRefreshFull adj origbranch = do+	-- Restage pointer files so modifications to them due to get/drop+	-- do not prevent checking out the updated adjusted branch.+	restagePointerFiles =<< Annex.gitRepo 	let adjbranch = originalToAdjusted origbranch adj 	unlessM (updateAdjustedBranch adj adjbranch origbranch) $ 		warning $ unwords [ "Updating adjusted branch failed." ]
Annex/Content.hs view
@@ -204,19 +204,24 @@ 	alreadylocked = giveup "content is locked" 	failedtolock e = giveup $ "failed to lock content: " ++ show e -	lock locker mlockfile = tryIO $ locker >>= \case-		Nothing -> alreadylocked-		Just h -> #ifndef mingw32_HOST_OS-			case mlockfile of-				Nothing -> return h-				Just lockfile ->-					ifM (checkSaneLock lockfile h)-						( return h-						, alreadylocked-						)+	lock locker mlockfile = #else-			return h+	lock locker _mlockfile =+#endif+		tryIO $ locker >>= \case+			Nothing -> alreadylocked+			Just h ->+#ifndef mingw32_HOST_OS+				case mlockfile of+					Nothing -> return h+					Just lockfile ->+						ifM (checkSaneLock lockfile h)+							( return h+							, alreadylocked+							)+#else+				return h #endif 	 	go (Right _) = a
Annex/CopyFile.hs view
@@ -31,17 +31,15 @@  {- Copies a file is copy-on-write is supported. Otherwise, returns False.  -- - The destination file must not exist yet, or it will fail to make a CoW copy,- - and will return false.+ - The destination file must not exist yet (or may exist but be empty), + - or it will fail to make a CoW copy, and will return false.  -} tryCopyCoW :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> IO Bool tryCopyCoW (CopyCoWTried copycowtried) src dest meterupdate = 	-- If multiple threads reach this at the same time, they 	-- will both try CoW, which is acceptable. 	ifM (isEmptyMVar copycowtried)-		-- If dest exists, don't try CoW, since it would-		-- have to be deleted first.-		( ifM (doesFileExist dest)+		( ifM destfilealreadypopulated 			( return False 			, do 				ok <- docopycow@@ -61,6 +59,22 @@   where 	docopycow = watchFileSize dest meterupdate $ 		copyCoW CopyTimeStamps src dest+	+	dest' = toRawFilePath dest++	-- Check if the dest file already exists, which would prevent+	-- probing CoW. If the file exists but is empty, there's no benefit+	-- to resuming from it when CoW does not work, so remove it.+	destfilealreadypopulated = +		tryIO (R.getFileStatus dest') >>= \case+			Left _ -> return False+			Right st -> do+				sz <- getFileSize' dest' st+				if sz == 0+					then tryIO (removeFile dest) >>= \case+						Right () -> return False+						Left _ -> return True+					else return True  data CopyMethod = CopiedCoW | Copied
Annex/Ingest.hs view
@@ -63,7 +63,7 @@ 	{ lockingFile :: Bool 	-- ^ write bit removed during lock down 	, hardlinkFileTmpDir :: Maybe RawFilePath-	-- ^ hard link to temp directorya+	-- ^ hard link to temp directory 	, checkWritePerms :: Bool 	-- ^ check that write perms are successfully removed 	}@@ -178,7 +178,7 @@ 		Nothing -> do 			backend <- maybe 				(chooseBackend $ keyFilename source)-				(return . Just)+				return 				preferredbackend 			fst <$> genKey source meterupdate backend 		Just k -> return k
Annex/Init.hs view
@@ -51,10 +51,10 @@ import Upgrade import Annex.Tmp import Utility.UserInfo-import qualified Utility.RawFilePath as R-import Utility.ThreadScheduler import Annex.Perms #ifndef mingw32_HOST_OS+import Utility.ThreadScheduler+import qualified Utility.RawFilePath as R import Utility.FileMode import System.Posix.User import qualified Utility.LockFile.Posix as Posix@@ -62,8 +62,8 @@  import qualified Data.Map as M import Control.Monad.IO.Class (MonadIO)-import System.PosixCompat.Files (ownerReadMode, isNamedPipe) #ifndef mingw32_HOST_OS+import System.PosixCompat.Files (ownerReadMode, isNamedPipe) import Data.Either import qualified System.FilePath.ByteString as P import Control.Concurrent.Async
Annex/Link.hs view
@@ -43,7 +43,9 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P+#ifndef mingw32_HOST_OS import System.PosixCompat.Files (isSymbolicLink)+#endif  type LinkTarget = S.ByteString
Annex/Transfer.hs view
@@ -1,6 +1,6 @@ {- git-annex transfers  -- - Copyright 2012-2021 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -34,6 +34,7 @@ import Annex.LockPool import Types.Key import qualified Types.Remote as Remote+import qualified Types.Backend import Types.Concurrency import Annex.Concurrent import Types.WorkerPool@@ -64,11 +65,11 @@ -- Upload, not supporting canceling detected stalls upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v upload' u key f sd d a _witness = guardHaveUUID u $ -	runTransfer (Transfer Upload u (fromKey id key)) f sd d a+	runTransfer (Transfer Upload u (fromKey id key)) Nothing f sd d a  alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v alwaysUpload u key f sd d a _witness = guardHaveUUID u $ -	alwaysRunTransfer (Transfer Upload u (fromKey id key)) f sd d a+	alwaysRunTransfer (Transfer Upload u (fromKey id key)) Nothing f sd d a  -- Download, supporting canceling detected stalls. download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool@@ -87,7 +88,7 @@ -- Download, not supporting canceling detected stalls. download' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v download' u key f sd d a _witness = guardHaveUUID u $-	runTransfer (Transfer Download u (fromKey id key)) f sd d a+	runTransfer (Transfer Download u (fromKey id key)) Nothing f sd d a  guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v guardHaveUUID u a@@ -109,20 +110,20 @@  - Cannot cancel stalls, but when a likely stall is detected,   - suggests to the user that they enable stall detection handling.  -}-runTransfer :: Observable v => Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v+runTransfer :: Observable v => Transfer -> Maybe Backend -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v runTransfer = runTransfer' False  {- Like runTransfer, but ignores any existing transfer lock file for the  - transfer, allowing re-running a transfer that is already in progress.  -}-alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v+alwaysRunTransfer :: Observable v => Transfer -> Maybe Backend -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v alwaysRunTransfer = runTransfer' True -runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v-runTransfer' ignorelock t afile stalldetection retrydecider transferaction =+runTransfer' :: Observable v => Bool -> Transfer -> Maybe Backend -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v+runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider transferaction = 	enteringStage (TransferStage (transferDirection t)) $ 		debugLocks $-			preCheckSecureHashes (transferKey t) go+			preCheckSecureHashes (transferKey t) eventualbackend go   where 	go = do 		info <- liftIO $ startTransferInfo afile@@ -244,7 +245,7 @@ 	-> NotifyWitness 	-> Annex Bool runTransferrer sd r k afile retrydecider direction _witness =-	enteringStage (TransferStage direction) $ preCheckSecureHashes k $ do+	enteringStage (TransferStage direction) $ preCheckSecureHashes k Nothing $ do 		info <- liftIO $ startTransferInfo afile 		go 0 info   where@@ -271,18 +272,25 @@  - still contains content using an insecure hash, remotes will likewise  - tend to be configured to reject it, so Upload is also prevented.  -}-preCheckSecureHashes :: Observable v => Key -> Annex v -> Annex v-preCheckSecureHashes k a = ifM (isCryptographicallySecure k)-	( a-	, ifM (annexSecureHashesOnly <$> Annex.getGitConfig)-		( do-			warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key"-			return observeFailure-		, a-		)-	)+preCheckSecureHashes :: Observable v => Key -> Maybe Backend -> Annex v -> Annex v+preCheckSecureHashes k meventualbackend a = case meventualbackend of+	Just eventualbackend -> go+		(pure (Types.Backend.isCryptographicallySecure eventualbackend))+		(Types.Backend.backendVariety eventualbackend)+	Nothing -> go+		(isCryptographicallySecure k)+		(fromKey keyVariety k)   where-	variety = fromKey keyVariety k+	go checksecure variety = ifM checksecure+		( a+		, ifM (annexSecureHashesOnly <$> Annex.getGitConfig)+			( blocked variety+			, a+			)+		)+	blocked variety = do+		warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key"+		return observeFailure  type NumRetries = Integer
Annex/TransferrerPool.hs view
@@ -175,7 +175,11 @@ {- Starts a new git-annex transfer process, setting up handles  - that will be used to communicate with it. -} mkTransferrer :: SignalActionsVar -> RunTransferrer -> IO Transferrer+#ifndef mingw32_HOST_OS mkTransferrer signalactonsvar (RunTransferrer program params batchmaker) = do+#else+mkTransferrer _ (RunTransferrer program params batchmaker) = do+#endif 	{- It runs as a batch job. -} 	let (program', params') = batchmaker (program, params) 	{- It's put into its own group so that the whole group can be
Annex/View.hs view
@@ -387,7 +387,7 @@ prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or 	[ B.null (P.takeFileName f) && B.null (P.takeDirectory f) 	, viewTooLarge view-	, all hasfields (viewedFiles view viewedFileFromReference (fromRawFilePath f) metadata)+	, all hasfields (viewedFiles view (viewedFileFromReference' Nothing) (fromRawFilePath f) metadata) 	]   where 	view = View (Git.Ref "foo") $@@ -421,7 +421,9 @@  - branch for the view.  -} applyView :: View -> Maybe Adjustment -> Annex Git.Branch-applyView = applyView' viewedFileFromReference getWorkTreeMetaData+applyView v ma = do+	gc <- Annex.getGitConfig+	applyView' (viewedFileFromReference gc) getWorkTreeMetaData v ma  {- Generates a new branch for a View, which must be a more narrow  - version of the View originally used to generate the currently@@ -553,7 +555,8 @@ 		Git.LsTree.LsTreeRecursive 		(Git.LsTree.LsTreeLong True) 		(viewParentBranch view)-	applyView'' viewedFileFromReference getWorkTreeMetaData view madj l clean $+	gc <- Annex.getGitConfig+	applyView'' (viewedFileFromReference gc) getWorkTreeMetaData view madj l clean $ 		\ti -> do 			let ref = Git.Ref.branchFileRef (viewParentBranch view) 				(getTopFilePath (Git.LsTree.file ti))
Annex/View/ViewedFile.hs view
@@ -1,6 +1,6 @@ {- filenames (not paths) used in views  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,6 +11,7 @@ 	ViewedFile, 	MkViewedFile, 	viewedFileFromReference,+	viewedFileFromReference', 	viewedFileReuse, 	dirFromViewedFile, 	prop_viewedFile_roundtrips,@@ -35,17 +36,27 @@  -  - So, from dir/subdir/file.foo, generate file_%dir%subdir%.foo  -}-viewedFileFromReference :: MkViewedFile-viewedFileFromReference f = concat $-	[ escape (fromRawFilePath base)+viewedFileFromReference :: GitConfig -> MkViewedFile+viewedFileFromReference g = viewedFileFromReference' (annexMaxExtensionLength g)++viewedFileFromReference' :: Maybe Int -> MkViewedFile+viewedFileFromReference' maxextlen f = concat $+	[ escape (fromRawFilePath base') 	, if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%"-	, escape $ fromRawFilePath $ S.concat extensions+	, escape $ fromRawFilePath $ S.concat extensions' 	]   where 	(path, basefile) = splitFileName f 	dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)-	(base, extensions) = splitShortExtensions (toRawFilePath basefile')-	+	(base, extensions) = case maxextlen of+		Nothing -> splitShortExtensions (toRawFilePath basefile')+		Just n -> splitShortExtensions' (n+1) (toRawFilePath basefile')+	{- Limit to two extensions maximum. -}+	(base', extensions')+		| length extensions <= 2 = (base, extensions)+		| otherwise = +			let (es,more) = splitAt 2 (reverse extensions)+			in (base <> mconcat (reverse more), reverse es) 	{- On Windows, if the filename looked like "dir/c:foo" then 	 - basefile would look like it contains a drive letter, which will 	 - not work. There cannot really be a filename like that, probably,@@ -90,7 +101,7 @@ 	-- Relative filenames wanted, not directories. 	| any (isPathSeparator) (end f ++ beginning f) = True 	| isAbsolute f || isDrive f = True-	| otherwise = dir == dirFromViewedFile (viewedFileFromReference f)+	| otherwise = dir == dirFromViewedFile (viewedFileFromReference' Nothing f)   where 	f = fromTestableFilePath tf 	dir = joinPath $ beginning $ splitDirectories f
Assistant/Restart.hs view
@@ -100,7 +100,7 @@ 	uo <- defUrlOptions 	(== Right True) <$> exists url' uo   where-	url' = case parseURI url of+	url' = case parseURIPortable url of 		Nothing -> url 		Just uri -> show $ uri 			{ uriScheme = "http:"
Assistant/WebApp/Configurators/Edit.hs view
@@ -235,7 +235,7 @@ 		Nothing -> getRepoInfo Nothing mempty 	g <- liftAnnex gitRepo 	mrepo <- liftAnnex $ maybe (pure Nothing) (Just <$$> Remote.getRepo) mr-	let sshrepo = maybe False (remoteLocationIsSshUrl . flip parseRemoteLocation g . Git.repoLocation) mrepo+	let sshrepo = maybe False (\repo -> remoteLocationIsSshUrl (parseRemoteLocation (Git.repoLocation repo) False g)) mrepo 	$(widgetFile "configurators/edit/nonannexremote")  {- Makes any directory associated with the repository. -}
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -22,6 +22,7 @@ import Types.GitConfig import Annex.SpecialRemote.Config import Types.ProposedAccepted+import Utility.Url  import qualified Data.Map as M import qualified Data.Text as T@@ -96,4 +97,4 @@ 		Just h -> h == hostname  urlHost :: String -> Maybe String-urlHost url = uriRegName <$> (uriAuthority =<< parseURI url)+urlHost url = uriRegName <$> (uriAuthority =<< parseURIPortable url)
Assistant/WebApp/Gpg.hs view
@@ -110,5 +110,5 @@  - Only works if the gcrypt repo was created as a git-annex remote. -} probeGCryptRemoteUUID :: String -> Annex (Maybe UUID) probeGCryptRemoteUUID repolocation = do-	r <- inRepo $ Git.Construct.fromRemoteLocation repolocation+	r <- inRepo $ Git.Construct.fromRemoteLocation repolocation False 	GCrypt.getGCryptUUID False r
Assistant/WebApp/RepoList.hs view
@@ -186,12 +186,12 @@ 			-- Skip gcrypt repos on removable drives; 			-- handled separately. 			case fromProposedAccepted <$> getconfig (Accepted "gitrepo") of-				Just rr	| remoteLocationIsUrl (parseRemoteLocation rr g) ->+				Just rr	| remoteLocationIsUrl (parseRemoteLocation rr False g) -> 					val True EnableSshGCryptR 				_ -> Nothing 		Just "git" ->  			case fromProposedAccepted <$> getconfig (Accepted "location") of-				Just loc | remoteLocationIsSshUrl (parseRemoteLocation loc g) ->+				Just loc | remoteLocationIsSshUrl (parseRemoteLocation loc False g) -> 					val True EnableSshGitRemoteR 				_ -> Nothing 		_ -> Nothing
Backend.hs view
@@ -54,15 +54,13 @@ 	lookupname = lookupBackendVariety . parseKeyVariety . encodeBS  {- Generates a key for a file. -}-genKey :: KeySource -> MeterUpdate -> Maybe Backend -> Annex (Key, Backend)-genKey source meterupdate preferredbackend = do-	b <- maybe defaultBackend return preferredbackend-	case B.genKey b of-		Just a -> do-			k <- a source meterupdate-			return (k, b)-		Nothing -> giveup $ "Cannot generate a key for backend " ++-			decodeBS (formatKeyVariety (B.backendVariety b))+genKey :: KeySource -> MeterUpdate -> Backend -> Annex (Key, Backend)+genKey source meterupdate b = case B.genKey b of+	Just a -> do+		k <- a source meterupdate+		return (k, b)+	Nothing -> giveup $ "Cannot generate a key for backend " +++		decodeBS (formatKeyVariety (B.backendVariety b))  getBackend :: FilePath -> Key -> Annex (Maybe Backend) getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case@@ -78,12 +76,16 @@ {- Looks up the backend that should be used for a file.  - That can be configured on a per-file basis in the gitattributes file,  - or forced with --backend. -}-chooseBackend :: RawFilePath -> Annex (Maybe Backend)+chooseBackend :: RawFilePath -> Annex Backend chooseBackend f = Annex.getRead Annex.forcebackend >>= go   where-	go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS-		=<< checkAttr "annex.backend" f-	go (Just _) = Just <$> defaultBackend+	go Nothing = do+		mb <- maybeLookupBackendVariety . parseKeyVariety . encodeBS+			=<< checkAttr "annex.backend" f+		case mb of+			Just b -> return b+			Nothing -> defaultBackend+	go (Just _) = defaultBackend  {- Looks up a backend by variety. May fail if unsupported or disabled. -} lookupBackendVariety :: KeyVariety -> Annex Backend@@ -111,5 +113,5 @@ 	<$> maybeLookupBackendVariety (fromKey keyVariety k)  isCryptographicallySecure :: Key -> Annex Bool-isCryptographicallySecure k = maybe False (`B.isCryptographicallySecure` k)+isCryptographicallySecure k = maybe False B.isCryptographicallySecure 	<$> maybeLookupBackendVariety (fromKey keyVariety k)
Backend/External.hs view
@@ -72,7 +72,7 @@ 		, canUpgradeKey = Nothing 		, fastMigrate = Nothing 		, isStableKey = const isstable-		, isCryptographicallySecure = const iscryptographicallysecure+		, isCryptographicallySecure = iscryptographicallysecure 		} makeBackend' ebname hasext (Left _) = return $ unavailBackend ebname hasext @@ -86,7 +86,7 @@ 		, canUpgradeKey = Nothing 		, fastMigrate = Nothing 		, isStableKey = const False-		, isCryptographicallySecure = const False+		, isCryptographicallySecure = False 		}  genKeyExternal :: ExternalBackendName -> HasExt -> KeySource -> MeterUpdate -> Annex Key
Backend/Hash.hs view
@@ -80,7 +80,7 @@ 	, canUpgradeKey = Just needsUpgrade 	, fastMigrate = Just trivialMigrate 	, isStableKey = const True-	, isCryptographicallySecure = const (cryptographicallySecure hash)+	, isCryptographicallySecure = cryptographicallySecure hash 	}  genBackendE :: Hash -> Backend
Backend/URL.hs view
@@ -29,7 +29,7 @@ 	-- The content of an url can change at any time, so URL keys are 	-- not stable. 	, isStableKey = const False-	, isCryptographicallySecure = const False+	, isCryptographicallySecure = False 	}  {- Every unique url has a corresponding key. -}
Backend/WORM.hs view
@@ -32,7 +32,7 @@ 	, canUpgradeKey = Just needsUpgrade 	, fastMigrate = Just removeProblemChars 	, isStableKey = const True-	, isCryptographicallySecure = const False+	, isCryptographicallySecure = False 	}  {- The key includes the file size, modification time, and the
CHANGELOG view
@@ -1,3 +1,25 @@+git-annex (10.20230329) upstream; urgency=medium++  * sync: Fix parsing of gcrypt::rsync:// urls that use a relative path.+  * Avoid failure to update adjusted branch --unlock-present after git-annex+    drop when annex.adjustedbranchrefresh=1+  * Avoid leaving repo with a detached head when there is a failure+    checking out an updated adjusted branch.+  * view: Support annex.maxextensionlength when generating filenames for+    the view branch.+  * Windows: Support urls like "file:///c:/path"+  * addurl, importfeed: Fix failure when annex.securehashesonly is set.+  * Copy with a reflink when exporting a tree to a directory special remote.+  * Fix bug that caused broken protocol to be used with external remotes+    that use exporttree=yes. In some cases this could result in the wrong+    content being exported to, or retrieved from the remote.+  * Support VERSION 2 in the external special remote protocol, which is+    identical to VERSION 1, but avoids external remote programs neededing+    to work around the above bug. External remote program that support+    exporttree=yes are recommended to be updated to send VERSION 2.++ -- Joey Hess <id@joeyh.name>  Wed, 29 Mar 2023 13:29:07 -0400+ git-annex (10.20230321) upstream; urgency=medium    * Using git-annex view in an adjusted branch, or git-annex adjust in a
Command/AddUrl.hs view
@@ -31,6 +31,7 @@ import Utility.Metered import Utility.HtmlDetect import Utility.Path.Max+import Utility.Url (parseURIPortable) import qualified Utility.RawFilePath as R import qualified Annex.Transfer as Transfer @@ -220,7 +221,7 @@ 	af = AssociatedFile (Just file)  startWeb :: AddUnlockedMatcher -> AddUrlOptions -> SeekInput -> URLString -> CommandStart-startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURI urlstring+startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURIPortable urlstring   where 	bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ 		Url.parseURIRelaxed $ urlstring@@ -322,28 +323,28 @@  downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key) downloadWeb addunlockedmatcher o url urlinfo file =-	go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file))+	go =<< downloadWith' downloader urlkey webUUID url file   where 	urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing 	downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f 	go Nothing = return Nothing-	go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtmlFile (fromRawFilePath tmp)))-		( tryyoutubedl tmp-		, normalfinish tmp+	go (Just (tmp, backend)) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtmlFile (fromRawFilePath tmp)))+		( tryyoutubedl tmp backend+		, normalfinish tmp backend 		)-	normalfinish tmp = checkCanAdd o file $ \canadd -> do+	normalfinish tmp backend = checkCanAdd o file $ \canadd -> do 		showDestinationFile (fromRawFilePath file) 		createWorkTreeDirectory (parentDir file)-		Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file+		Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend webUUID url file 	-- Ask youtube-dl what filename it will download first,  	-- so it's only used when the file contains embedded media.-	tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case+	tryyoutubedl tmp backend = youtubeDlFileNameHtmlOnly url >>= \case 		Right mediafile ->  			let f = youtubeDlDestFile o file (toRawFilePath mediafile) 			in lookupKey f >>= \case 				Just k -> alreadyannexed (fromRawFilePath f) k 				Nothing -> dl f-		Left err -> checkRaw (Just err) o Nothing (normalfinish tmp)+		Left err -> checkRaw (Just err) o Nothing (normalfinish tmp backend) 	  where 		dl dest = withTmpWorkDir mediakey $ \workdir -> do 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)@@ -357,7 +358,7 @@ 								showDestinationFile (fromRawFilePath dest) 								addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile)) 								return $ Just mediakey-						Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp)+						Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend) 						Left msg -> do 							cleanuptmp 							warning msg@@ -420,29 +421,31 @@  -} downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe Key) downloadWith canadd addunlockedmatcher downloader dummykey u url file =-	go =<< downloadWith' downloader dummykey u url afile+	go =<< downloadWith' downloader dummykey u url file   where-	afile = AssociatedFile (Just file) 	go Nothing = return Nothing-	go (Just tmp) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp u url file+	go (Just (tmp, backend)) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend u url file  {- Like downloadWith, but leaves the dummy key content in  - the returned location. -}-downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> AssociatedFile -> Annex (Maybe RawFilePath)-downloadWith' downloader dummykey u url afile =+downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe (RawFilePath, Backend))+downloadWith' downloader dummykey u url file = 	checkDiskSpaceToGet dummykey Nothing $ do+		backend <- chooseBackend file 		tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey-		ok <- Transfer.notifyTransfer Transfer.Download url $-			Transfer.download' u dummykey afile Nothing Transfer.stdRetry $ \p -> do+		let t = (Transfer.Transfer Transfer.Download u (fromKey id dummykey))+		ok <- Transfer.notifyTransfer Transfer.Download url $ \_w ->+			Transfer.runTransfer t (Just backend) afile Nothing Transfer.stdRetry $ \p -> do 				createAnnexDirectory (parentDir tmp) 				downloader (fromRawFilePath tmp) p 		if ok-			then return (Just tmp)+			then return (Just (tmp, backend)) 			else return Nothing+  where+	afile = AssociatedFile (Just file) -finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> UUID -> URLString -> RawFilePath -> Annex Key-finishDownloadWith canadd addunlockedmatcher tmp u url file = do-	backend <- chooseBackend file+finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> Backend -> UUID -> URLString -> RawFilePath -> Annex Key+finishDownloadWith canadd addunlockedmatcher tmp backend u url file = do 	let source = KeySource 		{ keyFilename = file 		, contentLocation = tmp
Command/CalcKey.hs view
@@ -8,7 +8,7 @@ module Command.CalcKey where  import Command-import Backend (genKey)+import Backend (genKey, defaultBackend) import Types.KeySource import Utility.Metered @@ -21,7 +21,7 @@ 			(batchable run (pure ()))  run :: () -> SeekInput -> String -> Annex Bool-run _ _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case+run _ _ file = tryNonAsync (genKey ks nullMeterUpdate =<< defaultBackend) >>= \case 	Right (k, _) -> do 		liftIO $ putStrLn $ serializeKey k 		return True
Command/FromKey.hs view
@@ -18,6 +18,7 @@ import Annex.FileMatcher import Annex.Ingest import Git.FilePath+import Utility.Url  import Network.URI @@ -89,7 +90,7 @@ keyOpt = either giveup id . keyOpt'  keyOpt' :: String -> Either String Key-keyOpt' s = case parseURI s of+keyOpt' s = case parseURIPortable s of 	Just u | not (isKeyPrefix (uriScheme u)) -> 		Right $ Backend.URL.fromUrl s Nothing 	_ -> case deserializeKey s of
Command/Fsck.hs view
@@ -16,11 +16,13 @@ import qualified Types.Backend import qualified Backend import Annex.Content+#ifndef mingw32_HOST_OS+import Annex.Version import Annex.Content.Presence+#endif import Annex.Content.Presence.LowLevel import Annex.Perms import Annex.Link-import Annex.Version import Logs.Location import Logs.Trust import Logs.Activity@@ -257,12 +259,13 @@  - to the other location.  -} fixObjectLocation :: Key -> Annex Bool-fixObjectLocation key = do #ifdef mingw32_HOST_OS+fixObjectLocation _key = do 	-- Windows does not allow locked files to be renamed, but annex 	-- links are also not used on Windows. 	return True #else+fixObjectLocation key = do 	loc <- calcRepo (gitAnnexLocation key) 	idealloc <- calcRepo (gitAnnexLocation' (const (pure True)) key) 	if loc == idealloc
Command/Migrate.hs view
@@ -56,8 +56,7 @@ 		Nothing -> stop 		Just oldbackend -> do 			exists <- inAnnex key-			newbackend <- maybe defaultBackend return -				=<< chooseBackend file+			newbackend <- chooseBackend file 			if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists 				then go False oldbackend newbackend 				else if removeSize o && exists@@ -116,7 +115,7 @@ 			, contentLocation = content 			, inodeCache = Nothing 			}-		newkey <- fst <$> genKey source nullMeterUpdate (Just newbackend)+		newkey <- fst <$> genKey source nullMeterUpdate newbackend 		return $ Just (newkey, False) 	genkey (Just fm) = fm oldkey newbackend afile >>= \case 		Just newkey -> return (Just (newkey, True))
Command/Reinject.hs view
@@ -63,7 +63,7 @@ startKnown :: FilePath -> CommandStart startKnown src = notAnnexed src' $ 	starting "reinject" ai si $ do-		(key, _) <- genKey ks nullMeterUpdate Nothing+		(key, _) <- genKey ks nullMeterUpdate =<< defaultBackend 		ifM (isKnownKey key) 			( perform src' key 			, do
Command/RemoteDaemon.hs view
@@ -12,7 +12,9 @@ import Command import RemoteDaemon.Core import Utility.Daemon+#ifndef mingw32_HOST_OS import Annex.Path+#endif  cmd :: Command cmd = noCommit $
Command/SendKey.hs view
@@ -49,7 +49,7 @@ 	let afile = AssociatedFile Nothing 	ok <- maybe (a $ const noop) 		-- Using noRetry here because we're the sender.-		(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile Nothing noRetry a)+		(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) Nothing afile Nothing noRetry a) 		=<< Fields.getField Fields.remoteUUID 	fastDebug "Command.SendKey" "transfer done" 	liftIO $ exitBool ok
Command/Sync.hs view
@@ -220,7 +220,7 @@ 	let withbranch a = a =<< getCurrentBranch  	remotes <- syncRemotes (syncWith o)-	-- Remotes that are git repositories, not special remotes.+	-- Remotes that are git repositories, not (necesarily) special remotes. 	let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes 	-- Remotes that contain annex object content. 	contentremotes <- filter (\r -> Remote.uuid r /= NoUUID)
Git/Construct.hs view
@@ -39,6 +39,7 @@ import Git.FilePath import qualified Git.Url as Url import Utility.UserInfo+import Utility.Url (parseURIPortable)  import qualified Data.ByteString as B import qualified System.FilePath.ByteString as P@@ -104,10 +105,10 @@  fromUrl' :: String -> IO Repo fromUrl' url-	| "file://" `isPrefixOf` url = case parseURI url of+	| "file://" `isPrefixOf` url = case parseURIPortable url of 		Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u 		Nothing -> pure $ newFrom $ UnparseableUrl url-	| otherwise = case parseURI url of+	| otherwise = case parseURIPortable url of 		Just u -> pure $ newFrom $ Url u 		Nothing -> pure $ newFrom $ UnparseableUrl url @@ -129,7 +130,7 @@ 				, auth 				, fromRawFilePath (repoPath r) 				]-			in r { location = Url $ fromJust $ parseURI absurl }+			in r { location = Url $ fromJust $ parseURIPortable absurl } 		_ -> r  {- Calculates a list of a repo's configured remotes, by parsing its config. -}@@ -140,7 +141,7 @@ 	filterkeys f = filterconfig (\(k,_) -> f k) 	remotepairs = filterkeys isRemoteUrlKey 	construct (k,v) = remoteNamedFromKey k $-		fromRemoteLocation (fromConfigValue v) repo+		fromRemoteLocation (fromConfigValue v) False repo  {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo@@ -156,9 +157,15 @@ 	Just n -> Just <$> remoteNamed n r  {- Constructs a new Repo for one of a Repo's remotes using a given- - location (ie, an url). -}-fromRemoteLocation :: String -> Repo -> IO Repo-fromRemoteLocation s repo = gen $ parseRemoteLocation s repo+ - location (ie, an url). + -+ - knownurl can be true if the location is known to be an url. This allows+ - urls that don't parse as urls to be used, returning UnparseableUrl.+ - If knownurl is false, the location may still be an url, if it parses as+ - one.+ -}+fromRemoteLocation :: String -> Bool -> Repo -> IO Repo+fromRemoteLocation s knownurl repo = gen $ parseRemoteLocation s knownurl repo   where 	gen (RemotePath p) = fromRemotePath p repo 	gen (RemoteUrl u) = fromUrl u
Git/Credential.hs view
@@ -117,7 +117,7 @@  mkCredentialBaseURL :: Repo -> URLString -> Maybe CredentialBaseURL mkCredentialBaseURL r s = do-	u <- parseURI s+	u <- parseURIPortable s 	let usehttppath = fromMaybe False $ Config.isTrueFalse' $ 		Config.get (ConfigKey "credential.useHttpPath") (ConfigValue "") r 	if usehttppath
Git/GCrypt.hs view
@@ -55,7 +55,15 @@ 			    -- allows them); need to de-escape any such 			    -- to get back the path to the repository. 			    l' = Network.URI.unEscapeString l-			in fromRemoteLocation l' baserepo+			    -- gcrypt supports relative urls for rsync +			    -- like "rsync://host:relative/path"+			    -- but that does not parse as a valid url+			    -- (while the absolute urls it supports are+			    -- valid). +			    -- In order to support it, force treating it as+			    -- an url.+			    knownurl = "rsync://" `isPrefixOf` l'+			in fromRemoteLocation l' knownurl baserepo 		| otherwise = notencrypted  	notencrypted = giveup "not a gcrypt encrypted repository"
Git/Hook.hs view
@@ -14,9 +14,11 @@ import Utility.Tmp import Utility.Shell import Utility.FileMode+#ifndef mingw32_HOST_OS import qualified Utility.RawFilePath as R- import System.PosixCompat.Files (fileMode)+#endif+  data Hook = Hook 	{ hookName :: FilePath
Git/Remote.hs view
@@ -63,7 +63,7 @@ 	legal c = isAlphaNum c 	 data RemoteLocation = RemoteUrl String | RemotePath FilePath-	deriving (Eq)+	deriving (Eq, Show)  remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True@@ -75,16 +75,18 @@  {- Determines if a given remote location is an url, or a local  - path. Takes the repository's insteadOf configuration into account. -}-parseRemoteLocation :: String -> Repo -> RemoteLocation-parseRemoteLocation s repo = ret $ calcloc s+parseRemoteLocation :: String -> Bool -> Repo -> RemoteLocation+parseRemoteLocation s knownurl repo = go   where-	ret v+ 	s' = calcloc s+	go #ifdef mingw32_HOST_OS-		| dosstyle v = RemotePath (dospath v)+		| dosstyle s' = RemotePath (dospath s') #endif-		| scpstyle v = RemoteUrl (scptourl v)-		| urlstyle v = RemoteUrl v-		| otherwise = RemotePath v+		| scpstyle s' = RemoteUrl (scptourl s')+		| urlstyle s' = RemoteUrl s'+		| knownurl && s' == s = RemoteUrl s'+		| otherwise = RemotePath s' 	-- insteadof config can rewrite remote location 	calcloc l 		| null insteadofs = l
Remote/BitTorrent.hs view
@@ -23,6 +23,7 @@ import Messages.Progress import Utility.Metered import Utility.Tmp+import Utility.Url (parseURIPortable) import Backend.URL import Annex.Perms import Annex.Tmp@@ -141,10 +142,10 @@ isSupportedUrl u = isTorrentMagnetUrl u || isTorrentUrl u  isTorrentUrl :: URLString -> Bool-isTorrentUrl = maybe False (\u -> ".torrent" `isSuffixOf` uriPath u) . parseURI+isTorrentUrl = maybe False (\u -> ".torrent" `isSuffixOf` uriPath u) . parseURIPortable  isTorrentMagnetUrl :: URLString -> Bool-isTorrentMagnetUrl u = "magnet:" `isPrefixOf` u && checkbt (parseURI u)+isTorrentMagnetUrl u = "magnet:" `isPrefixOf` u && checkbt (parseURIPortable u)   where 	checkbt (Just uri) | "xt=urn:btih:" `isInfixOf` uriQuery uri = True 	checkbt _ = False
Remote/Directory.hs view
@@ -19,7 +19,10 @@ import qualified Data.Map as M import qualified System.FilePath.ByteString as P import Data.Default-import System.PosixCompat.Files (isRegularFile, getFdStatus, deviceID)+import System.PosixCompat.Files (isRegularFile, deviceID)+#ifndef mingw32_HOST_OS+import System.PosixCompat.Files (getFdStatus)+#endif  import Annex.Common import Types.Remote
Remote/External.hs view
@@ -377,19 +377,27 @@ 		handleRequest' st external req mp responsehandler  handleRequestKey :: External -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> ResponseHandler a -> Annex a-handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of-	Right sk -> handleRequest external (mkreq sk) mp responsehandler+handleRequestKey external mkreq k mp responsehandler = +	withSafeKey k $ \sk -> handleRequest external (mkreq sk) mp responsehandler++withSafeKey :: Key -> (SafeKey -> Annex a) -> Annex a+withSafeKey k a = case mkSafeKey k of+	Right sk -> a sk 	Left e -> giveup e  {- Export location is first sent in an EXPORT message before  - the main request. This is done because the ExportLocation can  - contain spaces etc. -} handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> ResponseHandler a -> Annex a-handleRequestExport external loc mkreq k mp responsehandler = do-	withExternalState external $ \st -> do-		checkPrepared st external-		sendMessage st (EXPORT loc)-	handleRequestKey external mkreq k mp responsehandler+handleRequestExport external loc mkreq k mp responsehandler = +	withSafeKey k $ \sk ->+		-- Both the EXPORT and subsequent request must be sent to the+		-- same external process, so run both with the same external+		-- state.+		withExternalState external $ \st -> do+			checkPrepared st external+			sendMessage st (EXPORT loc)+			handleRequest' st external (mkreq sk) mp responsehandler  handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a handleRequest' st external req mp responsehandler
Remote/External/Types.hs view
@@ -53,7 +53,7 @@ import Types.Availability (Availability(..)) import Types.Key import Git.Types-import Utility.Url (URLString)+import Utility.Url (URLString, parseURIPortable) import qualified Utility.SimpleProtocol as Proto  import Control.Concurrent.STM@@ -415,7 +415,7 @@ 	deriving (Eq, Ord, Show)  supportedProtocolVersions :: [ProtocolVersion]-supportedProtocolVersions = [1]+supportedProtocolVersions = [1, 2]  instance Proto.Serializable JobId where 	serialize (JobId n) = show n@@ -462,7 +462,7 @@  instance Proto.Serializable URI where 	serialize = show-	deserialize = parseURI+	deserialize = parseURIPortable  instance Proto.Serializable ExportLocation where 	serialize = fromRawFilePath . fromExportLocation
Remote/GCrypt.hs view
@@ -266,7 +266,7 @@ 				let u = genUUIDInNameSpace gCryptNameSpace gcryptid 				if Just u == mu || isNothing mu 					then do-						method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo)+						method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo False) 						gitConfigSpecialRemote u c' [("gcrypt", fromAccessMethod method)] 						return (c', u) 					else giveup $ "uuid mismatch; expected " ++ show mu ++ " but remote gitrepo has " ++ show u ++ " (" ++ show gcryptid ++ ")"
Remote/Git.hs view
@@ -102,7 +102,7 @@ 			Nothing -> return r 			Just url -> inRepo $ \g -> 				Git.Construct.remoteNamed n $-					Git.Construct.fromRemoteLocation (Git.fromConfigValue url) g+					Git.Construct.fromRemoteLocation (Git.fromConfigValue url) False g  {- Git remotes are normally set up using standard git commands, not  - git-annex initremote and enableremote.@@ -118,7 +118,7 @@ gitSetup Init mu _ c _ = do 	let location = maybe (giveup "Specify location=url") fromProposedAccepted $ 		M.lookup locationField c-	r <- inRepo $ Git.Construct.fromRemoteLocation location+	r <- inRepo $ Git.Construct.fromRemoteLocation location False 	r' <- tryGitConfigRead False r False 	let u = getUncachedUUID r' 	if u == NoUUID@@ -504,7 +504,7 @@ 					Nothing -> return True 				copier <- mkFileCopier hardlink st 				(ok, v) <- runTransfer (Transfer Download u (fromKey id key))-					file Nothing stdRetry $ \p ->+					Nothing file Nothing stdRetry $ \p -> 						metered (Just (combineMeterUpdate p meterupdate)) key bwlimit $ \_ p' ->  							copier object dest key p' checksuccess vc 				if ok@@ -567,7 +567,7 @@ 		-- run copy from perspective of remote 		res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) 			( return True-			, runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do+			, runTransfer (Transfer Download u (fromKey id key)) Nothing file Nothing stdRetry $ \p -> do 				let verify = RemoteVerify r 				copier <- mkFileCopier hardlink st 				let rsp = RetrievalAllKeysSecure
Remote/GitLFS.hs view
@@ -203,7 +203,7 @@ 			<$> M.lookup Annex.SpecialRemote.Config.typeField c 		u <- fromProposedAccepted 			<$> M.lookup urlField c-		let u' = Git.Remote.parseRemoteLocation u g+		let u' = Git.Remote.parseRemoteLocation u False g 		return $ Git.Remote.RemoteUrl (Git.repoLocation r) == u'  			&& t == typename remote 	go u mcu = do
RemoteDaemon/Types.hs view
@@ -15,6 +15,7 @@ import qualified Utility.SimpleProtocol as Proto import Types.GitConfig import Annex.ChangedRefs (ChangedRefs)+import Utility.Url  import Network.URI import Control.Concurrent@@ -100,7 +101,7 @@  instance Proto.Serializable RemoteURI where 	serialize (RemoteURI u) = show u-	deserialize = RemoteURI <$$> parseURI+	deserialize = RemoteURI <$$> parseURIPortable  instance Proto.Serializable Bool where 	serialize False = "0"
Types/Backend.hs view
@@ -34,7 +34,7 @@ 	-- same data. 	, isStableKey :: Key -> Bool 	-- Checks if a key is verified using a cryptographically secure hash.-	, isCryptographicallySecure :: Key -> Bool+	, isCryptographicallySecure :: Bool 	}  instance Show (BackendA a) where
Utility/CopyFile.hs view
@@ -61,9 +61,6 @@  -  - The dest file must not exist yet, or it will fail to make a CoW copy,  - and will return False.- -- - Note that in coreutil 9.0, cp uses CoW by default, without needing an- - option. This code is only needed to support older versions.  -} copyCoW :: CopyMetaData -> FilePath -> FilePath -> IO Bool copyCoW meta src dest@@ -83,6 +80,9 @@ 		return ok 	| otherwise = return False   where+ 	-- Note that in coreutils 9.0, cp uses CoW by default,+	-- without needing an option. This s only needed to support +	-- older versions. 	params = Param "--reflink=always" : copyMetaDataParams meta  {- Create a hard link if the filesystem allows it, and fall back to copying
Utility/DirWatcher/Win32Notify.hs view
@@ -7,7 +7,7 @@  module Utility.DirWatcher.Win32Notify (watchDir) where -import Common hiding (isDirectory)+import Common import Utility.DirWatcher.Types import qualified Utility.RawFilePath as R
Utility/FileMode.hs view
@@ -16,7 +16,10 @@ import System.IO import Control.Monad import System.PosixCompat.Types-import System.PosixCompat.Files (unionFileModes, intersectFileModes, stdFileMode, nullFileMode, setFileCreationMask, groupReadMode, ownerReadMode, ownerWriteMode, ownerExecuteMode, groupWriteMode, groupExecuteMode, otherReadMode, otherWriteMode, otherExecuteMode, fileMode)+import System.PosixCompat.Files (unionFileModes, intersectFileModes, stdFileMode, nullFileMode, groupReadMode, ownerReadMode, ownerWriteMode, ownerExecuteMode, groupWriteMode, groupExecuteMode, otherReadMode, otherWriteMode, otherExecuteMode, fileMode)+#ifndef mingw32_HOST_OS+import System.PosixCompat.Files (setFileCreationMask)+#endif import Control.Monad.IO.Class import Foreign (complement) import Control.Monad.Catch
Utility/FileSize.hs view
@@ -14,13 +14,15 @@ 	getFileSize', ) where -import System.PosixCompat.Files (FileStatus, fileSize)-import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO import Utility.FileSystemEncoding+#else+import System.PosixCompat.Files (fileSize) #endif+import System.PosixCompat.Files (FileStatus)+import qualified Utility.RawFilePath as R  type FileSize = Integer
Utility/InodeCache.hs view
@@ -54,9 +54,7 @@ import System.PosixCompat.Files (isRegularFile, fileID) import Data.Time.Clock.POSIX -#ifdef mingw32_HOST_OS-import Data.Word (Word64)-#else+#ifndef mingw32_HOST_OS import qualified System.Posix.Files as Posix #endif
Utility/LockFile/Windows.hs view
@@ -21,7 +21,6 @@  import Utility.Path.Windows import Utility.FileSystemEncoding-import Utility.Split  type LockFile = RawFilePath
Utility/MoveFile.hs view
@@ -14,11 +14,11 @@ ) where  import Control.Monad-import System.PosixCompat.Files (isDirectory) import System.IO.Error import Prelude  #ifndef mingw32_HOST_OS+import System.PosixCompat.Files (isDirectory) import Control.Monad.IfElse import Utility.SafeCommand #endif
Utility/Path.hs view
@@ -20,6 +20,7 @@ 	runSegmentPaths', 	dotfile, 	splitShortExtensions,+	splitShortExtensions', 	relPathDirToFileAbs, 	inSearchPath, 	searchPath,
Utility/Url.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}  module Utility.Url ( 	newManager,@@ -32,6 +33,7 @@ 	downloadConduit, 	sinkResponseFile, 	downloadPartial,+	parseURIPortable, 	parseURIRelaxed, 	matchStatusCodeException, 	matchHttpExceptionContent,@@ -71,6 +73,9 @@ import Data.Either import Data.Conduit import Text.Read+#ifdef mingw32_HOST_OS+import qualified System.FilePath.Windows as PW+#endif  type URLString = String @@ -608,10 +613,29 @@ 					then Just <$> brReadSome (responseBody resp) n 					else return Nothing +{- On unix this is the same as parseURI. But on Windows,+ - it can parse urls such as file:///C:/path/to/file+ - parseURI normally parses that as a path /C:/path/to/file+ - and this simply removes the excess leading slash when there is a+ - drive letter after it. -}+parseURIPortable :: URLString -> Maybe URI+#ifndef mingw32_HOST_OS+parseURIPortable = parseURI+#else+parseURIPortable s+	| "file:" `isPrefixOf` s = do+		u <- parseURI s+		return $ case PW.splitDirectories (uriPath u) of+			(p:d:_) | all PW.isPathSeparator p && PW.isDrive d ->+				u { uriPath = dropWhile PW.isPathSeparator (uriPath u) }+			_ -> u+	| otherwise = parseURI s+#endif+ {- Allows for spaces and other stuff in urls, properly escaping them. -} parseURIRelaxed :: URLString -> Maybe URI parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $-	parseURI $ escapeURIString isAllowedInURI s+	parseURIPortable $ escapeURIString isAllowedInURI s  {- Generate a http-conduit Request for an URI. This is able  - to deal with some urls that parseRequest would usually reject.
doc/git-annex-view.mdwn view
@@ -44,6 +44,12 @@ The name of the `_` directory can be changed using the annex.viewunsetdirectory git config. +Filenames in the view branch include their path within the original branch, to+ensure that they are unique. The path comes after the main filename, and+before any extensions. For example, "foo/bar.baz" will have a name+like "bar_%foo%.baz". annex.maxextensionlength can be used to configure+what is treated as an extension.+ # OPTIONS  * The [[git-annex-common-options]](1) can be used.
doc/git-annex.mdwn view
@@ -825,9 +825,11 @@  * `annex.maxextensionlength` -  Maximum length, in bytes, of what is considered a filename extension when-  adding a file to a backend that preserves filename extensions. The-  default length is 4, which allows extensions like "jpeg". The dot before+  Maximum length, in bytes, of what is considered a filename extension.+  This is used when adding a file to a backend that preserves filename extensions,+  and also when generating a view branch.++  The default length is 4, which allows extensions like "jpeg". The dot before   the extension is not counted part of its length. At most two extensions   at the end of a filename will be preserved, e.g. .gz or .tar.gz .
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20230321+Version: 10.20230329 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>