git-annex 10.20260213 → 10.20260316
raw patch · 16 files changed
+202/−109 lines, 16 filesdep ~base
Dependency ranges changed: base
Files
- Annex/Url.hs +8/−2
- CHANGELOG +21/−0
- Command/Sync.hs +1/−1
- Git/Credential.hs +4/−4
- Remote/Adb.hs +1/−1
- Remote/Directory.hs +1/−3
- Remote/External.hs +15/−6
- Remote/External/Types.hs +4/−1
- Remote/Git.hs +24/−14
- Remote/HttpAlso.hs +11/−15
- Remote/S3.hs +2/−11
- Remote/WebDAV/DavLocation.hs +2/−5
- Types/GitConfig.hs +4/−2
- Types/Remote.hs +1/−1
- Utility/Url.hs +98/−38
- git-annex.cabal +5/−5
Annex/Url.hs view
@@ -15,6 +15,7 @@ getUserAgent, ipAddressesUnlimited, checkBoth,+ checkBoth', download, download', exists,@@ -48,8 +49,10 @@ import Network.HTTP.Client.TLS import Text.Read import qualified Data.Set as S+#if MIN_VERSION_tls(2,0,0) import qualified Network.Connection as NC import qualified Network.TLS as TLS+#endif defaultUserAgent :: U.UserAgent defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion@@ -193,8 +196,11 @@ checkBoth url expected_size uo = liftIO (U.checkBoth url expected_size uo) >>= \case Right r -> return r- Left err -> warning (UnquotedString err) >> return False+ Left err -> giveup err +checkBoth' :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex (Either String Bool)+checkBoth' url expected_size uo = liftIO $ U.checkBoth url expected_size uo+ download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex Bool download meterupdate iv url file uo = liftIO (U.download meterupdate iv url file uo) >>= \case@@ -208,7 +214,7 @@ exists :: U.URLString -> U.UrlOptions -> Annex Bool exists url uo = liftIO (U.exists url uo) >>= \case Right b -> return b- Left err -> warning (UnquotedString err) >> return False+ Left err -> giveup err getUrlInfo :: U.URLString -> U.UrlOptions -> Annex (Either String U.UrlInfo) getUrlInfo url uo = liftIO (U.getUrlInfo url uo)
CHANGELOG view
@@ -1,3 +1,24 @@+git-annex (10.20260316) upstream; urgency=medium++ * Added CHECKPRESENT-URL extension to the external special remote protocol.+ * Fix reversion in previous version that caused auto-initializing of+ local git remotes that have annex-ignore set.+ * Fix bug that caused git credential to be rejected when a http request+ failed for some reason other than 401.+ * Importing from the directory special remote will no longer add sizes+ to keys, which overrode backends that generate unsized keys.+ * Fix retrival from http git remotes of keys with '%' in their names.+ * Fix behavior when initremote is used with --sameas= + combined with --private.+ * web, S3, git: Fix bugs in checking if content is present on a remote+ when configuration does not allow accessing it.+ * httpalso: Fix bugs in handling content not being present on the remote.+ * adb: Avoid deleting contents of a non-empty directory when+ removing the last exported file from the directory.+ * Improve display of http exceptions.++ -- Joey Hess <id@joeyh.name> Mon, 16 Mar 2026 06:53:22 -0400+ git-annex (10.20260213) upstream; urgency=medium * When used with git forges that allow Push to Create, the remote's
Command/Sync.hs view
@@ -694,7 +694,7 @@ , return True ) where- needemulation = Remote.Git.onLocalRepo repo $+ needemulation = Remote.Git.onLocalRepo remote repo $ (annexCrippledFileSystem <$> Annex.getGitConfig) <&&> needUpdateInsteadEmulation
Git/Credential.hs view
@@ -51,15 +51,15 @@ where go storeincache c = case credentialBasicAuth c of- Just ba -> return $ Just (ba, signalsuccess)+ Just ba -> return $ Just (ba, signalauthsuccess) Nothing -> do- signalsuccess False+ signalauthsuccess False return Nothing where- signalsuccess True = do+ signalauthsuccess True = do () <- storeincache c approveUrlCredential c r- signalsuccess False = rejectUrlCredential c r+ signalauthsuccess False = rejectUrlCredential c r -- | This may prompt the user for the credential, or get a cached -- credential from git.
Remote/Adb.hs view
@@ -274,7 +274,7 @@ unlessM go $ giveup "adb failed" where- go = adbShellBool serial [Param "rm", Param "-rf", File (fromAndroidPath adir)]+ go = adbShellBool serial [Param "rmdir", Param "--ignore-fail-on-non-empty", File (fromAndroidPath adir)] adir = androidExportLocation abase (mkExportLocation (fromExportDirectory dir)) checkPresentExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> Annex Bool
Remote/Directory.hs view
@@ -433,9 +433,7 @@ importKeyM :: IgnoreInodes -> OsPath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) importKeyM ii dir loc cid sz p = do backend <- chooseBackend f- unsizedk <- fst <$> genKey ks p backend- let k = alterKey unsizedk $ \kd -> kd- { keySize = keySize kd <|> Just sz }+ k <- fst <$> genKey ks p backend currcid <- liftIO $ mkContentIdentifier ii absf =<< R.getSymbolicLinkStatus (fromOsPath absf) guardSameContentIdentifiers (return (Just k)) [cid] currcid
Remote/External.hs view
@@ -95,7 +95,7 @@ { storeExport = storeExportM external , retrieveExport = retrieveExportM external gc , removeExport = removeExportM external- , checkPresentExport = checkPresentExportM external+ , checkPresentExport = checkPresentExportM external gc , removeExportDirectory = Just $ removeExportDirectoryM external , renameExport = Just $ renameExportM external }@@ -118,7 +118,7 @@ (storeKeyM external) (retrieveKeyFileM external gc) (removeKeyM external)- (checkPresentM external)+ (checkPresentM external gc) rmt where mk c cst ordered avail towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported =@@ -276,8 +276,8 @@ respErrorMessage "REMOVE" errmsg _ -> Nothing -checkPresentM :: External -> CheckPresent-checkPresentM external k = either giveup id <$> go+checkPresentM :: External -> RemoteGitConfig -> CheckPresent+checkPresentM external gc k = either giveup id <$> go where go = handleRequestKey external CHECKPRESENT k Nothing $ \resp -> case resp of@@ -288,6 +288,8 @@ CHECKPRESENT_UNKNOWN k' errmsg | k' == k -> result $ Left $ respErrorMessage "CHECKPRESENT" errmsg+ CHECKPRESENT_URL k' url+ | k == k' -> checkKeyUrl' gc k url _ -> Nothing whereisKeyM :: External -> Key -> Annex [String]@@ -327,8 +329,8 @@ _ -> Nothing req sk = TRANSFEREXPORT Download sk (fromOsPath dest) -checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool-checkPresentExportM external k loc = either giveup id <$> go+checkPresentExportM :: External -> RemoteGitConfig -> Key -> ExportLocation -> Annex Bool+checkPresentExportM external gc k loc = either giveup id <$> go where go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of CHECKPRESENT_SUCCESS k'@@ -338,6 +340,8 @@ CHECKPRESENT_UNKNOWN k' errmsg | k' == k -> result $ Left $ respErrorMessage "CHECKPRESENT" errmsg+ CHECKPRESENT_URL k' url+ | k == k' -> checkKeyUrl' gc k url UNSUPPORTED_REQUEST -> result $ Left "CHECKPRESENTEXPORT not implemented by external special remote" _ -> Nothing@@ -860,6 +864,11 @@ checkKeyUrl gc k = do us <- getWebUrls k anyM (\u -> withUrlOptions (Just gc) $ checkBoth u (fromKey keySize k)) us++checkKeyUrl' :: RemoteGitConfig -> Key -> URLString -> Maybe (Annex (ResponseHandlerResult (Either String Bool)))+checkKeyUrl' gc k url = + Just $ withUrlOptions (Just gc) $ \uo ->+ Result <$> checkBoth' url (fromKey keySize k) uo getWebUrls :: Key -> Annex [URLString] getWebUrls key = filter supported <$> getUrls key
Remote/External/Types.hs view
@@ -1,6 +1,6 @@ {- External special remote data types. -- - 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. -}@@ -116,6 +116,7 @@ , "GETGITREMOTENAME" , "UNAVAILABLERESPONSE" , "TRANSFER-RETRIEVE-URL"+ , "CHECKPRESENT-URL" , asyncExtension ] @@ -247,6 +248,7 @@ | CHECKPRESENT_SUCCESS Key | CHECKPRESENT_FAILURE Key | CHECKPRESENT_UNKNOWN Key ErrorMsg+ | CHECKPRESENT_URL Key URLString | REMOVE_SUCCESS Key | REMOVE_FAILURE Key ErrorMsg | COST Cost@@ -286,6 +288,7 @@ parseCommand "CHECKPRESENT-SUCCESS" = Proto.parse1 CHECKPRESENT_SUCCESS parseCommand "CHECKPRESENT-FAILURE" = Proto.parse1 CHECKPRESENT_FAILURE parseCommand "CHECKPRESENT-UNKNOWN" = Proto.parse2 CHECKPRESENT_UNKNOWN+ parseCommand "CHECKPRESENT-URL" = Proto.parse2 CHECKPRESENT_URL parseCommand "REMOVE-SUCCESS" = Proto.parse1 REMOVE_SUCCESS parseCommand "REMOVE-FAILURE" = Proto.parse2 REMOVE_FAILURE parseCommand "COST" = Proto.parse1 COST
Remote/Git.hs view
@@ -50,6 +50,7 @@ import Utility.Metered import Utility.Env import Utility.Batch+import Utility.Url (extendUrlWithPath) import qualified Utility.FileIO as F import Remote.Helper.Git import Remote.Helper.Messages@@ -190,7 +191,8 @@ annexignore <- liftIO $ getDynamicConfig (remoteAnnexIgnore gc) case (repoCheap r, annexignore, hasuuid) of (True, _, _)- | remoteAnnexCheckUUID gc -> tryGitConfigRead gc autoinit r hasuuid+ | remoteAnnexCheckUUID gc ->+ tryGitConfigRead gc (not annexignore && autoinit) r hasuuid | otherwise -> return r (_, True, _) | remoteAnnexIgnoreAuto gc ->@@ -412,9 +414,12 @@ ": " ++ show e Annex.getState Annex.repo let r' = r { Git.repoPathSpecifiedExplicitly = True }- s <- newLocal r'- liftIO $ Annex.eval s $ check- `finally` quiesce True+ if autoinit+ then do+ s <- newLocal r'+ liftIO $ Annex.eval s $ check+ `finally` quiesce True+ else liftIO $ Git.Config.read r' failedreadlocalconfig = do unless hasuuid $ case Git.remoteName r of@@ -482,7 +487,7 @@ keyUrls :: GitConfig -> Git.Repo -> Remote -> Key -> [String] keyUrls gc repo r key = map tourl locs' where- tourl l = Git.repoLocation repo ++ "/" ++ l+ tourl = extendUrlWithPath (Git.repoLocation repo) -- If the remote is known to not be bare, try the hash locations -- used for non-bare repos first, as an optimisation. locs@@ -757,12 +762,15 @@ ensureInitialized noop (pure []) a `finally` quiesce True -data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar [(Annex.AnnexState, Annex.AnnexRead)])+data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo Bool (MVar [(Annex.AnnexState, Annex.AnnexRead)]) {- This can safely be called on a Repo that is not local, but of course - onLocal will not work if used with the result. -}-mkLocalRemoteAnnex :: Git.Repo -> Annex (LocalRemoteAnnex)-mkLocalRemoteAnnex repo = LocalRemoteAnnex repo <$> liftIO (newMVar [])+mkLocalRemoteAnnex :: Git.Repo -> RemoteGitConfig -> Annex (LocalRemoteAnnex)+mkLocalRemoteAnnex repo gc =+ LocalRemoteAnnex repo+ <$> liftIO (getDynamicConfig (remoteAnnexIgnore gc))+ <*> liftIO (newMVar []) {- Runs an action from the perspective of a local remote. -@@ -776,9 +784,9 @@ onLocal :: State -> Annex a -> Annex a onLocal (State _ _ _ _ _ lra) = onLocal' lra -onLocalRepo :: Git.Repo -> Annex a -> Annex a-onLocalRepo repo a = do- lra <- mkLocalRemoteAnnex repo+onLocalRepo :: Remote -> Git.Repo -> Annex a -> Annex a+onLocalRepo r repo a = do+ lra <- mkLocalRemoteAnnex repo (gitconfig r) onLocal' lra a newLocal :: Git.Repo -> Annex (Annex.AnnexState, Annex.AnnexRead)@@ -794,15 +802,17 @@ }) onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a-onLocal' (LocalRemoteAnnex repo mv) a = liftIO (takeMVar mv) >>= \case+onLocal' (LocalRemoteAnnex repo annexignore mv) a = liftIO (takeMVar mv) >>= \case [] -> do liftIO $ putMVar mv [] v <- newLocal repo- go (v, ensureInitialized noop (pure []) >> a)+ go (v, initialized >> a) (v:rest) -> do liftIO $ putMVar mv rest go (v, a) where+ initialized = unless annexignore $+ ensureInitialized noop (pure []) go ((st, rd), a') = do curro <- Annex.getState Annex.output let act = Annex.run (st { Annex.output = curro }, rd) $@@ -901,7 +911,7 @@ pool <- Ssh.mkP2PShellConnectionPool copycowtried <- liftIO newCopyCoWTried fastcopy <- getFastCopy gc- lra <- mkLocalRemoteAnnex r+ lra <- mkLocalRemoteAnnex r gc (duc, getrepo) <- go return $ State pool duc copycowtried fastcopy getrepo lra where
Remote/HttpAlso.hs view
@@ -26,7 +26,6 @@ import Annex.SpecialRemote.Config import Git.FilePath -import Data.Either import qualified Data.Map as M import System.FilePath.Posix as P import Control.Concurrent.STM@@ -139,18 +138,15 @@ checkKey :: RemoteGitConfig -> Maybe URLString -> LearnedLayout -> CheckPresent checkKey gc baseurl ll key =- isRight <$> keyUrlAction baseurl ll key (checkKey' gc key)+ either giveup return =<< keyUrlAction baseurl ll key (checkKey' gc key) -checkKey' :: RemoteGitConfig -> Key -> URLString -> Annex (Either String ())+checkKey' :: RemoteGitConfig -> Key -> URLString -> Annex (Either String Bool) checkKey' gc key url = - ifM (Url.withUrlOptions (Just gc) $ Url.checkBoth url (fromKey keySize key))- ( return (Right ())- , return (Left "content not found")- )+ Url.withUrlOptions (Just gc) $ Url.checkBoth' url (fromKey keySize key) checkPresentExportHttpAlso :: RemoteGitConfig -> Maybe URLString -> Key -> ExportLocation -> Annex Bool checkPresentExportHttpAlso gc baseurl key loc =- isRight <$> exportLocationUrlAction baseurl loc (checkKey' gc key)+ either giveup return =<< exportLocationUrlAction baseurl loc (checkKey' gc key) type LearnedLayout = TVar (Maybe [Key -> URLString]) @@ -164,8 +160,8 @@ :: Maybe URLString -> LearnedLayout -> Key- -> (URLString -> Annex (Either String ()))- -> Annex (Either String ())+ -> (URLString -> Annex (Either String a))+ -> Annex (Either String a) keyUrlAction (Just baseurl) ll key downloader = liftIO (readTVarIO ll) >>= \case Just learned -> go Nothing False [learned]@@ -173,27 +169,27 @@ where go err learn [] = go' err learn [] [] go err learn (layouts:rest) = go' err learn layouts [] >>= \case- Right () -> return (Right ())+ Right a -> return (Right a) Left err' -> go (Just err') learn rest go' (Just err) _ [] _ = pure (Left err) go' Nothing _ [] _ = error "internal" go' _err learn (layout:rest) prevs = downloader (layout key) >>= \case- Right () -> do+ Right a -> do when learn $ do let learned = layout:prevs++rest liftIO $ atomically $ writeTVar ll (Just learned)- return (Right ())+ return (Right a) Left err -> go' (Just err) learn rest (layout:prevs) keyUrlAction Nothing _ _ _ = noBaseUrlError exportLocationUrlAction :: Maybe URLString -> ExportLocation- -> (URLString -> Annex (Either String ()))- -> Annex (Either String ())+ -> (URLString -> Annex (Either String a))+ -> Annex (Either String a) exportLocationUrlAction (Just baseurl) loc a = a (baseurl P.</> fromOsPath (fromExportLocation loc)) exportLocationUrlAction Nothing _ _ = noBaseUrlError
Remote/S3.hs view
@@ -28,7 +28,6 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as M import qualified Data.Set as S-import qualified System.FilePath.Posix as Posix import Data.Char import Data.String import Data.Maybe@@ -37,7 +36,6 @@ import Network.HTTP.Conduit (Manager) import Network.HTTP.Client (responseStatus, responseBody, RequestBody(..)) import Network.HTTP.Types-import Network.URI import Control.Monad.Trans.Resource import Control.Monad.Catch import Control.Concurrent.STM (atomically)@@ -68,7 +66,7 @@ import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url-import Utility.Url (extractFromResourceT, UserAgent, sinkResponseIncrementalVerifier)+import Utility.Url (extractFromResourceT, UserAgent, sinkResponseIncrementalVerifier, extendUrlWithPath) import Annex.Url (getUserAgent, getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env import Annex.Verify@@ -1219,14 +1217,7 @@ "https://" ++ T.unpack (bucket info) ++ ".s3.amazonaws.com/" genericPublicUrl :: URLString -> BucketObject -> URLString-genericPublicUrl baseurl p = - baseurl Posix.</> escapeURIString skipescape p- where- -- Don't need to escape '/' because the bucket object- -- is not necessarily a single url component. - -- But do want to escape eg '+' and ' '- skipescape '/' = True- skipescape c = isUnescapedInURIComponent c+genericPublicUrl = extendUrlWithPath genCredentials :: CredPair -> IO AWS.Credentials genCredentials (keyid, secret) = do
Remote/WebDAV/DavLocation.hs view
@@ -13,7 +13,7 @@ import Types import Types.Export import Annex.Locations-import Utility.Url (URLString)+import Utility.Url (URLString, extendUrlWithPath) #ifdef mingw32_HOST_OS import Utility.Split #endif@@ -22,7 +22,6 @@ import qualified System.FilePath.Posix as UrlPath import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) import Control.Monad.IO.Class (MonadIO)-import Network.URI import Data.Default -- Relative to the top of the DAV url.@@ -30,9 +29,7 @@ {- Runs action with a new location relative to the current location. -} inLocation :: (MonadIO m) => DavLocation -> DAVT m a -> DAVT m a-inLocation d = inDAVLocation (UrlPath.</> d')- where- d' = escapeURIString isUnescapedInURI d+inLocation d = inDAVLocation (`extendUrlWithPath` d) {- The directory where files(s) for a key are stored. -} keyDir :: Key -> DavLocation
Types/GitConfig.hs view
@@ -307,8 +307,10 @@ | Git.Config.isTrueFalse' v /= Just True = Nothing | isRemoteKey (remoteAnnexConfigEnd "private") k = do remotename <- remoteKeyToRemoteName k- toUUID <$> Git.Config.getMaybe- (remoteAnnexConfig remotename "uuid") r+ let getu c = + toUUID <$> Git.Config.getMaybe+ (remoteAnnexConfig remotename c) r+ getu "config-uuid" <|> getu "uuid" | otherwise = Nothing in mapMaybe get (M.toList (Git.config r)) ]
Types/Remote.hs view
@@ -288,7 +288,7 @@ , removeExport :: Key -> ExportLocation -> a () -- Removes an exported directory. Typically the directory will be -- empty, but it could possibly contain files or other directories,- -- and it's ok to delete those (but not required to). + -- and it's ok to delete those (but better to avoid doing so). -- If the remote does not use directories, or automatically cleans -- up empty directories, this can be Nothing. --
Utility/Url.hs view
@@ -1,6 +1,6 @@ {- Url downloading. -- - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -41,6 +41,7 @@ applyBasicAuth', extractFromResourceT, conduitUrlSchemes,+ extendUrlWithPath, ) where import Common@@ -55,6 +56,7 @@ import Network.URI import Network.HTTP.Types+import qualified System.FilePath.Posix as UrlPath import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as B8@@ -176,6 +178,7 @@ - - The Left error is returned if policy or the restricted http manager - does not allow accessing the url or the url scheme is not supported.+ - It's also returned on eg, DNS or network failure. -} checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO (Either String Bool) checkBoth url expected_size uo = fmap go <$> check url expected_size uo@@ -209,10 +212,13 @@ - - The Left error is returned if policy or the restricted http manages - does not allow accessing the url or the url scheme is not supported.+ - It's also returned on eg, DNS or network failure. -} getUrlInfo :: URLString -> UrlOptions -> IO (Either String UrlInfo) getUrlInfo url uo = case parseURIRelaxed url of- Just u -> checkPolicy uo u (go u)+ Just u -> checkPolicy uo u $+ catchJust matchHttpException (go u) (return . Left . showHttpException)+ `catchNonAsync` (return . Left . show) Nothing -> return (Right dne) where go :: URI -> IO (Either String UrlInfo)@@ -256,7 +262,7 @@ <=< lookup hContentDisposition . responseHeaders existsconduit r req =- let a = catchcrossprotoredir r (existsconduit' req uo)+ let a = catchcrossprotoredir r (existsconduit' req uo Nothing) in catchJust matchconnectionrestricted a retconnectionrestricted matchconnectionrestricted he@(HttpExceptionRequest _ (InternalException ie)) =@@ -271,7 +277,10 @@ _ -> throwM he retconnectionrestricted he = throwM he - existsconduit' req uo' = do+ existsconduit' req uo' msignalauthsuccess = do+ let authedok = liftIO $ case msignalauthsuccess of+ Nothing -> noop+ Just signalauthsuccess -> signalauthsuccess True let req' = headRequest (applyRequest uo req) debug "Utility.Url" (show req') join $ runResourceT $ do@@ -282,15 +291,20 @@ fn <- extractFromResourceT (extractfilename resp) return $ found len fn else if responseStatus resp == unauthorized401- then return $ getBasicAuth uo' (show (getUri req)) (responseHeaders resp) >>= \case- Nothing -> return dne- Just (ba, signalsuccess) -> do- ui <- existsconduit'- (applyBasicAuth' ba req) - (uo' { getBasicAuth = noBasicAuth })- signalsuccess (urlExists ui)- return ui- else return $ return dne+ then case msignalauthsuccess of+ Nothing -> return $ getBasicAuth uo' (show (getUri req)) (responseHeaders resp) >>= \case+ Just (ba, signalauthsuccess) ->+ existsconduit'+ (applyBasicAuth' ba req)+ uo'+ (Just signalauthsuccess)+ Nothing -> return dne+ Just signalauthsuccess -> do+ liftIO $ signalauthsuccess False+ return $ return dne+ else do+ authedok+ return $ return dne existscurl u curlparams = do output <- catchDefaultIO "" $@@ -369,7 +383,7 @@ download' :: Bool -> MeterUpdate -> Maybe IncrementalVerifier -> URLString -> OsPath -> UrlOptions -> IO (Either String ()) download' nocurlerror meterupdate iv url file uo =- catchJust matchHttpException go showhttpexception+ catchJust matchHttpException go (dlfailed . showHttpException) `catchNonAsync` (dlfailed . show) where go = case parseURIRelaxed url of@@ -395,16 +409,6 @@ ftpport = 21 - showhttpexception he = dlfailed $ case he of- HttpExceptionRequest _ (StatusCodeException r _) ->- B8.toString $ statusMessage $ responseStatus r- HttpExceptionRequest _ (InternalException ie) -> - case fromException ie of- Nothing -> show ie- Just (ConnectionRestricted why) -> why- HttpExceptionRequest _ other -> show other- _ -> show he- dlfailed msg = do noverification return $ Left $ "download failed: " ++ msg@@ -464,7 +468,10 @@ - as usual.) -} downloadConduit :: MeterUpdate -> Maybe IncrementalVerifier -> Request -> OsPath -> UrlOptions -> IO ()-downloadConduit meterupdate iv req file uo =+downloadConduit = downloadConduit' Nothing++downloadConduit' :: Maybe (Bool -> IO ()) -> MeterUpdate -> Maybe IncrementalVerifier -> Request -> OsPath -> UrlOptions -> IO ()+downloadConduit' msignalauthsuccess meterupdate iv req file uo = catchMaybeIO (getFileSize file) >>= \case Just sz | sz > 0 -> resumedownload sz _ -> join $ runResourceT $ do@@ -472,15 +479,22 @@ resp <- http req' (httpManager uo) if responseStatus resp == ok200 then do+ authedok store zeroBytesProcessed WriteMode resp return (return ()) else do rf <- extractFromResourceT (respfailure resp) if responseStatus resp == unauthorized401- then return $ getBasicAuth uo (show (getUri req')) (responseHeaders resp) >>= \case- Nothing -> giveup rf- Just ba -> retryauthed ba- else return $ giveup rf+ then case msignalauthsuccess of+ Nothing -> return $ getBasicAuth uo (show (getUri req')) (responseHeaders resp) >>= \case+ Nothing -> giveup rf+ Just ba -> retryauthed ba+ Just signalauthsuccess -> do+ liftIO $ signalauthsuccess False+ giveup rf+ else do+ authedok+ return $ giveup rf where req' = applyRequest uo $ req -- Override http-client's default decompression of gzip@@ -504,23 +518,32 @@ resp <- http req'' (httpManager uo) if responseStatus resp == partialContent206 then do+ authedok store (toBytesProcessed sz) AppendMode resp return (return ()) else if responseStatus resp == ok200 then do+ authedok store zeroBytesProcessed WriteMode resp return (return ()) else if alreadydownloaded sz resp then do+ authedok liftIO noverification return (return ()) else do rf <- extractFromResourceT (respfailure resp) if responseStatus resp == unauthorized401- then return $ getBasicAuth uo (show (getUri req'')) (responseHeaders resp) >>= \case- Nothing -> giveup rf- Just ba -> retryauthed ba- else return $ giveup rf+ then case msignalauthsuccess of+ Nothing -> return $ getBasicAuth uo (show (getUri req'')) (responseHeaders resp) >>= \case+ Just ba -> retryauthed ba+ Nothing -> giveup rf+ Just signalauthsuccess -> do+ liftIO $ signalauthsuccess False+ giveup rf+ else do+ authedok+ return $ giveup rf alreadydownloaded sz resp | responseStatus resp /= requestedRangeNotSatisfiable416 = False@@ -542,20 +565,25 @@ respfailure = B8.toString . statusMessage . responseStatus - retryauthed (ba, signalsuccess) = do- r <- tryNonAsync $ downloadConduit+ retryauthed (ba, signalauthsuccess) = do+ r <- tryNonAsync $ downloadConduit'+ (Just signalauthsuccess) meterupdate iv (applyBasicAuth' ba req) file- (uo { getBasicAuth = noBasicAuth })+ uo case r of- Right () -> signalsuccess True+ Right () -> signalauthsuccess True Left e -> do- () <- signalsuccess False+ () <- signalauthsuccess False throwM e noverification = maybe noop unableIncrementalVerifier iv + authedok = liftIO $ case msignalauthsuccess of+ Nothing -> noop+ Just signalauthsuccess -> signalauthsuccess True+ {- Sinks a Response's body to a file. The file can either be appended to - (AppendMode), or written from the start of the response (WriteMode). - Updates the meter and incremental verifier as data is received,@@ -763,3 +791,35 @@ extractFromResourceT v = do liftIO $ evaluate (rnf v) return v++{- Extends an url by adding a path to the end.+ -+ - If the url does not end with '/' already, that will be added before+ - the path.+ -+ - Characters in the path that are not allowed in an url are url-escaped,+ - so if the input url string is a valid url, the result will also be a+ - valid url.+ -}+extendUrlWithPath :: URLString -> FilePath -> URLString+extendUrlWithPath u p = u UrlPath.</> escapeURIString skipescape p+ where+ -- Don't escape any '/' in the path. But do escape other+ -- characters that are not allowed unescaped in an url,+ -- which could result in the url not parsing, or parsing+ -- to not point to the desired path but somewhere else.+ -- (In particular '%' and '[' and ']'.)+ skipescape '/' = True+ skipescape c = isUnescapedInURIComponent c++showHttpException :: HttpException -> String+showHttpException (HttpExceptionRequest _ (StatusCodeException r _)) =+ B8.toString $ statusMessage $ responseStatus r+showHttpException (HttpExceptionRequest _ (InternalException ie)) =+ case fromException ie of+ Nothing -> show ie+ Just (ConnectionRestricted why) -> why+showHttpException (HttpExceptionRequest _ (ConnectionFailure e)) = + "connection failure: " ++ show e+showHttpException (HttpExceptionRequest _ other) = show other+showHttpException he = show he
git-annex.cabal view
@@ -1,11 +1,11 @@ Name: git-annex-Version: 10.20260213+Version: 10.20260316 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable-Copyright: 2010-2025 Joey Hess+Copyright: 2010-2026 Joey Hess License-File: COPYRIGHT Homepage: http://git-annex.branchable.com/ Build-type: Custom@@ -184,7 +184,7 @@ custom-setup Setup-Depends:- base (>= 4.18.2.1 && < 5.0),+ base (>= 4.18.2.1 && < 5), split, filepath, exceptions,@@ -195,12 +195,12 @@ directory (>= 1.2.7.0), async, utf8-string (>= 1.0.0),- Cabal (< 4.0)+ Cabal (< 4) Executable git-annex Main-Is: git-annex.hs Build-Depends:- base (>= 4.18.2.1 && < 5.0),+ base (>= 4.18.2.1 && < 5), network-uri (>= 2.6), optparse-applicative (>= 0.14.2), containers (>= 0.5.8),