diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -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) diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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 diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -694,7 +694,7 @@ , return True ) where - needemulation = Remote.Git.onLocalRepo repo $ + needemulation = Remote.Git.onLocalRepo remote repo $ (annexCrippledFileSystem <$> Annex.getGitConfig) <&&> needUpdateInsteadEmulation diff --git a/Git/Credential.hs b/Git/Credential.hs --- a/Git/Credential.hs +++ b/Git/Credential.hs @@ -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. diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -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 diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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 diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -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 diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -1,6 +1,6 @@ {- External special remote data types. - - - Copyright 2013-2025 Joey Hess + - Copyright 2013-2026 Joey Hess - - 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 diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -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 diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -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 diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -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 diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -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)) ] diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -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. -- diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -1,6 +1,6 @@ {- Url downloading. - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2026 Joey Hess - - 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 diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,11 +1,11 @@ Name: git-annex -Version: 10.20260213 +Version: 10.20260316 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess 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),