git-annex 10.20251215 → 10.20260115

raw patch · 93 files changed

+264/−1010 lines, 93 filesdep −network-infodep −network-multicastdep ~Win32dep ~basedep ~bytestring

Dependencies removed: network-info, network-multicast

Dependency ranges changed: Win32, base, bytestring, persistent, persistent-sqlite, stm, text, unix

Files

• Annex/Common.hs +1/−0
• Annex/Content/PointerFile.hs +22/−15
• Annex/Import.hs +12/−3
• Annex/Init.hs +23/−3
• Annex/Journal.hs +1/−7
• Annex/Link.hs +0/−11
• Annex/Locations.hs +0/−4
• Annex/Proxy.hs +0/−1
• Annex/Sim.hs +1/−1
• Annex/SpecialRemote.hs +1/−2
• Annex/Url.hs +3/−3
• Assistant.hs +0/−8
• Assistant/Alert.hs +0/−1
• Assistant/MakeRemote.hs +1/−2
• Assistant/Pairing/MakeRemote.hs +0/−98
• Assistant/Pairing/Network.hs +0/−132
• Assistant/Threads/PairListener.hs +0/−156
• Assistant/WebApp/Configurators/AWS.hs +0/−1
• Assistant/WebApp/Configurators/Pairing.hs +0/−186
• Assistant/WebApp/Configurators/Ssh.hs +1/−1
• Assistant/WebApp/Configurators/WebDAV.hs +0/−1
• Assistant/WebApp/Gpg.hs +0/−1
• Assistant/WebApp/MakeRemote.hs +0/−1
• Assistant/WebApp/Pairing.hs +0/−1
• Assistant/WebApp/RepoId.hs +0/−1
• Assistant/WebApp/routes +0/−4
• BuildFlags.hs +0/−6
• CHANGELOG +24/−0
• COPYRIGHT +1/−1
• CmdLine/GitRemoteAnnex.hs +2/−2
• Command/ConfigRemote.hs +1/−1
• Command/Dead.hs +0/−1
• Command/EnableRemote.hs +13/−17
• Command/Fix.hs +21/−3
• Command/InitCluster.hs +0/−1
• Command/InitRemote.hs +6/−4
• Command/List.hs +0/−1
• Command/ReregisterUrl.hs +0/−1
• Command/TestRemote.hs +0/−1
• Command/TransferKeys.hs +0/−1
• Database/ContentIdentifier.hs +2/−15
• Database/Export.hs +3/−4
• Database/Fsck.hs +1/−2
• Database/Handle.hs +9/−12
• Database/ImportFeed.hs +3/−4
• Database/Init.hs +1/−7
• Database/Keys/SQL.hs +1/−2
• Database/RawFilePath.hs +1/−3
• Database/RepoSize.hs +1/−2
• Database/Utility.hs +0/−27
• Git/Credential.hs +15/−8
• Logs/Proxy.hs +0/−1
• P2P/Http/Client.hs +8/−6
• P2P/Http/Server.hs +1/−1
• P2P/Http/State.hs +1/−1
• P2P/Http/Types.hs +0/−5
• Remote.hs +1/−1
• Remote/Adb.hs +2/−2
• Remote/Borg.hs +2/−2
• Remote/Bup.hs +2/−2
• Remote/Compute.hs +2/−2
• Remote/Ddar.hs +2/−2
• Remote/Directory.hs +2/−2
• Remote/External.hs +5/−4
• Remote/External/Types.hs +0/−1
• Remote/GCrypt.hs +2/−2
• Remote/Git.hs +4/−4
• Remote/GitLFS.hs +6/−3
• Remote/Glacier.hs +2/−2
• Remote/Helper/ExportImport.hs +2/−2
• Remote/Hook.hs +2/−2
• Remote/HttpAlso.hs +3/−3
• Remote/Mask.hs +2/−2
• Remote/Rsync.hs +2/−2
• Remote/S3.hs +2/−2
• Remote/Tahoe.hs +2/−2
• Remote/Web.hs +2/−2
• Remote/WebDAV.hs +2/−2
• Types/Cluster.hs +2/−7
• Types/GitConfig.hs +10/−2
• Types/Remote.hs +1/−1
• Types/Transferrer.hs +0/−1
• Utility/LockFile/Windows.hs +1/−12
• Utility/OpenFd.hs +1/−11
• Utility/STM.hs +0/−23
• Utility/Url.hs +5/−5
• Utility/UserInfo.hs +0/−2
• git-annex.cabal +11/−26
• stack.yaml +1/−2
• templates/configurators/addrepository/misc.hamlet +0/−8
• templates/configurators/pairing/disabled.hamlet +0/−6
• templates/configurators/pairing/local/inprogress.hamlet +0/−19
• templates/configurators/pairing/local/prompt.hamlet +0/−53

@@ -12,6 +12,7 @@ import Messages as X import Git.Quote as X import Types.RepoSize as X+import Git.Types as X (RemoteName) #ifndef mingw32_HOST_OS import System.Posix.IO as X hiding (createPipe, append) #endif

@@ -1,6 +1,6 @@ {- git-annex pointer files  -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -33,21 +33,28 @@ populatePointerFile :: Restage -> Key -> OsPath -> OsPath -> Annex (Maybe InodeCache) populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)   where-	go (Just k') | k == k' = do-		destmode <- liftIO $ catchMaybeIO $-			fileMode <$> R.getFileStatus (fromOsPath f)-		liftIO $ removeWhenExistsWith removeFile f-		(ic, populated) <- replaceWorkTreeFile f $ \tmp -> do-			ok <- linkOrCopy k obj tmp destmode >>= \case-				Just _ -> thawContent tmp >> return True-				Nothing -> liftIO (writePointerFile tmp k destmode) >> return False-			ic <- withTSDelta (liftIO . genInodeCache tmp)-			return (ic, ok)-		maybe noop (restagePointerFile restage f) ic-		if populated-			then return ic-			else return Nothing+	go (Just k') | k == k' = populatePointerFile' restage k obj f 	go _ = return Nothing++{- Before calling, must verify that the pointer file is a pointer to the key.+ -+ - This returns Nothing when populating the pointer file fails due to eg,+ - not enough disk space.+ -}+populatePointerFile' :: Restage -> Key -> OsPath -> OsPath -> Annex (Maybe InodeCache)+populatePointerFile' restage k obj f = do+	destmode <- liftIO $ catchMaybeIO $+		fileMode <$> R.getFileStatus (fromOsPath f)+	(ic, populated) <- replaceWorkTreeFile f $ \tmp -> do+		ok <- linkOrCopy k obj tmp destmode >>= \case+			Just _ -> thawContent tmp >> return True+			Nothing -> liftIO (writePointerFile tmp k destmode) >> return False+		ic <- withTSDelta (liftIO . genInodeCache tmp)+		return (ic, ok)+	maybe noop (restagePointerFile restage f) ic+	if populated+		then return ic+		else return Nothing  {- Removes the content from a pointer file, replacing it with a pointer.  -

@@ -798,7 +798,7 @@ 					Right r -> next $ do 						liftIO $ atomically $ 							putTMVar job r-						return True+						return (isJust r) 			commandAction $ bracket_ 				(waitstart importing cid) 				(signaldone importing cid)@@ -982,14 +982,23 @@ 			ImportSubTree subdir _ -> 				getTopFilePath subdir </> fromImportLocation loc -	getcidkey cidmap db cid = liftIO $+	getcidkey cidmap db cid = do 		-- Avoiding querying the database when it's empty speeds up 		-- the initial import.-		if CIDDb.databaseIsEmpty db+		l <- liftIO $ if CIDDb.databaseIsEmpty db 			then getcidkeymap cidmap cid 			else CIDDb.getContentIdentifierKeys db rs cid >>= \case 				[] -> getcidkeymap cidmap cid 				l -> return l+		filterM validcidkey l+	+	-- Guard against a content identifier containing a git sha that is+	-- not present in the repository. This can happen when a previous,+	-- import failed and the tree was not recorded, and this import is+	-- being run in another clone of the repository.+	validcidkey k = case keyGitSha k of+		Just sha -> isJust <$> catObjectMetaData sha+		Nothing -> return True  	getcidkeymap cidmap cid = 		atomically $ maybeToList . M.lookup cid <$> readTVar cidmap

@@ -1,6 +1,6 @@ {- git-annex repository initialization  -- - Copyright 2011-2025 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,6 +20,7 @@ 	probeCrippledFileSystem, 	probeCrippledFileSystem', 	isCrippledFileSystem,+	propigateInitGitConfigs, ) where  import Annex.Common@@ -34,6 +35,8 @@ import Logs.UUID import Logs.Trust.Basic import Logs.Config+import Logs.PreferredContent.Raw+import Logs.Group import Types.TrustLevel import Types.RepoVersion import Annex.Version@@ -64,6 +67,7 @@ #endif  import qualified Data.Map as M+import qualified Data.Set as S import Control.Monad.IO.Class (MonadIO) #ifndef mingw32_HOST_OS import System.PosixCompat.Files (ownerReadMode, isNamedPipe)@@ -150,7 +154,8 @@ 		hookWrite preCommitHook 		hookWrite postReceiveHook 	setDifferences-	unlessM (isJust <$> getVersion) $+	initialversion <- getVersion+	unless (isJust initialversion) $ 		setVersion (fromMaybe defaultVersion mversion) 	supportunlocked <- annexSupportUnlocked <$> Annex.getGitConfig 	if supportunlocked@@ -171,6 +176,8 @@ 					Direct.switchHEADBack 				) 	propigateSecureHashesOnly+	when (isNothing initialversion) $+		propigateInitGitConfigs =<< getUUID 	createInodeSentinalFile False 	fixupUnusualReposAfterInit @@ -487,7 +494,7 @@ 	trustSet u UnTrusted 	setConfig (annexConfig "hardlink") (Git.Config.boolConfig True) -{- Propagate annex.securehashesonly from then global config to local+{- Propigate annex.securehashesonly from the global config to local  - config. This makes a clone inherit a parent's setting, but once  - a repository has a local setting, changes to the global config won't  - affect it. -}@@ -495,6 +502,19 @@ propigateSecureHashesOnly = 	maybe noop (setConfig "annex.securehashesonly" . fromConfigValue) 		=<< getGlobalConfig "annex.securehashesonly"++{- Propigate git configs that set defaults. -}+propigateInitGitConfigs :: UUID -> Annex ()+propigateInitGitConfigs u = do+	gc <- Annex.getGitConfig+	set (annexInitWanted gc) preferredContentSet+	set (annexInitRequired gc) requiredContentSet+	case annexInitGroups gc of+		[] -> noop+		groups -> groupChange u (S.union (S.fromList groups))+  where+	set (Just expr) setter = setter u expr+	set Nothing _ = noop  fixupUnusualReposAfterInit :: Annex () fixupUnusualReposAfterInit = do

@@ -13,7 +13,6 @@  -}  {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}  module Annex.Journal where @@ -211,14 +210,9 @@ discardIncompleteAppend v 	| L.null v = v 	| L.last v == nl = v-	| otherwise = dropwhileend (/= nl) v+	| otherwise = L.dropWhileEnd (/= nl) v   where 	nl = fromIntegral (ord '\n')-#if MIN_VERSION_bytestring(0,11,2)-	dropwhileend = L.dropWhileEnd-#else-	dropwhileend p = L.reverse . L.dropWhile p . L.reverse-#endif  {- List of existing journal files in a journal directory, but without locking,  - may miss new ones just being added, or may have false positives if the

@@ -47,12 +47,8 @@ import qualified Data.ByteString.Lazy as L  #ifndef mingw32_HOST_OS-#if MIN_VERSION_unix(2,8,0) import Utility.OpenFd-#else-import System.PosixCompat.Files (isSymbolicLink) #endif-#endif  type LinkTarget = S.ByteString @@ -455,19 +451,12 @@ #if defined(mingw32_HOST_OS) 	F.withFile f ReadMode readhandle #else-#if MIN_VERSION_unix(2,8,0) 	let open = do 		fd <- openFdWithMode (fromOsPath f) ReadOnly Nothing 			(defaultFileFlags { nofollow = True }) 			(CloseOnExecFlag True) 		fdToHandle fd 	in bracket open hClose readhandle-#else-	ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f))-		( return Nothing-		, F.withFile f ReadMode readhandle-		)-#endif #endif   where 	readhandle h = parseLinkTargetOrPointer <$> S.hGet h maxPointerSz

@@ -796,11 +796,7 @@  	needesc = map (fromIntegral . ord) ['&', '%', ':', '/'] -#if MIN_VERSION_bytestring(0,11,3) 	anyneedesc = SB.any (`elem` needesc)-#else-	anyneedesc = any (`elem` needesc) . SB.unpack-#endif  {- Reverses keyFile, converting a filename fragment (ie, the basename of  - the symlink target) into a key. -}

@@ -29,7 +29,6 @@ import Logs.Location import Utility.Tmp.Dir import Utility.Metered-import Git.Types import qualified Database.Export as Export import qualified Utility.FileIO as F #ifndef mingw32_HOST_OS

@@ -9,7 +9,7 @@  module Annex.Sim where -import Annex.Common+import Annex.Common hiding (RemoteName) import Utility.DataUnits import Types.NumCopies import Types.Group

@@ -22,7 +22,6 @@ import Logs.Remote import Logs.Trust import qualified Types.Remote as Remote-import Git.Types (RemoteName) import Utility.SafeOutput  import qualified Data.Map as M@@ -99,7 +98,7 @@ 			(Just name, Right t) -> checkcanenable u name $ do 				showSideAction $ UnquotedString $ "Auto enabling special remote " ++ name 				dummycfg <- liftIO dummyRemoteGitConfig-				tryNonAsync (setup t (AutoEnable c) (Just u) Nothing c dummycfg) >>= \case+				tryNonAsync (setup t (AutoEnable c) (Just u) name Nothing c dummycfg) >>= \case 					Left e -> warning (UnquotedString (show e)) 					Right (_c, _u) -> 						when (cu /= u) $

@@ -157,7 +157,7 @@ withUrlOptions mgc a = a =<< getUrlOptions mgc  -- When downloading an url, if authentication is needed, uses--- git-credential to prompt for username and password.+-- git-credential for the prompting. -- -- Note that, when the downloader is curl, it will not use git-credential. -- If the user wants to, they can configure curl to use a netrc file that@@ -169,8 +169,8 @@ 	prompter <- mkPrompter 	cc <- Annex.getRead Annex.gitcredentialcache 	a $ uo-		{ U.getBasicAuth = \u -> prompter $-			getBasicAuthFromCredential g cc u+		{ U.getBasicAuth = \u respheaders -> prompter $+			getBasicAuthFromCredential g cc u respheaders 		}  checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool

@@ -40,9 +40,6 @@ #ifdef WITH_WEBAPP import Assistant.WebApp import Assistant.Threads.WebApp-#ifdef WITH_PAIRING-import Assistant.Threads.PairListener-#endif #else import Assistant.Types.UrlRenderer #endif@@ -155,11 +152,6 @@ 			then webappthread 			else webappthread ++ 				[ watch commitThread-#ifdef WITH_WEBAPP-#ifdef WITH_PAIRING-				, assist $ pairListenerThread urlrenderer-#endif-#endif 				, assist pushThread 				, assist pushRetryThread 				, assist exportThread

@@ -16,7 +16,6 @@ import Utility.Tense import Types.Transfer import Types.Distribution-import Git.Types (RemoteName)  import Data.String import qualified Data.Text as T

@@ -24,7 +24,6 @@ import Logs.UUID import Logs.Remote import Git.Remote-import Git.Types (RemoteName) import Creds import Assistant.Gpg import Utility.Gpg (KeyId)@@ -108,7 +107,7 @@ 	 - to perform IO actions to refill the pool. -} 	let weakc = M.insert (Proposed "highRandomQuality") (Proposed "false") (M.union config c) 	dummycfg <- liftIO dummyRemoteGitConfig-	(c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg+	(c', u) <- R.setup remotetype ss mu name mcreds weakc dummycfg 	case mcu of 		Nothing -> 			configSet u c'

@@ -1,98 +0,0 @@-{- git-annex assistant pairing remote creation- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Assistant.Pairing.MakeRemote where--import Assistant.Common-import Assistant.Ssh-import Assistant.Pairing-import Assistant.Pairing.Network-import Assistant.MakeRemote-import Assistant.Sync-import Config.Cost-import Config-import qualified Types.Remote as Remote--import Network.Socket-import qualified Data.Text as T--{- Authorized keys are set up before pairing is complete, so that the other- - side can immediately begin syncing. -}-setupAuthorizedKeys :: PairMsg -> OsPath -> IO ()-setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of-	Left err -> giveup err-	Right pubkey -> do-		absdir <- absPath repodir-		unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $-			giveup "failed setting up ssh authorized keys"--{- When local pairing is complete, this is used to set up the remote for- - the host we paired with. -}-finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()-finishedLocalPairing msg keypair = do-	sshdata <- liftIO $ installSshKeyPair keypair =<< pairMsgToSshData msg-	{- Ensure that we know the ssh host key for the host we paired with.-	 - If we don't, ssh over to get it. -}-	liftIO $ unlessM (knownHost $ sshHostName sshdata) $-		void $ sshTranscript-			[ sshOpt "StrictHostKeyChecking" "no"-			, sshOpt "NumberOfPasswordPrompts" "0"-			, "-n"-			]-			(genSshHost (sshHostName sshdata) (sshUserName sshdata))-			("git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata))-			Nothing-	r <- liftAnnex $ addRemote $ makeSshRemote sshdata-	repo <- liftAnnex $ Remote.getRepo r-	liftAnnex $ setRemoteCost repo semiExpensiveRemoteCost-	syncRemote r--{- Mostly a straightforward conversion.  Except:- -  * Determine the best hostname to use to contact the host.- -  * Strip leading ~/ from the directory name.- -}-pairMsgToSshData :: PairMsg -> IO SshData-pairMsgToSshData msg = do-	let d = pairMsgData msg-	hostname <- liftIO $ bestHostName msg-	let dir = case remoteDirectory d of-		('~':'/':v) -> v-		v -> v-	return SshData-		{ sshHostName = T.pack hostname-		, sshUserName = Just (T.pack $ remoteUserName d)-		, sshDirectory = T.pack dir-		, sshRepoName = genSshRepoName hostname (toOsPath dir)-		, sshPort = 22-		, needsPubKey = True-		, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]-		, sshRepoUrl = Nothing-		}--{- Finds the best hostname to use for the host that sent the PairMsg.- -- - If remoteHostName is set, tries to use a .local address based on it.- - That's the most robust, if this system supports .local.- - Otherwise, looks up the hostname in the DNS for the remoteAddress,- - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}-bestHostName :: PairMsg -> IO HostName-bestHostName msg = case remoteHostName $ pairMsgData msg of-	Just h -> do-		let localname = h ++ ".local"-		addrs <- catchDefaultIO [] $-			getAddrInfo Nothing (Just localname) Nothing-		maybe fallback (const $ return localname) (headMaybe addrs)-	Nothing -> fallback-  where-	fallback = do-		let a = pairMsgAddr msg-		let sockaddr = case a of-			IPv4Addr addr -> SockAddrInet (fromInteger 0) addr-			IPv6Addr addr -> SockAddrInet6 (fromInteger 0) 0 addr 0-		fromMaybe (showAddr a)-			<$> catchDefaultIO Nothing-				(fst <$> getNameInfo [] True False sockaddr)

@@ -1,132 +0,0 @@-{- git-annex assistant pairing network code- -- - All network traffic is sent over multicast UDP. For reliability,- - each message is repeated until acknowledged. This is done using a- - thread, that gets stopped before the next message is sent.- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Assistant.Pairing.Network where--import Assistant.Common-import Assistant.Pairing-import Assistant.DaemonStatus-import Utility.ThreadScheduler-import Utility.Verifiable--import Network.Multicast-import Network.Info-import Network.Socket-import qualified Network.Socket.ByteString as B-import qualified Data.ByteString.UTF8 as BU8-import qualified Data.Map as M-import Control.Concurrent--{- This is an arbitrary port in the dynamic port range, that could- - conceivably be used for some other broadcast messages.- - If so, hope they ignore the garbage from us; we'll certainly- - ignore garbage from them. Wild wild west. -}-pairingPort :: PortNumber-pairingPort = 55556--{- Goal: Reach all hosts on the same network segment.- - Method: Use same address that avahi uses. Other broadcast addresses seem- - to not be let through some routers. -}-multicastAddress :: AddrClass -> HostName-multicastAddress IPv4AddrClass = "224.0.0.251"-multicastAddress IPv6AddrClass = "ff02::fb"--{- Multicasts a message repeatedly on all interfaces, with a 2 second- - delay between each transmission. The message is repeated forever- - unless a number of repeats is specified.- -- - The remoteHostAddress is set to the interface's IP address.- -- - Note that new sockets are opened each time. This is hardly efficient,- - but it allows new network interfaces to be used as they come up.- - On the other hand, the expensive DNS lookups are cached.- -}-multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO ()-multicastPairMsg repeats secret pairdata stage = go M.empty repeats-  where-	go _ (Just 0) = noop-	go cache n = do-		addrs <- activeNetworkAddresses-		let cache' = updatecache cache addrs-		mapM_ (sendinterface cache') addrs-		threadDelaySeconds (Seconds 2)-		go cache' $ pred <$> n-	{- The multicast library currently chokes on ipv6 addresses. -}-	sendinterface _ (IPv6Addr _) = noop-	sendinterface cache i = void $ tryIO $-		withSocketsDo $ bracket setup cleanup use-	  where-		setup = multicastSender (multicastAddress IPv4AddrClass) pairingPort-		cleanup (sock, _) = close sock -- FIXME does not work-		use (sock, addr) = do-			setInterface sock (showAddr i)-			maybe noop-				(\s -> void $ B.sendTo sock (BU8.fromString s) addr)-				(M.lookup i cache)-	updatecache cache [] = cache-	updatecache cache (i:is)-		| M.member i cache = updatecache cache is-		| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is-	mkmsg addr = PairMsg $-		mkVerifiable (stage, pairdata, addr) secret--startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant ()-startSending pip stage sender = do-	a <- asIO start-	void $ liftIO $ forkIO a-  where-	start = do-		tid <- liftIO myThreadId-		let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }-		oldpip <- modifyDaemonStatus $-			\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)-		maybe noop stopold oldpip-		liftIO $ sender stage-	stopold = maybe noop (liftIO . killThread) . inProgressThreadId--stopSending :: PairingInProgress -> Assistant ()-stopSending pip = do-	maybe noop (liftIO . killThread) $ inProgressThreadId pip-	modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing }--class ToSomeAddr a where-	toSomeAddr :: a -> SomeAddr--instance ToSomeAddr IPv4 where-	toSomeAddr (IPv4 a) = IPv4Addr a--instance ToSomeAddr IPv6 where-	toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4)--showAddr :: SomeAddr -> HostName-showAddr (IPv4Addr a) = show $ IPv4 a-showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4--activeNetworkAddresses :: IO [SomeAddr]-activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)-	. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])-	<$> getNetworkInterfaces--{- A human-visible description of the repository being paired with.- - Note that the repository's description is not shown to the user, because- - it could be something like "my repo", which is confusing when pairing- - with someone else's repo. However, this has the same format as the- - default description of a repo. -}-pairRepo :: PairMsg -> String-pairRepo msg = concat-	[ remoteUserName d-	, "@"-	, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)-	, ":"-	, remoteDirectory d-	]-  where-	d = pairMsgData msg

@@ -1,156 +0,0 @@-{- git-annex assistant thread to listen for incoming pairing traffic- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--{-# LANGUAGE OverloadedStrings #-}--module Assistant.Threads.PairListener where--import Assistant.Common-import Assistant.Pairing-import Assistant.Pairing.Network-import Assistant.Pairing.MakeRemote-import Assistant.WebApp (UrlRenderer)-import Assistant.WebApp.Types-import Assistant.Alert-import Assistant.DaemonStatus-import Utility.ThreadScheduler-import Git--import Network.Multicast-import Network.Socket-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BU8-import qualified Network.Socket.ByteString as B-import qualified Data.Text as T--pairListenerThread :: UrlRenderer -> NamedThread-pairListenerThread urlrenderer = namedThread "PairListener" $ do-	listener <- asIO1 $ go [] []-	liftIO $ withSocketsDo $-		runEvery (Seconds 60) $ void $ tryIO $ -			listener =<< getsock-  where-	{- Note this can crash if there's no network interface,-	 - or only one like lo that doesn't support multicast. -}-	getsock = multicastReceiver (multicastAddress IPv4AddrClass) pairingPort-		-	go reqs cache sock = liftIO (getmsg sock B.empty) >>= \msg -> case readish (BU8.toString msg) of-		Nothing -> go reqs cache sock-		Just m -> do-			debug ["received", show msg]-			(pip, verified) <- verificationCheck m-				=<< (pairingInProgress <$> getDaemonStatus)-			let wrongstage = maybe False (\p -> pairMsgStage m <= inProgressPairStage p) pip-			let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip-			case (wrongstage, fromus, checkSane (pairMsgData m), pairMsgStage m) of-				(_, True, _, _) -> do-					debug ["ignoring message that looped back"]-					go reqs cache sock-				(_, _, False, _) -> do-					liftAnnex $ warning $ UnquotedString $-						"illegal control characters in pairing message; ignoring (" ++ show (pairMsgData m) ++ ")"-					go reqs cache sock-				-- PairReq starts a pairing process, so a-				-- new one is always heeded, even if-				-- some other pairing is in process.-				(_, _, _, PairReq) -> if m `elem` reqs-					then go reqs (invalidateCache m cache) sock-					else do-						pairReqReceived verified urlrenderer m-						go (m:take 10 reqs) (invalidateCache m cache) sock-				(True, _, _, _) -> do-					debug-						["ignoring out of order message"-						, show (pairMsgStage m)-						, "expected"-						, show (succ . inProgressPairStage <$> pip)-						]-					go reqs cache sock-				(_, _, _, PairAck) -> do-					cache' <- pairAckReceived verified pip m cache-					go reqs cache' sock-				(_,_ , _, PairDone) -> do-					pairDoneReceived verified pip m-					go reqs cache sock--	{- As well as verifying the message using the shared secret,-	 - check its UUID against the UUID we have stored. If-	 - they're the same, someone is sending bogus messages,-	 - which could be an attempt to brute force the shared secret. -}-	verificationCheck _ Nothing = return (Nothing, False)-	verificationCheck m (Just pip)-		| not verified && sameuuid = do-			liftAnnex $ warning-				"detected possible pairing brute force attempt; disabled pairing"-			stopSending pip-			return (Nothing, False)-		| otherwise = return (Just pip, verified && sameuuid)-	  where-		verified = verifiedPairMsg m pip-		sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)--	{- PairReqs invalidate the cache of recently finished pairings.-	 - This is so that, if a new pairing is started with the-	 - same secret used before, a bogus PairDone is not sent. -}-	invalidateCache msg = filter (not . verifiedPairMsg msg)--	getmsg sock c = do-		(msg, _) <- B.recvFrom sock chunksz-		if B.length msg < chunksz-			then return $ c <> msg-			else getmsg sock $ c <> msg-	  where-		chunksz = 1024--{- Show an alert when a PairReq is seen. -}-pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()-pairReqReceived True _ _ = noop -- ignore our own PairReq-pairReqReceived False urlrenderer msg = do-	button <- mkAlertButton True (T.pack "Respond") urlrenderer (FinishLocalPairR msg)-	void $ addAlert $ pairRequestReceivedAlert repo button-  where-	repo = pairRepo msg--{- When a verified PairAck is seen, a host is ready to pair with us, and has- - already configured our ssh key. Stop sending PairReqs, finish the pairing,- - and send a single PairDone. -}-pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]-pairAckReceived True (Just pip) msg cache = do-	stopSending pip-	repodir <- repoPath <$> liftAnnex gitRepo-	liftIO $ setupAuthorizedKeys msg repodir-	finishedLocalPairing msg (inProgressSshKeyPair pip)-	startSending pip PairDone $ multicastPairMsg-		(Just 1) (inProgressSecret pip) (inProgressPairData pip)-	return $ pip : take 10 cache-{- A stale PairAck might also be seen, after we've finished pairing.- - Perhaps our PairDone was not received. To handle this, we keep- - a cache of recently finished pairings, and re-send PairDone in- - response to stale PairAcks for them. -}-pairAckReceived _ _ msg cache = do-	let pips = filter (verifiedPairMsg msg) cache-	unless (null pips) $-		forM_ pips $ \pip ->-			startSending pip PairDone $ multicastPairMsg-				(Just 1) (inProgressSecret pip) (inProgressPairData pip)-	return cache--{- If we get a verified PairDone, the host has accepted our PairAck, and- - has paired with us. Stop sending PairAcks, and finish pairing with them.- -- - TODO: Should third-party hosts remove their pair request alert when they- - see a PairDone?- - Complication: The user could have already clicked on the alert and be- - entering the secret. Would be better to start a fresh pair request in this- - situation.- -}-pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant ()-pairDoneReceived False _ _ = noop -- not verified-pairDoneReceived True Nothing _ = noop -- not in progress-pairDoneReceived True (Just pip) msg = do-	stopSending pip-	finishedLocalPairing msg (inProgressSshKeyPair pip)

@@ -21,7 +21,6 @@ import Types.StandardGroups import Creds import Assistant.Gpg-import Git.Types (RemoteName) import Annex.SpecialRemote.Config import Types.ProposedAccepted 

@@ -6,25 +6,13 @@  -}  {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}-{-# LANGUAGE CPP #-}  module Assistant.WebApp.Configurators.Pairing where -import Assistant.Pairing import Assistant.WebApp.Common-import Annex.UUID-#ifdef WITH_PAIRING-import Assistant.DaemonStatus-import Assistant.Pairing.MakeRemote-import Assistant.Pairing.Network-import Assistant.Ssh-import Utility.Verifiable-#endif-import Utility.UserInfo import Utility.Tor import Utility.Su import Assistant.WebApp.Pairing-import Assistant.Alert import qualified Utility.MagicWormhole as Wormhole import Assistant.MakeRemote import Assistant.RemoteControl@@ -32,19 +20,11 @@ import Assistant.WebApp.SideBar import Command.P2P (unusedPeerRemoteName, PairingResult(..)) import P2P.Address-import Git import Annex.Path import Utility.Process.Transcript  import qualified Data.Map as M import qualified Data.Text as T-#ifdef WITH_PAIRING-import qualified Data.Text.Encoding as T-import qualified Data.ByteString as B-import Data.Char-import qualified Control.Exception as E-import Control.Concurrent-#endif import Control.Concurrent.STM hiding (check)  getStartWormholePairFriendR :: Handler Html@@ -151,171 +131,5 @@ 		$(widgetFile "configurators/needmagicwormhole") 	) -{- Starts local pairing. -}-getStartLocalPairR :: Handler Html-getStartLocalPairR = postStartLocalPairR-postStartLocalPairR :: Handler Html-#ifdef WITH_PAIRING-postStartLocalPairR = promptSecret Nothing $-	startLocalPairing PairReq noop pairingAlert Nothing-#else-postStartLocalPairR = noLocalPairing--noLocalPairing :: Handler Html-noLocalPairing = noPairing "local"-#endif--{- Runs on the system that responds to a local pair request; sets up the ssh- - authorized key first so that the originating host can immediately sync- - with us. -}-getFinishLocalPairR :: PairMsg -> Handler Html-getFinishLocalPairR = postFinishLocalPairR-postFinishLocalPairR :: PairMsg -> Handler Html-#ifdef WITH_PAIRING-postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do-	repodir <- liftH $ repoPath <$> liftAnnex gitRepo-	liftIO $ setup repodir-	startLocalPairing PairAck (cleanup repodir) alert uuid "" secret-  where-	alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just-	setup repodir = setupAuthorizedKeys msg repodir-	cleanup repodir = removeAuthorizedKeys True repodir $-		remoteSshPubKey $ pairMsgData msg-	uuid = Just $ pairUUID $ pairMsgData msg-#else-postFinishLocalPairR _ = noLocalPairing-#endif--getRunningLocalPairR :: SecretReminder -> Handler Html-#ifdef WITH_PAIRING-getRunningLocalPairR s = pairPage $ do-	let secret = fromSecretReminder s-	$(widgetFile "configurators/pairing/local/inprogress")-#else-getRunningLocalPairR _ = noLocalPairing-#endif--#ifdef WITH_PAIRING--{- Starts local pairing, at either the PairReq (initiating host) or - - PairAck (responding host) stage.- -- - Displays an alert, and starts a thread sending the pairing message,- - which will continue running until the other host responds, or until- - canceled by the user. If canceled by the user, runs the oncancel action.- -- - Redirects to the pairing in progress page.- -}-startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget-startLocalPairing stage oncancel alert muuid displaysecret secret = do-	urlrender <- liftH getUrlRender-	reldir <- fromJust . relDir <$> liftH getYesod--	sendrequests <- liftAssistant $ asIO2 $ mksendrequests urlrender-	{- Generating a ssh key pair can take a while, so do it in the-	 - background. -}-	thread <- liftAssistant $ asIO $ do-		keypair <- liftIO $ genSshKeyPair-		let pubkey = either giveup id $ validateSshPubKey $ sshPubKey keypair-		pairdata <- liftIO $ PairData-			<$> getHostname-			<*> (either giveup id <$> myUserName)-			<*> pure reldir-			<*> pure pubkey-			<*> (maybe genUUID return muuid)-		let sender = multicastPairMsg Nothing secret pairdata-		let pip = PairingInProgress secret Nothing keypair pairdata stage-		startSending pip stage $ sendrequests sender-	void $ liftIO $ forkIO thread--	liftH $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret-  where-	{- Sends pairing messages until the thread is killed,-	 - and shows an activity alert while doing it.-	 --	 - The cancel button returns the user to the DashboardR. This is-	 - not ideal, but they have to be sent somewhere, and could-	 - have been on a page specific to the in-process pairing-	 - that just stopped, so can't go back there.-	 -}-	mksendrequests urlrender sender _stage = do-		tid <- liftIO myThreadId-		let selfdestruct = AlertButton-			{ buttonLabel = "Cancel"-			, buttonPrimary = True-			, buttonUrl = urlrender DashboardR-			, buttonAction = Just $ const $ do-				oncancel-				killThread tid-			}-		alertDuring (alert selfdestruct) $ liftIO $ do-			_ <- E.try (sender stage) :: IO (Either E.SomeException ())-			return ()--data InputSecret = InputSecret { secretText :: Maybe Text }--{- If a PairMsg is passed in, ensures that the user enters a secret- - that can validate it. -}-promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html-promptSecret msg cont = pairPage $ do-	((result, form), enctype) <- liftH $-		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $-			InputSecret <$> aopt textField (bfs "Secret phrase") Nothing-	case result of-		FormSuccess v -> do-			let rawsecret = fromMaybe "" $ secretText v-			let secret = toSecret rawsecret-			case msg of-				Nothing -> case secretProblem secret of-					Nothing -> cont rawsecret secret-					Just problem ->-						showform form enctype $ Just problem-				Just m ->-					if verify (fromPairMsg m) secret-						then cont rawsecret secret-						else showform form enctype $ Just-							"That's not the right secret phrase."-		_ -> showform form enctype Nothing-  where-	showform form enctype mproblem = do-		let start = isNothing msg-		let badphrase = isJust mproblem-		let problem = fromMaybe "" mproblem-		let (username, hostname) = maybe ("", "")-			(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v)))-			(verifiableVal . fromPairMsg <$> msg)-		u <- liftIO myUserName-		let sameusername = Right username == (T.pack <$> u)-		$(widgetFile "configurators/pairing/local/prompt")--{- This counts unicode characters as more than one character,- - but that's ok; they *do* provide additional entropy. -}-secretProblem :: Secret -> Maybe Text-secretProblem s-	| B.null s = Just "The secret phrase cannot be left empty. (Remember that punctuation and white space is ignored.)"-	| B.length s < 6 = Just "Enter a longer secret phrase, at least 6 characters, but really, a phrase is best! This is not a password you'll need to enter every day."-	| s == toSecret sampleQuote = Just "Speaking of foolishness, don't paste in the example I gave. Enter a different phrase, please!"-	| otherwise = Nothing--toSecret :: Text -> Secret-toSecret s = T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s--{- From Dickens -}-sampleQuote :: Text-sampleQuote = T.unwords-	[ "It was the best of times,"-	, "it was the worst of times,"-	, "it was the age of wisdom,"-	, "it was the age of foolishness."-	]--#else--#endif- pairPage :: Widget -> Handler Html pairPage = page "Pairing" (Just Configuration)--noPairing :: Text -> Handler Html-noPairing pairingtype = pairPage $-	$(widgetFile "configurators/pairing/disabled")

@@ -21,7 +21,7 @@ import Utility.Gpg import Types.Remote (RemoteConfig) import Types.ProposedAccepted-import Git.Types (RemoteName, fromRef, fromConfigKey)+import Git.Types (fromRef, fromConfigKey) import qualified Remote.GCrypt as GCrypt import qualified Annex import qualified Git.Command

@@ -17,7 +17,6 @@ import Types.Remote (RemoteConfig, config) import Types.StandardGroups import Logs.Remote-import Git.Types (RemoteName) import Assistant.Gpg import Types.GitConfig import Annex.SpecialRemote.Config

@@ -19,7 +19,6 @@ import qualified Annex.Branch import qualified Git.GCrypt import qualified Remote.GCrypt as GCrypt-import Git.Types (RemoteName) import Assistant.WebApp.MakeRemote import Annex.SpecialRemote.Config import Logs.Remote

@@ -18,7 +18,6 @@ import qualified Config import Config.Cost import Types.StandardGroups-import Git.Types (RemoteName) import Logs.PreferredContent import Assistant.MakeRemote 

@@ -12,7 +12,6 @@ import Command.P2P (wormholePairing, PairingResult(..)) import P2P.Address import Annex.Concurrent-import Git.Types  import Control.Concurrent import Control.Concurrent.Async

@@ -8,7 +8,6 @@ module Assistant.WebApp.RepoId where  import Annex.Common-import Git.Types (RemoteName) import qualified Remote  {- Parts of the webapp need to be able to act on repositories that may or

@@ -56,10 +56,6 @@ /config/repository/add/cloud/IA AddIAR GET POST /config/repository/add/cloud/glacier AddGlacierR GET POST -/config/repository/pair/local/start StartLocalPairR GET POST-/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET-/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST- /config/repository/pair/wormhole/start/self StartWormholePairSelfR GET /config/repository/pair/wormhole/start/friend StartWormholePairFriendR GET /config/repository/pair/wormhole/prepare/#PairingWith PrepareWormholePairR GET

@@ -26,11 +26,6 @@ #else #warning Building without the webapp. #endif-#ifdef WITH_PAIRING-	, "Pairing"-#else-#warning Building without local pairing.-#endif #ifdef WITH_INOTIFY 	, "Inotify" #endif@@ -80,7 +75,6 @@ 	, ("uuid", VERSION_uuid) 	, ("bloomfilter", VERSION_bloomfilter) 	, ("http-client", VERSION_http_client)-	, ("persistent-sqlite", VERSION_persistent_sqlite) 	, ("crypton", VERSION_crypton) 	, ("aws", VERSION_aws) 	, ("DAV", VERSION_DAV)

@@ -1,3 +1,27 @@+git-annex (10.20260115) upstream; urgency=medium++  * New git configs annex.initwanted, annex.initrequired, and+    annex.initgroups.+  * Fix bug that could result in a tree imported from a remote containing+    missing git blobs.+  * fix: Populate unlocked pointer files in situations where a git command,+    like git reset or git stash, leaves them unpopulated.+  * Pass www-authenticate headers in to to git credential, to support+    eg, git-credential-oauth.+  * import: Fix display of some import errors.+  * external: Respond to GETGITREMOTENAME during INITREMOTE with the remote+    name.+  * When displaying sqlite error messages, include the path to the database.+  * webapp: Remove support for local pairing; use wormhole pairing instead.+  * git-annex.cabal: Removed pairing build flag, and no longer depends+    on network-multicast or network-info.+  * Remove support for building with old versions of persistent and +    persistent-sqlite.+  * Removed support for building with ghc older than 9.6.6.+  * stack.yaml: Update to lts-24.26.++ -- Joey Hess <id@joeyh.name>  Fri, 16 Jan 2026 11:09:14 -0400+ git-annex (10.20251215) upstream; urgency=medium    * Added annex.trashbin configuration.

@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2025 Joey Hess <id@joeyh.name>+Copyright: © 2010-2026 Joey Hess <id@joeyh.name> License: AGPL-3+  Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*

@@ -598,8 +598,8 @@ 			specialRemoteConfig cfg 		t <- either giveup return (SpecialRemote.findType c) 		dummycfg <- liftIO dummyRemoteGitConfig-		(c', u) <- Remote.setup t (Remote.Enable c) (Just (specialRemoteUUID cfg)) -			Nothing c dummycfg+		(c', u) <- Remote.setup t (Remote.Enable c) (Just (specialRemoteUUID cfg))+			remotename Nothing c dummycfg 			`onException` cleanupremote remotename 		Logs.Remote.configSet u c' 		setConfig (remoteConfig c' "url") (specialRemoteUrl cfg)

@@ -55,7 +55,7 @@ startSpecialRemote = startSpecialRemote' "configremote" . performSpecialRemote  performSpecialRemote :: Annex () -> PerformSpecialRemote-performSpecialRemote precheck _ u _ c _ mcu = do+performSpecialRemote precheck _ u _ _ c _ mcu = do 	precheck 	case mcu of 		Nothing -> Logs.Remote.configSet u c

@@ -12,7 +12,6 @@ import Command.Trust (trustCommand) import Logs.Location import Remote (keyLocations)-import Git.Types  cmd :: Command cmd = withAnnexOptions [jsonOptions] $

@@ -14,7 +14,6 @@ import qualified Logs.Remote import qualified Types.Remote as R import qualified Git-import qualified Git.Types as Git import qualified Annex.SpecialRemote as SpecialRemote import qualified Remote import qualified Types.Remote as Remote@@ -75,7 +74,7 @@  -- enableremote of a normal git remote with no added parameters is a special case -- that retries probing the remote uuid.-startNormalRemote :: Git.RemoteName -> Git.Repo -> CommandStart+startNormalRemote :: RemoteName -> Git.Repo -> CommandStart startNormalRemote name r = starting "enableremote (normal)" ai si $ do 	setRemoteIgnore r False 	r' <- Remote.Git.configRead False r@@ -85,12 +84,12 @@ 	ai = ActionItemOther (Just (UnquotedString name)) 	si = SeekInput [name] -startSpecialRemote :: EnableRemoteOptions -> Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart+startSpecialRemote :: EnableRemoteOptions -> RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart startSpecialRemote o = startSpecialRemote' "enableremote" (performSpecialRemote o) -type PerformSpecialRemote = RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform+type PerformSpecialRemote = RemoteType -> UUID -> RemoteName -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform -startSpecialRemote' :: String -> PerformSpecialRemote -> Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart+startSpecialRemote' :: String -> PerformSpecialRemote -> RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart startSpecialRemote' cname perform name config [] = do 	m <- SpecialRemote.specialRemoteMap 	confm <- Logs.Remote.remoteConfigMap@@ -110,7 +109,7 @@ 		gc <- maybe (liftIO dummyRemoteGitConfig)  			(return . Remote.gitconfig) 			=<< Remote.byUUID u-		perform t u c fullconfig gc mcu+		perform t u name c fullconfig gc mcu   where 	ai = ActionItemOther (Just (UnquotedString name)) 	si = SeekInput [name]@@ -118,18 +117,15 @@ 	giveup "Multiple remotes have that name. Either use git-annex renameremote to rename them, or specify the uuid of the remote."  performSpecialRemote :: EnableRemoteOptions -> PerformSpecialRemote-performSpecialRemote o t u oldc c gc mcu = do+performSpecialRemote o t u name oldc c gc mcu = do 	-- Avoid enabling a special remote if there is another remote 	-- with the same name.-	case SpecialRemote.lookupName c of-		Nothing -> noop-		Just name -> do-			rs <- Remote.remoteList-			case filter (\rmt -> Remote.name rmt == name) rs of-				(rmt:_) | Remote.uuid rmt /= u ->-					giveup $ "Not overwriting currently configured git remote named \"" ++ name ++ "\""-				_ -> noop-	(c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc+	rs <- Remote.remoteList+	case filter (\rmt -> Remote.name rmt == name) rs of+		(rmt:_) | Remote.uuid rmt /= u ->+			giveup $ "Not overwriting currently configured git remote named \"" ++ name ++ "\""+		_ -> noop+	(c', u') <- R.setup t (R.Enable oldc) (Just u) name Nothing c gc 	next $ cleanupSpecialRemote o t u' c' mcu  cleanupSpecialRemote :: EnableRemoteOptions -> RemoteType -> UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup@@ -174,7 +170,7 @@  -- Use dead remote only when there is no other remote -- with the same name-deadLast :: Git.RemoteName -> ([(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> Annex a) -> Annex a+deadLast :: RemoteName -> ([(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> Annex a) -> Annex a deadLast name use = 	SpecialRemote.findExisting' name >>= \case 		([], l) -> use l

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -14,6 +14,7 @@ import qualified Annex import Annex.ReplaceFile import Annex.Content+import Annex.Content.PointerFile import Annex.Perms import Annex.Link import qualified Database.Keys@@ -28,7 +29,7 @@ cmd :: Command cmd = noCommit $ withAnnexOptions [annexedMatchingOptions, jsonOptions] $ 	command "fix" SectionMaintenance-		"fix up links to annexed content"+		"fix up pointers to annexed content" 		paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek@@ -54,11 +55,20 @@ 				fixby $ fixSymlink file wantlink 			| otherwise -> stop 		Nothing -> case fixwhat of-			FixAll -> fixthin+			FixAll -> fixpointers 			FixSymlinks -> stop   where 	file' = fromOsPath file+ 	fixby = starting "fix" (mkActionItem (key, file)) si++	fixpointers =+		ifM (isJust <$> liftIO (isPointerFile file))+			( stopUnless (inAnnex key) $ +				fixby $ fixPointerFile key file+			, fixthin+			)+ 	fixthin = do 		obj <- calcRepo (gitAnnexLocation key) 		stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do@@ -110,3 +120,11 @@ 	next $ return True   where 	link' = fromOsPath link++fixPointerFile :: Key -> OsPath -> CommandPerform+fixPointerFile key file = do+	obj <- calcRepo (gitAnnexLocation key)+	populatePointerFile' QueueRestage key obj file >>= \case+		Just ic -> Database.Keys.addInodeCaches key [ic]+		Nothing -> giveup "not enough disk space to populate pointer file"+	next $ return True

@@ -15,7 +15,6 @@ import Logs.UUID import Config import Annex.UUID-import Git.Types import Git.Remote (isLegalName)  import qualified Data.Map as M

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -22,6 +22,7 @@ import Config import Git.Config import Git.Types+import Annex.Init  import qualified Data.Map as M import qualified Data.Text as T@@ -103,13 +104,13 @@ 	si = SeekInput (name:ws) 	ai = ActionItemOther (Just (UnquotedString name)) -perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform+perform :: RemoteType -> RemoteName -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform perform t name c o = do 	when (privateRemote o) $ 		setConfig (remoteAnnexConfig c "private") (boolConfig True) 	dummycfg <- liftIO dummyRemoteGitConfig 	let c' = M.delete uuidField c-	(c'', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) Nothing c' dummycfg+	(c'', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) name Nothing c' dummycfg 	next $ cleanup t u name c'' o   where 	uuidfromuser = case fromProposedAccepted <$> M.lookup uuidField c of@@ -122,11 +123,12 @@ uuidField :: R.RemoteConfigField uuidField = Accepted "uuid" -cleanup :: RemoteType -> UUID -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup+cleanup :: RemoteType -> UUID -> RemoteName -> R.RemoteConfig -> InitRemoteOptions -> CommandCleanup cleanup t u name c o = do 	case sameas o of 		Nothing -> do 			describeUUID u (toUUIDDesc name)+			propigateInitGitConfigs u 			Logs.Remote.configSet u c 		Just _ -> do 			cu <- liftIO genUUID

@@ -22,7 +22,6 @@ import Logs.Trust import Logs.UUID import Annex.UUID-import Git.Types (RemoteName) import Utility.Tuple import Utility.SafeOutput 

@@ -11,7 +11,6 @@ import Logs.Web import Command.FromKey (keyOpt, keyOpt') import qualified Remote-import Git.Types  cmd :: Command cmd = withAnnexOptions [jsonOptions] $ command "reregisterurl"

@@ -31,7 +31,6 @@ import Annex.SpecialRemote.Config (exportTreeField) import Remote.Helper.Chunked import Remote.Helper.Encryptable (encryptionField, highRandomQualityField)-import Git.Types import qualified Utility.FileIO as F import Remote.List 

@@ -18,7 +18,6 @@ import Annex.Transfer import qualified Remote import Utility.SimpleProtocol (dupIoHandles)-import Git.Types (RemoteName) import qualified Database.Keys import Annex.BranchState 

@@ -5,7 +5,6 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TypeOperators, TemplateHaskell #-} {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}@@ -35,7 +34,6 @@ 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@@ -50,13 +48,7 @@  import Database.Persist.Sql hiding (Key) import Database.Persist.TH--#if MIN_VERSION_persistent_sqlite(2,13,3) import Database.RawFilePath-#else-import Database.Persist.Sqlite (runSqlite)-import qualified Data.Text as T-#endif  data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue Bool @@ -103,13 +95,8 @@ 			runMigrationSilent migrateContentIdentifier 		-- Migrate from old versions of database, which had buggy 		-- and suboptimal uniqueness constraints.-#if MIN_VERSION_persistent_sqlite(2,13,3) 		else liftIO $ runSqlite' (fromOsPath db) $ void $ 			runMigrationSilent migrateContentIdentifier-#else-		else liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $-			runMigrationSilent migrateContentIdentifier-#endif 	h <- liftIO $ H.openDbQueue db "content_identifiers" 	return $ ContentIdentifierHandle h isnew @@ -130,7 +117,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 $ insertUniqueFast $ ContentIdentifiers u cid k+	void $ insertUnique_ $ ContentIdentifiers u cid k  getContentIdentifiers :: ContentIdentifierHandle -> RemoteStateHandle -> Key -> IO [ContentIdentifier] getContentIdentifiers (ContentIdentifierHandle h _) (RemoteStateHandle u) k = @@ -153,7 +140,7 @@ recordAnnexBranchTree :: ContentIdentifierHandle -> Sha -> IO () recordAnnexBranchTree h s = queueDb h $ do 	deleteWhere ([] :: [Filter AnnexBranch])-	void $ insertUniqueFast $ AnnexBranch $ toSSha s+	void $ insertUnique_ $ AnnexBranch $ toSSha s  getAnnexBranchTree :: ContentIdentifierHandle -> IO Sha getAnnexBranchTree (ContentIdentifierHandle h _) = H.queryDbQueue h $ do

@@ -46,7 +46,6 @@ 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@@ -120,7 +119,7 @@ recordExportTreeCurrent :: ExportHandle -> Sha -> IO () recordExportTreeCurrent h s = queueDb h $ do 	deleteWhere ([] :: [Filter ExportTreeCurrent])-	void $ insertUniqueFast $ ExportTreeCurrent $ toSSha s+	void $ insertUnique_ $ ExportTreeCurrent $ toSSha s  getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha) getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do@@ -132,7 +131,7 @@  addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () addExportedLocation h k el = queueDb h $ do-	void $ insertUniqueFast $ Exported k ef+	void $ insertUnique_ $ Exported k ef 	let edirs = map 		(\ed -> ExportedDirectory (SByteString (fromOsPath (fromExportDirectory ed))) ef) 		(exportDirectories el)@@ -183,7 +182,7 @@  addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $-	void $ insertUniqueFast $ ExportTree k ef+	void $ insertUnique_ $ ExportTree k ef   where 	ef = SByteString (fromOsPath (fromExportLocation loc)) 

@@ -27,7 +27,6 @@  import Database.Types import qualified Database.Queue as H-import Database.Utility import Database.Init import Annex.Locations import Utility.Exception@@ -85,7 +84,7 @@  addDb :: FsckHandle -> Key -> IO () addDb (FsckHandle h _) k = H.queueDb h checkcommit $-	void $ insertUniqueFast $ Fscked k+	void $ insertUnique_ $ 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

@@ -1,6 +1,6 @@ {- Persistent sqlite database handles.  -- - Copyright 2015-2023 Joey Hess <id@joeyh.name>+ - Copyright 2015-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -24,6 +24,7 @@ import Utility.DebugLocks import Utility.InodeCache import Utility.OsPath+import Utility.SafeOutput  import Database.Persist.Sqlite import qualified Database.Sqlite as Sqlite@@ -78,7 +79,7 @@  - it is able to run.  -} queryDb :: DbHandle -> SqlPersistM a -> IO a-queryDb (DbHandle _db _ jobs errvar) a = do+queryDb (DbHandle db _ jobs errvar) a = do 	res <- newEmptyMVar 	putMVar jobs $ QueryJob $ 		debugLocks $ liftIO . putMVar res =<< tryNonAsync a@@ -86,7 +87,7 @@ 		Right r -> either throwIO return r 		Left BlockedIndefinitelyOnMVar -> do 			err <- takeMVar errvar-			giveup $ "sqlite worker thread crashed: " ++ err+			giveup $ "sqlite worker thread for " ++ fromOsPath (safeOutput db) ++ " crashed: " ++ err  {- Writes a change to the database.  -@@ -111,7 +112,7 @@ 					robustly a 			Left BlockedIndefinitelyOnMVar -> do 				err <- takeMVar errvar-				giveup $ "sqlite worker thread crashed: " ++ err+				giveup $ "sqlite worker thread for " ++ fromOsPath (safeOutput db) ++ " crashed: " ++ err 	 	briefdelay = 100000 -- 1/10th second @@ -191,14 +192,10 @@ 					briefdelay 					retryHelper "access" ex maxretries db retries ic $ 						go conn-				| otherwise -> rethrow $ errmsg "after successful open" ex+				| otherwise -> rethrow $ errmsg ("after successful sqlite database " ++ fromOsPath (safeOutput db) ++ " open") ex 	 	opensettle retries ic = do-#if MIN_VERSION_persistent_sqlite(2,13,3) 		conn <- Sqlite.open' (fromOsPath db)-#else-		conn <- Sqlite.open (T.pack (fromOsPath db))-#endif 		settle conn retries ic  	settle conn retries ic = do@@ -217,7 +214,7 @@ 						if e == Sqlite.ErrorIO 							then opensettle 							else settle conn-				| otherwise -> rethrow $ errmsg "while opening database connection" ex+				| otherwise -> rethrow $ errmsg ("while opening sqlite database " ++ fromOsPath (safeOutput db) ++ " connection") ex 	 	-- This should succeed for any table. 	nullselect = T.pack $ "SELECT null from " ++ tablename ++ " limit 1"@@ -274,7 +271,7 @@ 				| e == Sqlite.ErrorBusy -> do 					threadDelay briefdelay 					retryHelper "close" ex maxretries db retries ic go-				| otherwise -> rethrow $ errmsg "while closing database connection" ex+				| otherwise -> rethrow $ errmsg ("while closing sqlite database " ++ fromOsPath (safeOutput db) ++ " connection") ex 	 	briefdelay = 1000 -- 1/1000th second 	@@ -312,7 +309,7 @@  databaseAccessStalledMsg :: Show err => String -> OsPath -> err -> String databaseAccessStalledMsg action db err =-	"Repeatedly unable to " ++ action ++ " sqlite database " ++ fromOsPath db +	"Repeatedly unable to " ++ action ++ " sqlite database " ++ fromOsPath (safeOutput db) 		++ ": " ++ show err ++ ". " 		++ "Perhaps another git-annex process is suspended and is " 		++ "keeping this database locked?"

@@ -26,7 +26,6 @@ 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,16 +108,16 @@  recordKnownUrl :: ImportFeedDbHandle -> URLByteString -> IO () recordKnownUrl h u = queueDb h $-	void $ insertUniqueFast $ KnownUrls $ SByteString u+	void $ insertUnique_ $ KnownUrls $ SByteString u  recordKnownItemId :: ImportFeedDbHandle -> SByteString -> IO () recordKnownItemId h i = queueDb h $-	void $ insertUniqueFast $ KnownItemIds i+	void $ insertUnique_ $ KnownItemIds i  recordAnnexBranchTree :: ImportFeedDbHandle -> Sha -> IO () recordAnnexBranchTree h s = queueDb h $ do 	deleteWhere ([] :: [Filter AnnexBranch])-	void $ insertUniqueFast $ AnnexBranch $ toSSha s+	void $ insertUnique_ $ AnnexBranch $ toSSha s  getAnnexBranchTree :: ImportFeedDbHandle -> IO Sha getAnnexBranchTree (ImportFeedDbHandle h) = H.queryDbQueue h $ do

@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.Init where @@ -13,9 +13,7 @@ import Annex.Perms import Utility.FileMode import qualified Utility.RawFilePath as R-#if MIN_VERSION_persistent_sqlite(2,13,3) import Database.RawFilePath-#endif  import Database.Persist.Sqlite import Lens.Micro@@ -36,11 +34,7 @@ 	let tmpdb = tmpdbdir </> literalOsPath "db" 	let tmpdb' = fromOsPath tmpdb 	createAnnexDirectory tmpdbdir-#if MIN_VERSION_persistent_sqlite(2,13,3) 	liftIO $ runSqliteInfo' tmpdb' (enableWAL tmpdb) migration-#else-	liftIO $ runSqliteInfo (enableWAL tmpdb) migration-#endif 	setAnnexDirPerm tmpdbdir 	-- Work around sqlite bug that prevents it from honoring 	-- less restrictive umasks.

@@ -18,7 +18,6 @@  import Database.Types import Database.Handle-import Database.Utility import qualified Database.Queue as H import Utility.InodeCache import Git.FilePath@@ -120,7 +119,7 @@  addInodeCaches :: Key -> [InodeCache] -> WriteHandle -> IO () addInodeCaches k is = queueDb $-	forM_ is $ \i -> insertUniqueFast $ Content k i +	forM_ is $ \i -> insertUnique_ $ Content k i  		(inodeCacheToFileSize i) 		(inodeCacheToEpochTime i) 

@@ -31,11 +31,10 @@  - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -} -{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.RawFilePath where -#if MIN_VERSION_persistent_sqlite(2,13,3) import Database.Persist.Sqlite import qualified Database.Sqlite as Sqlite import Utility.RawFilePath (RawFilePath)@@ -92,4 +91,3 @@ 	-> (SqlBackend -> m a) 	-> m a withSqliteConnInfo' db = withSqlConn . openWith' db const-#endif

@@ -38,7 +38,6 @@ import Database.RepoSize.Handle import qualified Database.Handle as H import Database.Init-import Database.Utility import Database.Types import Annex.LockFile import Git.Types@@ -200,7 +199,7 @@ recordAnnexBranchCommit :: Sha -> SqlPersistM () recordAnnexBranchCommit branchcommitsha = do 	deleteWhere ([] :: [Filter AnnexBranch])-	void $ insertUniqueFast $ AnnexBranch $ toSSha branchcommitsha+	void $ insertUnique_ $ AnnexBranch $ toSSha branchcommitsha  startingLiveSizeChange :: RepoSizeHandle -> UUID -> Key -> SizeChange -> SizeChangeId -> IO () startingLiveSizeChange (RepoSizeHandle (Just h) _) u k sc cid = 

@@ -1,27 +0,0 @@-{- 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

@@ -1,6 +1,6 @@ {- git credential interface  -- - Copyright 2019-2022 Joey Hess <id@joeyh.name>+ - Copyright 2019-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -19,6 +19,8 @@  import qualified Data.Map as M import Network.URI+import Network.HTTP.Types+import Network.HTTP.Types.Header import Control.Concurrent.STM  data Credential = Credential { fromCredential :: M.Map String String }@@ -35,7 +37,7 @@ 	<*> credentialPassword cred  getBasicAuthFromCredential :: Repo -> TMVar CredentialCache -> GetBasicAuth-getBasicAuthFromCredential r ccv u = do+getBasicAuthFromCredential r ccv u respheaders = do 	(CredentialCache cc) <- atomically $ readTMVar ccv 	case mkCredentialBaseURL r u of 		Just bu -> case M.lookup bu cc of@@ -44,8 +46,8 @@ 				let storeincache = \c -> atomically $ do 					CredentialCache cc' <- takeTMVar ccv 					putTMVar ccv (CredentialCache (M.insert bu c cc'))-				go storeincache =<< getUrlCredential u r-		Nothing -> go (const noop) =<< getUrlCredential u r+				go storeincache =<< getUrlCredential u respheaders r+		Nothing -> go (const noop) =<< getUrlCredential u respheaders r   where 	go storeincache c = 		case credentialBasicAuth c of@@ -61,8 +63,9 @@  -- | This may prompt the user for the credential, or get a cached -- credential from git.-getUrlCredential :: URLString -> Repo -> IO Credential-getUrlCredential = runCredential "fill" . urlCredential+getUrlCredential :: URLString -> ResponseHeaders -> Repo -> IO Credential+getUrlCredential url respheaders = runCredential "fill" $ +	urlCredential url respheaders  -- | Call if the credential the user entered works, and can be cached for -- later use if git is configured to do so.@@ -73,8 +76,12 @@ rejectUrlCredential :: Credential -> Repo -> IO () rejectUrlCredential c = void . runCredential "reject" c -urlCredential :: URLString -> Credential-urlCredential = Credential . M.singleton "url"+urlCredential :: URLString -> ResponseHeaders -> Credential+urlCredential url respheaders = Credential $ M.fromList $+	("url", url) : map wwwauth (filter iswwwauth respheaders)+  where+	iswwwauth (h, _) = h == hWWWAuthenticate+	wwwauth (_, v) = ("wwwauth[]", decodeBS v)  runCredential :: String -> Credential -> Repo -> IO Credential runCredential action input r =

@@ -17,7 +17,6 @@ import Annex.Common import qualified Annex.Branch import qualified Git.Remote-import Git.Types import Logs import Logs.UUIDBased import Logs.MapLog

@@ -2,7 +2,7 @@  -  - https://git-annex.branchable.com/design/p2p_protocol_over_http/  -- - Copyright 2024 Joey Hess <id@joeyh.name>+ - Copyright 2024-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -35,7 +35,6 @@ import Annex.Concurrent import Utility.Url (BasicAuth(..)) import Utility.HumanTime-import Utility.STM import qualified Utility.FileIO as F import qualified Git.Credential as Git @@ -43,15 +42,17 @@ import Servant.Client.Streaming import qualified Servant.Types.SourceT as S import Network.HTTP.Types.Status-import Network.HTTP.Client+import Network.HTTP.Client hiding (responseHeaders) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Internal as LI import qualified Data.Map as M import Control.Concurrent.Async+import Control.Concurrent.STM import Control.Concurrent import System.IO.Unsafe import Data.Time.Clock.POSIX import qualified Data.ByteString.Lazy as L+import Data.Foldable (toList)  type ClientAction a 	= ClientEnv@@ -119,7 +120,7 @@ 					go clientenv mcred credcached mauth vs 				| statusCode (responseStatusCode resp) == 401 -> 					case mcred of-						Nothing -> authrequired clientenv (v:vs)+						Nothing -> authrequired clientenv resp (v:vs) 						Just cred -> do 							inRepo $ Git.rejectUrlCredential cred 							Just <$> fallback (showstatuscode resp)@@ -134,9 +135,10 @@  	catchclienterror a = a `catch` \(ex :: ClientError) -> pure (Left ex) -	authrequired clientenv vs = do+	authrequired clientenv resp vs = do+		let respheaders = toList $ responseHeaders resp 		cred <- prompt $ -			inRepo $ Git.getUrlCredential credentialbaseurl+			inRepo $ Git.getUrlCredential credentialbaseurl respheaders 		go clientenv (Just cred) False (credauth cred) vs  	showstatuscode resp = 

@@ -34,7 +34,6 @@ import Remote.List import Types.Direction import Utility.Metered-import Utility.STM  import Servant import qualified Servant.Types.SourceT as S@@ -42,6 +41,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as LI import Control.Concurrent.Async+import Control.Concurrent.STM import Control.Concurrent import System.IO.Unsafe import Data.Either

@@ -38,13 +38,13 @@ import Annex.Cluster import qualified P2P.Proxy as Proxy import qualified Types.Remote as Remote-import Utility.STM import Remote.List  import Servant import qualified Data.Map.Strict as M import qualified Data.Set as S import Control.Concurrent.Async+import Control.Concurrent.STM import Data.Time.Clock.POSIX  data P2PHttpServerState = P2PHttpServerState

@@ -11,7 +11,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE CPP #-}  module P2P.Http.Types where @@ -149,11 +148,7 @@  instance ToHttpApiData Auth where 	toHeader (Auth u p) = "Basic " <> B64.encode (u <> ":" <> p)-#if MIN_VERSION_text(2,0,0) 	toUrlPiece = TE.decodeUtf8Lenient . toHeader-#else-	toUrlPiece = TE.decodeUtf8With (\_ _ -> Just '\xfffd') . toHeader-#endif  instance FromHttpApiData Auth where 	parseHeader h =

@@ -85,7 +85,7 @@ import Remote.List.Util import Config import Config.DynamicConfig-import Git.Types (RemoteName, ConfigKey(..), fromConfigValue)+import Git.Types (ConfigKey(..), fromConfigValue) import Utility.Aeson  {- Map from UUIDs of Remotes to a calculated value. -}

@@ -139,8 +139,8 @@ 	serial = maybe (giveup "missing androidserial") AndroidSerial 		(remoteAnnexAndroidSerial gc) -adbSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-adbSetup ss mu _ c gc = do+adbSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+adbSetup ss mu _ _ c gc = do 	u <- maybe (liftIO genUUID) return mu  	-- verify configuration

@@ -133,8 +133,8 @@ 		BorgRepo 		(remoteAnnexBorgRepo gc) -borgSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-borgSetup _ mu _ c _gc = do+borgSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+borgSetup _ mu _ _ c _gc = do 	u <- maybe (liftIO genUUID) return mu  	-- verify configuration is sane

@@ -123,8 +123,8 @@   where 	buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc -bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-bupSetup ss mu _ c gc = do+bupSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+bupSetup ss mu _ _ c gc = do 	u <- maybe (liftIO genUUID) return mu  	-- verify configuration is sane

@@ -139,8 +139,8 @@ 		, remoteStateHandle = rs 		} -setupInstance :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-setupInstance ss mu _ c _ = do+setupInstance :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+setupInstance ss mu _ _ c _ = do 	ComputeProgram program <- either giveup return $ getComputeProgram' c 	allowedprograms <- maybe [] words . annexAllowedComputePrograms 		<$> Annex.getGitConfig

@@ -114,8 +114,8 @@ 		} 	ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc) -ddarSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-ddarSetup ss mu _ c gc = do+ddarSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+ddarSetup ss mu _ _ c gc = do 	u <- maybe (liftIO genUUID) return mu  	-- verify configuration is sane

@@ -150,8 +150,8 @@ 	dir' = fromMaybe (giveup "missing directory") 		(remoteAnnexDirectory gc) -directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-directorySetup ss mu _ c gc = do+directorySetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+directorySetup ss mu _ _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	-- verify configuration is sane 	let dir = maybe (giveup "Specify directory=") fromProposedAccepted $

@@ -1,6 +1,6 @@ {- External special remote interface.  -- - Copyright 2013-2025 Joey Hess <id@joeyh.name>+ - Copyright 2013-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -171,8 +171,8 @@ 			fromMaybe (giveup "missing externaltype") 				(remoteAnnexExternalType gc) -externalSetup :: Maybe ExternalProgram -> Maybe (String, String) -> SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-externalSetup externalprogram setgitconfig ss mu _ c gc = do+externalSetup :: Maybe ExternalProgram -> Maybe (String, String) -> SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+externalSetup externalprogram setgitconfig ss mu remotename _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	pc <- either giveup return $ parseRemoteConfig c (lenientRemoteConfigParser externalprogram) 	let readonlyconfig = getRemoteConfigValue readonlyField pc == Just True@@ -193,7 +193,7 @@ 		else do 			pc' <- either giveup return $ parseRemoteConfig c' (lenientRemoteConfigParser externalprogram) 			let p = fromMaybe (ExternalType externaltype) externalprogram-			external <- newExternal p (Just u) pc' (Just gc) Nothing Nothing+			external <- newExternal p (Just u) pc' (Just gc) (Just remotename) Nothing 			-- Now that we have an external, ask it to LISTCONFIGS,  			-- and re-parse the RemoteConfig strictly, so we can 			-- error out if the user provided an unexpected config.@@ -953,3 +953,4 @@   where 	isproposed (Accepted _) = False 	isproposed (Proposed _) = True+

@@ -52,7 +52,6 @@ import Types.Export import Types.Availability (Availability(..)) import Types.Key-import Git.Types import Utility.Url (URLString) import Utility.Url.Parse import qualified Utility.SimpleProtocol as Proto

@@ -219,8 +219,8 @@ unsupportedUrl :: a unsupportedUrl = giveup "unsupported repo url for gcrypt" -gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-gCryptSetup ss mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c+gCryptSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+gCryptSetup ss mu _ _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c   where 	remotename = fromJust (lookupName c) 	go Nothing = giveup "Specify gitrepo="

@@ -141,8 +141,8 @@  - No attempt is made to make the remote be accessible via ssh key setup,  - etc.  -}-gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-gitSetup Init mu _ c gc = do+gitSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+gitSetup Init mu _ _ c gc = do 	let location = maybe (giveup "Specify location=url") fromProposedAccepted $ 		M.lookup locationField c 	r <- inRepo $ Git.Construct.fromRemoteLocation location False@@ -153,8 +153,8 @@ 		else if isNothing mu || mu == Just u 			then enableRemote (Just u) c 			else giveup "git repository does not have specified uuid"-gitSetup (Enable _) mu _ c _ = enableRemote mu c-gitSetup (AutoEnable _) mu _ c _ = enableRemote mu c+gitSetup (Enable _) mu _ _ c _ = enableRemote mu c+gitSetup (AutoEnable _) mu _ _ c _ = enableRemote mu c  enableRemote :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) enableRemote (Just u) c = do

@@ -144,8 +144,8 @@ 		, remoteStateHandle = rs 		} -mySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-mySetup ss mu _ c gc = do+mySetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+mySetup ss mu _ _ c gc = do 	u <- maybe (liftIO genUUID) return mu  	(c', _encsetup) <- encryptionSetup ss c gc@@ -316,7 +316,10 @@ 			resp <- makeSmallAPIRequest testreq 			if needauth (responseStatus resp) 				then do-					cred <- prompt $ inRepo $ Git.getUrlCredential (show lfsrepouri)+					cred <- prompt $ inRepo $+						Git.getUrlCredential+							(show lfsrepouri)+							(responseHeaders resp) 					let endpoint' = addbasicauth (Git.credentialBasicAuth cred) endpoint 					let testreq' = LFS.startTransferRequest endpoint' transfernothing 					flip catchNonAsync (const (returnendpoint endpoint')) $ do

@@ -118,8 +118,8 @@ 			{ chunkConfig = NoChunks 			} -glacierSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-glacierSetup ss mu mcreds c gc = do+glacierSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+glacierSetup ss mu _ mcreds c gc = do 	u <- maybe (liftIO genUUID) return mu 	glacierSetup' ss u mcreds c gc glacierSetup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)

@@ -79,7 +79,7 @@ adjustExportImportRemoteType :: RemoteType -> RemoteType adjustExportImportRemoteType rt = rt { setup = setup' }   where-	setup' st mu cp c gc = do+	setup' st mu remotename cp c gc = do 		pc <- either giveup return . parseRemoteConfig c 			=<< configParser rt c 		let checkconfig supported configured configfield cont =@@ -97,7 +97,7 @@ 				) 		checkconfig exportSupported exportTree exportTreeField $ 			checkconfig importSupported importTree importTreeField $-				setup rt st mu cp c gc+				setup rt st mu remotename cp c gc 	 	enable oldc pc configured configfield cont = do 		oldpc <- parsedRemoteConfig rt oldc

@@ -96,8 +96,8 @@   where 	hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc -hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-hookSetup ss mu _ c gc = do+hookSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+hookSetup ss mu _ _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	let hooktype = maybe (giveup "Specify hooktype=") fromProposedAccepted $ 		M.lookup hooktypeField c

@@ -108,10 +108,10 @@ cannotModify :: a cannotModify = giveup "httpalso special remote is read only" -httpAlsoSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-httpAlsoSetup _ Nothing _ _ _ =+httpAlsoSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+httpAlsoSetup _ Nothing _ _ _ _ = 	giveup "Must use --sameas when initializing a httpalso remote."-httpAlsoSetup ss (Just u) _ c gc = do+httpAlsoSetup ss (Just u) _ _ c gc = do 	_url <- maybe (giveup "Specify url=") 		(return . fromProposedAccepted) 		(M.lookup urlField c)

@@ -89,8 +89,8 @@ 		(checkKey maskedremote) 		this -maskSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-maskSetup setupstage mu _ c gc = do+maskSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+maskSetup setupstage mu _ _ c gc = do 	remotelist <- Annex.getState Annex.remotes 	let findnamed maskremotename = 		case filter (\r -> name r == maskremotename) remotelist of

@@ -199,8 +199,8 @@ 	loginopt = maybe [] (\l -> ["-l",l]) login 	fromNull as xs = if null xs then as else xs -rsyncSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-rsyncSetup ss mu _ c gc = do+rsyncSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+rsyncSetup ss mu _ _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	-- verify configuration is sane 	let url = maybe (giveup "Specify rsyncurl=") fromProposedAccepted $

@@ -270,8 +270,8 @@ 			, remoteStateHandle = rs 			} -s3Setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-s3Setup ss mu mcreds c gc = do+s3Setup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+s3Setup ss mu _ mcreds c gc = do 	u <- maybe (liftIO genUUID) return mu 	s3Setup' ss u mcreds c gc 

@@ -125,8 +125,8 @@ 		, remoteStateHandle = rs 		} -tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-tahoeSetup _ mu _ c _ = do+tahoeSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+tahoeSetup _ mu _ _ c _ = do 	furl <- maybe (fromMaybe missingfurl $ M.lookup furlField c) Proposed 		<$> liftIO (getEnv "TAHOE_FURL") 	u <- maybe (liftIO genUUID) return mu

@@ -109,8 +109,8 @@ 		, remoteStateHandle = rs 		} -setupInstance :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-setupInstance _ mu _ c _ = do+setupInstance :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+setupInstance _ mu _ _ c _ = do 	u <- maybe (liftIO genUUID) return mu 	gitConfigSpecialRemote u c [("web", "true")] 	return (c, u)

@@ -128,8 +128,8 @@ 			} 		chunkconfig = getChunkConfig c -webdavSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-webdavSetup ss mu mcreds c gc = do+webdavSetup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+webdavSetup ss mu _ mcreds c gc = do 	u <- maybe (liftIO genUUID) return mu 	url <- maybe (giveup "Specify url=") 		(return . fromProposedAccepted)

@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}  module Types.Cluster ( 	ClusterUUID,@@ -43,12 +43,7 @@ -- Check if it is a valid cluster UUID. isClusterUUID :: UUID -> Bool isClusterUUID (UUID b) -	| B.take 2 b == "ac" = -#if MIN_VERSION_bytestring(0,11,0)-		B.indexMaybe b 14 == Just eight-#else-		B.length b > 14 && B.head (B.drop 14 b) == eight-#endif+	| B.take 2 b == "ac" = B.indexMaybe b 14 == Just eight   where 	eight = fromIntegral (ord '8') isClusterUUID _ = False

@@ -1,6 +1,6 @@ {- git-annex configuration  -- - Copyright 2012-2025 Joey Hess <id@joeyh.name>+ - Copyright 2012-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -51,6 +51,7 @@ import Types.StallDetection import Types.View import Types.Cluster+import Types.Group import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd)@@ -171,6 +172,9 @@ 	, annexViewUnsetDirectory :: ViewUnset 	, annexClusters :: M.Map RemoteName ClusterUUID 	, annexFullyBalancedThreshhold :: Double+	, annexInitWanted :: Maybe String+	, annexInitRequired :: Maybe String+	, annexInitGroups :: [Group] 	}  extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig@@ -284,7 +288,7 @@ 		(getmayberead (annexConfig "adjustedbranchrefresh")) 	, annexSupportUnlocked = getbool (annexConfig "supportunlocked") True 	, annexAssistantAllowUnlocked = getbool (annexConfig "assistant.allowunlocked") False-	, annexTrashbin = getmaybe "annex.trashbin"+	, annexTrashbin = getmaybe (annexConfig "trashbin") 	, coreSymlinks = getbool "core.symlinks" True 	, coreSharedRepository = getSharedRepository r 	, coreQuotePath = QuotePath (getbool "core.quotepath" True)@@ -315,6 +319,10 @@ 	, annexFullyBalancedThreshhold = 		fromMaybe 0.9 $ (/ 100) <$> getmayberead 			(annexConfig "fullybalancedthreshhold")+	, annexInitWanted = getmaybe (annexConfig "initwanted")+	, annexInitRequired = getmaybe (annexConfig "initrequired")+	, annexInitGroups = map (Group . encodeBS) $+		getwords (annexConfig "initgroups") 	}   where 	getbool k d = fromMaybe d $ getmaybebool k

@@ -65,7 +65,7 @@ 	-- parse configs of remotes of this type 	, configParser :: RemoteConfig -> a RemoteConfigParser 	-- initializes or enables a remote-	, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)+	, setup :: SetupStage -> Maybe UUID -> RemoteName -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID) 	-- check if a remote of this type is able to support export 	, exportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool 	-- check if a remote of this type is able to support import

@@ -9,7 +9,6 @@  import Annex.Common import Types.Messages-import Git.Types (RemoteName) import qualified Utility.SimpleProtocol as Proto import Utility.Format import Utility.Metered (TotalSize(..))

@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Utility.LockFile.Windows ( 	lockShared,@@ -22,9 +22,7 @@ import Utility.Path.Windows import Utility.FileSystemEncoding import Utility.OsPath-#if MIN_VERSION_Win32(2,13,4) import Common (tryNonAsync)-#endif  type LockFile = OsPath @@ -62,21 +60,12 @@ openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do 	f' <- convertToWindowsNativeNamespace (fromOsPath f)-#if MIN_VERSION_Win32(2,13,4) 	r <- tryNonAsync $ createFile_NoRetry (fromRawFilePath f') gENERIC_READ sharemode  		Nothing oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL 		Nothing 	return $ case r of 		Left _ -> Nothing 		Right h -> Just h-#else-	h <- withTString (fromRawFilePath f') $ \c_f ->-		c_CreateFile c_f gENERIC_READ sharemode (maybePtr Nothing)-			oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing)-	return $ if h == iNVALID_HANDLE_VALUE-		then Nothing-		else Just h-#endif  dropLock :: LockHandle -> IO () dropLock = closeHandle

@@ -1,4 +1,4 @@-{- openFd wrapper to support old versions of unix package.+{- openFd wrapper  -  - Copyright 2023-2025 Joey Hess <id@joeyh.name>  -@@ -14,9 +14,6 @@  import System.Posix.IO.ByteString import System.Posix.Types-#if ! MIN_VERSION_unix(2,8,0)-import Control.Monad-#endif  import Utility.RawFilePath @@ -24,13 +21,6 @@  openFdWithMode :: RawFilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> CloseOnExecFlag -> IO Fd openFdWithMode f openmode filemode flags (CloseOnExecFlag closeonexec) = do-#if MIN_VERSION_unix(2,8,0) 	openFd f openmode (flags { creat = filemode, cloexec = closeonexec })-#else-	fd <- openFd f openmode filemode flags-	when closeonexec $-		setFdOption fd CloseOnExec True-	return fd-#endif  #endif

@@ -1,23 +0,0 @@-{- support for old versions of the stm package- -- - Copyright 2024 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-tabs #-}--module Utility.STM (-	module Control.Concurrent.STM,-#if ! MIN_VERSION_stm(2,5,1)-	writeTMVar-#endif-) where--import Control.Concurrent.STM--#if ! MIN_VERSION_stm(2,5,1)-writeTMVar :: TMVar t -> t -> STM ()-writeTMVar t new = tryTakeTMVar t >> putTMVar t new-#endif

@@ -281,7 +281,7 @@ 					fn <- extractFromResourceT (extractfilename resp) 					return $ found len fn 				else if responseStatus resp == unauthorized401-					then return $ getBasicAuth uo' (show (getUri req)) >>= \case+					then return $ getBasicAuth uo' (show (getUri req)) (responseHeaders resp) >>= \case 						Nothing -> return dne 						Just (ba, signalsuccess) -> do 							ui <- existsconduit'@@ -476,7 +476,7 @@ 				else do 					rf <- extractFromResourceT (respfailure resp) 					if responseStatus resp == unauthorized401-						then return $ getBasicAuth uo (show (getUri req')) >>= \case+						then return $ getBasicAuth uo (show (getUri req')) (responseHeaders resp) >>= \case 							Nothing -> giveup rf 							Just ba -> retryauthed ba 						else return $ giveup rf@@ -516,7 +516,7 @@ 					else do 						rf <- extractFromResourceT (respfailure resp) 						if responseStatus resp == unauthorized401-							then return $ getBasicAuth uo (show (getUri req'')) >>= \case+							then return $ getBasicAuth uo (show (getUri req'')) (responseHeaders resp) >>= \case 								Nothing -> giveup rf 								Just ba -> retryauthed ba 							else return $ giveup rf@@ -725,10 +725,10 @@ -- -- The returned IO action is run after trying to use the BasicAuth, -- indicating if the password worked.-type GetBasicAuth = URLString -> IO (Maybe (BasicAuth, Bool -> IO ()))+type GetBasicAuth = URLString -> ResponseHeaders -> IO (Maybe (BasicAuth, Bool -> IO ()))  noBasicAuth :: GetBasicAuth-noBasicAuth = const $ pure Nothing+noBasicAuth = const $ const $ pure Nothing  applyBasicAuth' :: BasicAuth -> Request -> Request applyBasicAuth' ba = applyBasicAuth

@@ -19,9 +19,7 @@ #ifndef mingw32_HOST_OS import Utility.Data import System.Posix.User-#if MIN_VERSION_unix(2,8,0) import System.Posix.User.ByteString (UserEntry)-#endif #endif  {- Current user's home directory.

@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20251215+Version: 10.20260115 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -96,11 +96,8 @@   templates/configurators/newrepository/first.hamlet   templates/configurators/newrepository/combine.hamlet   templates/configurators/enablewebdav.hamlet-  templates/configurators/pairing/local/inprogress.hamlet-  templates/configurators/pairing/local/prompt.hamlet   templates/configurators/pairing/wormhole/prompt.hamlet   templates/configurators/pairing/wormhole/start.hamlet-  templates/configurators/pairing/disabled.hamlet   templates/configurators/addglacier.hamlet   templates/configurators/fsck.cassius   templates/configurators/edit/nonannexremote.hamlet@@ -152,9 +149,6 @@   Description: Enable git-annex assistant, webapp, and watch command   Default: True -Flag Pairing-  Description: Enable pairing- Flag Production   Description: Enable production build (slower build; faster binary) @@ -186,11 +180,11 @@  source-repository head   type: git-  location: git://git-annex.branchable.com/+  location: https://git.joeyh.name/git/git-annex.git/  custom-setup   Setup-Depends:-    base (>= 4.15.1.0 && < 5.0),+    base (>= 4.18.2.1 && < 5.0),     split,     filepath,     exceptions,@@ -206,12 +200,12 @@ Executable git-annex   Main-Is: git-annex.hs   Build-Depends:-   base (>= 4.15.1.0 && < 5.0),+   base (>= 4.18.2.1 && < 5.0),    network-uri (>= 2.6),    optparse-applicative (>= 0.14.2),    containers (>= 0.5.8),    exceptions (>= 0.6),-   stm (>= 2.3),+   stm (>= 2.5.1.0),    mtl (>= 2),    uuid (>= 1.2.6),    process (>= 1.6.4),@@ -229,8 +223,8 @@    monad-logger (>= 0.3.10),    free,    utf8-string (>= 1.0.0),-   bytestring,-   text,+   bytestring (>= 0.11.5.3),+   text (>= 2.0.2),    sandi,    monad-control,    transformers,@@ -245,8 +239,8 @@    conduit,    time (>= 1.9.1),    old-locale,-   persistent-sqlite (>= 2.8.1),-   persistent (>= 2.8.1),+   persistent-sqlite (>= 2.13.3),+   persistent (>= 2.13.3),    persistent-template (>= 2.8.0),    unliftio-core,    microlens,@@ -325,12 +319,12 @@    if (os(windows))     Build-Depends:-      Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0),+      Win32 (>= 2.13.4.0),       setenv,       process (>= 1.6.2.0),       silently (>= 1.2.5.1)   else-    Build-Depends: unix (>= 2.7.2)+    Build-Depends: unix (>= 2.8.4)    if flag(Assistant) && ! os(solaris) && ! os(gnu)     CPP-Options: -DWITH_ASSISTANT -DWITH_WEBAPP@@ -367,8 +361,6 @@       Assistant.Monad       Assistant.NamedThread       Assistant.Pairing-      Assistant.Pairing.MakeRemote-      Assistant.Pairing.Network       Assistant.Pushes       Assistant.RemoteControl       Assistant.Repair@@ -386,7 +378,6 @@       Assistant.Threads.Merger       Assistant.Threads.MountWatcher       Assistant.Threads.NetWatcher-      Assistant.Threads.PairListener       Assistant.Threads.ProblemFixer       Assistant.Threads.Pusher       Assistant.Threads.RemoteControl@@ -484,10 +475,6 @@       CPP-Options: -DWITH_DBUS -DWITH_DESKTOP_NOTIFY -DWITH_DBUS_NOTIFICATIONS       Other-Modules: Utility.DBus -  if flag(Pairing)-    Build-Depends: network-multicast, network-info-    CPP-Options: -DWITH_PAIRING-   if flag(TorrentParser)     Build-Depends: torrent (>= 10000.0.0)     CPP-Options: -DWITH_TORRENTPARSER@@ -789,7 +776,6 @@     Database.RepoSize     Database.RepoSize.Handle     Database.Types-    Database.Utility     Git     Git.AutoCorrect     Git.Branch@@ -1126,7 +1112,6 @@     Utility.SshConfig     Utility.SshHost     Utility.StatelessOpenPGP-    Utility.STM     Utility.Su     Utility.SystemDirectory     Utility.FileIO

@@ -3,7 +3,6 @@     production: true     parallelbuild: true     assistant: true-    pairing: true     torrentparser: true     magicmime: false     dbus: false@@ -12,6 +11,6 @@     ospath: true packages: - '.'-resolver: lts-24.2+resolver: lts-24.26 extra-deps: - aws-0.25.2

@@ -11,14 +11,6 @@ ^{makeWormholePairing}  <h3>-  <a href="@{StartLocalPairR}">-    <span .glyphicon .glyphicon-plus-sign>-    \ Local computer-<p>-  Pair with a computer to keep files in sync quickly, #-  over your local network.--<h3>   <a href="@{NewRepositoryR}">     <span .glyphicon .glyphicon-plus-sign>     \ Add another repository

@@ -1,6 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      not supported-    <p>-      This build of git-annex does not support #{pairingtype} pairing. Sorry!

@@ -1,19 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Pairing in progress ..-    $if T.null secret-      <p>-        You do not need to leave this page open; pairing will finish #-        automatically.-    $else-      <p>-        Now you should either go tell the owner of the computer you want to pair #-        with the secret phrase you selected ("#{secret}"), or go enter it into #-        the computer you want to pair with.-      <p>-        You do not need to leave this page open; pairing will finish automatically #-        as soon as the secret phrase is entered into the other computer.-      <p>-        If you're not seeing a pair request on the other computer, try moving #-        it to the same switch or wireless network as this one.

@@ -1,53 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Pairing with a local computer-    <p>-      $if start-        Pair with a computer on your local network (or VPN), and the #-        two git annex repositories will be combined into one, with changes #-        kept in sync between them.-      $else-        Pairing with #{username}@#{hostname} will combine your two git annex #-        repositories into one, allowing you to share files.-    <p>-      $if start-        For security, enter a secret phrase. To verify that you're pairing #-        with the right computer, its git-annex webapp will then prompt for the #-        same secret phrase. That's all this secret phrase will be used for.-      $else-        $if sameusername-          For security, you need to enter the same secret phrase that was #-          entered on #{hostname} when the pairing was started.-        $else-          For security, a secret phrase has been selected, which you need #-          to enter here to finish the pairing. If you don't know the #-          phrase, go ask #{username} ...-    $if badphrase-      <div .alert .alert-danger>-        <span .glyphicon .glyphicon-warning-sign>-        \ #{problem}-    <p>-      <form method="post" .form-horizontal enctype=#{enctype}>-        <fieldset>-          ^{form}-          ^{webAppFormAuthToken}-          <div .form-group>-            <div .col-sm-10 .col-sm-offset-2>-              <button .btn .btn-primary type=submit>-                $if start-                  Start pairing-                $else-                  Finish pairing-      <div .alert .alert-info>-        $if start-          <p>-            A good secret phrase is reasonably long. You'll only #-            type it a few times. Only letters and numbers matter; #-            punctuation and white space is ignored.-          <p>-            A quotation is one good choice, something like: #-            "#{sampleQuote}"-        $else-          Only letters and numbers matter; punctuation and spaces are #-          ignored.