diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -368,8 +368,16 @@ cleanuplockfile lockfile #endif - cleanuplockfile lockfile = void $ tryNonAsync $ do - thawContentDir lockfile + cleanuplockfile lockfile = + -- Often the content directory will be thawed already, + -- so avoid re-thawing, unless cleanup fails. + tryNonAsync (cleanuplockfile' lockfile) >>= \case + Right () -> return () + Left _ -> void $ tryNonAsync $ do + thawContentDir lockfile + cleanuplockfile' lockfile + + cleanuplockfile' lockfile = do liftIO $ removeWhenExistsWith removeFile lockfile cleanObjectDirs lockfile diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -351,10 +351,15 @@ fromSshHost host ++ "!" ++ show port hostport2socket' :: String -> OsPath hostport2socket' s - | length s > lengthofmd5s = toOsPath $ show $ md5 $ encodeBL s - | otherwise = toOsPath s + | length s' > lengthofmd5s = toOsPath $ show $ md5 $ encodeBL s' + | otherwise = toOsPath s' where lengthofmd5s = 32 + -- ssh parses the socket filename as a ControlPath, so it can + -- contain eg "%h". We don't want that here, and it's possible + -- for a hostname to itself contain a '%', eg a IPV6 link-local + -- address with a zone ID. + s' = filter (/= '%') s socket2lock :: OsPath -> OsPath socket2lock socket = socket <> lockExt diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -56,8 +56,8 @@ getUserAgent = Annex.getRead $ fromMaybe defaultUserAgent . Annex.useragent -getUrlOptions :: Annex U.UrlOptions -getUrlOptions = Annex.getState Annex.urloptions >>= \case +getUrlOptions :: Maybe RemoteGitConfig -> Annex U.UrlOptions +getUrlOptions mgc = Annex.getState Annex.urloptions >>= \case Just uo -> return uo Nothing -> do uo <- mk @@ -81,10 +81,15 @@ >>= \case Just output -> pure (lines output) Nothing -> annexHttpHeaders <$> Annex.getGitConfig + + getweboptions = case mgc of + Just gc | not (null (remoteAnnexWebOptions gc)) -> + pure (remoteAnnexWebOptions gc) + _ -> annexWebOptions <$> Annex.getGitConfig checkallowedaddr = words . annexAllowedIPAddresses <$> Annex.getGitConfig >>= \case ["all"] -> do - curlopts <- map Param . annexWebOptions <$> Annex.getGitConfig + curlopts <- map Param <$> getweboptions allowedurlschemes <- annexAllowedUrlSchemes <$> Annex.getGitConfig let urldownloader = if null curlopts && not (any (`S.notMember` U.conduitUrlSchemes) allowedurlschemes) then U.DownloadWithConduit $ @@ -148,8 +153,8 @@ ipAddressesUnlimited = ("all" == ) . annexAllowedIPAddresses <$> Annex.getGitConfig -withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a -withUrlOptions a = a =<< getUrlOptions +withUrlOptions :: Maybe RemoteGitConfig -> (U.UrlOptions -> Annex a) -> Annex a +withUrlOptions mgc a = a =<< getUrlOptions mgc -- When downloading an url, if authentication is needed, uses -- git-credential to prompt for username and password. @@ -157,10 +162,10 @@ -- 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 -- handles authentication. -withUrlOptionsPromptingCreds :: (U.UrlOptions -> Annex a) -> Annex a -withUrlOptionsPromptingCreds a = do +withUrlOptionsPromptingCreds :: Maybe RemoteGitConfig -> (U.UrlOptions -> Annex a) -> Annex a +withUrlOptionsPromptingCreds mgc a = do g <- Annex.gitRepo - uo <- getUrlOptions + uo <- getUrlOptions mgc prompter <- mkPrompter cc <- Annex.getRead Annex.gitcredentialcache a $ uo diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -74,7 +74,7 @@ -- ) youtubeDl :: URLString -> OsPath -> MeterUpdate -> Annex (Either String (Maybe OsPath)) youtubeDl url workdir p = ifM ipAddressesUnlimited - ( withUrlOptions $ youtubeDl' url workdir p + ( withUrlOptions Nothing $ youtubeDl' url workdir p , return $ Left youtubeDlNotAllowedMessage ) @@ -194,7 +194,7 @@ -- without it. So, this first downloads part of the content and checks -- if it's a html page; only then is youtube-dl used. htmlOnly :: URLString -> a -> Annex a -> Annex a -htmlOnly url fallback a = withUrlOptions $ \uo -> +htmlOnly url fallback a = withUrlOptions Nothing $ \uo -> liftIO (downloadPartial url uo htmlPrefixLength) >>= \case Just bs | isHtmlBs bs -> a _ -> return fallback @@ -202,7 +202,7 @@ -- Check if youtube-dl supports downloading content from an url. youtubeDlSupported :: URLString -> Annex Bool youtubeDlSupported url = either (const False) id - <$> withUrlOptions (youtubeDlCheck' url) + <$> withUrlOptions Nothing (youtubeDlCheck' url) -- Check if youtube-dl can find media in an url. -- @@ -211,7 +211,7 @@ -- download won't succeed. youtubeDlCheck :: URLString -> Annex (Either String Bool) youtubeDlCheck url = ifM youtubeDlAllowed - ( withUrlOptions $ youtubeDlCheck' url + ( withUrlOptions Nothing $ youtubeDlCheck' url , return $ Left youtubeDlNotAllowedMessage ) @@ -227,7 +227,7 @@ -- -- (This is not always identical to the filename it uses when downloading.) youtubeDlFileName :: URLString -> Annex (Either String OsPath) -youtubeDlFileName url = withUrlOptions go +youtubeDlFileName url = withUrlOptions Nothing go where go uo | supportedScheme uo url = flip catchIO (pure . Left . show) $ @@ -238,7 +238,7 @@ -- Does not check if the url contains htmlOnly; use when that's already -- been verified. youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String OsPath) -youtubeDlFileNameHtmlOnly = withUrlOptions . youtubeDlFileNameHtmlOnly' +youtubeDlFileNameHtmlOnly = withUrlOptions Nothing . youtubeDlFileNameHtmlOnly' youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String OsPath) youtubeDlFileNameHtmlOnly' url uo diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -324,7 +324,7 @@ downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution) downloadDistributionInfo = do - uo <- liftAnnex Url.getUrlOptions + uo <- liftAnnex $ Url.getUrlOptions Nothing gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig liftIO $ withTmpDir (literalOsPath "git-annex.tmp") $ \tmpdir -> do let infof = tmpdir literalOsPath "info" diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -179,7 +179,7 @@ getRepoInfo :: RemoteConfig -> Widget getRepoInfo c = do - uo <- liftAnnex Url.getUrlOptions + uo <- liftAnnex $ Url.getUrlOptions Nothing urlexists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo [whamlet| diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,26 @@ +git-annex (10.20250416) upstream; urgency=medium + + * Added the mask special remote. + * updatecluster, updateproxy: When a remote that has no annex-uuid is + configured as annex-cluster-node, warn and avoid writing bad data to + the git-annex branch. + * Fix build without the assistant. + * fsck: Avoid complaining about required content of dead repositories. + * drop: Avoid redundant object directory thawing. + * httpalso: Windows url fix. + * Added remote.name.annex-web-options config, which is a per-remote + version of the annex.web-options config. + * migrate: Fix --remove-size to work when a file is not present. + Fixes reversion introduced in version 10.20231129. + * Support git remotes that use a IPV6 link-local address with a zone ID. + * Support git remotes that use an url with a user name that is URL + encoded, or in the case of an "scp-style" url, a user name that must be + encoded to be legal in an URL. + * Fix git-lfs special remote ssh endpoint discovery when the repository + path is URL encoded. + + -- Joey Hess Wed, 16 Apr 2025 13:34:40 -0400 + git-annex (10.20250320) upstream; urgency=medium * Added the compute special remote. diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -496,7 +496,7 @@ resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String) resolveSpecialRemoteWebUrl url | "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl = - Url.withUrlOptionsPromptingCreds $ \uo -> + Url.withUrlOptionsPromptingCreds Nothing $ \uo -> withTmpFile (literalOsPath "git-remote-annex") $ \tmp h -> do liftIO $ hClose h Url.download' nullMeterUpdate Nothing url tmp uo >>= \case diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -251,7 +251,7 @@ go url = startingAddUrl si urlstring o $ if relaxedOption (downloadOptions o) then go' url Url.assumeUrlExists - else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case + else Url.withUrlOptions Nothing (Url.getUrlInfo urlstring) >>= \case Right urlinfo -> go' url urlinfo Left err -> do warning (UnquotedString err) @@ -352,7 +352,8 @@ go =<< downloadWith' downloader urlkey webUUID url file where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing (verifiableOption o) - downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f + downloader f p = Url.withUrlOptions Nothing $ + downloadUrl False urlkey p Nothing [url] f go Nothing = return Nothing go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile tmp)) ( tryyoutubedl tmp backend diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -375,11 +375,13 @@ -- Can't be checked if there's no associated file. AssociatedFile Nothing -> return True AssociatedFile (Just _) -> do - requiredlocs <- S.fromList . M.keys <$> requiredContentMap - if S.null requiredlocs + requiredlocs <- filterM notdead =<< (M.keys <$> requiredContentMap) + if null requiredlocs then return True - else go requiredlocs + else go (S.fromList requiredlocs) where + notdead u = (/=) DeadTrusted <$> lookupTrust u + go requiredlocs = do presentlocs <- S.fromList <$> loggedLocations key missinglocs <- filterM diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -268,7 +268,7 @@ downloadFeed :: URLString -> FilePath -> Annex Bool downloadFeed url f | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" - | otherwise = Url.withUrlOptions $ + | otherwise = Url.withUrlOptions Nothing $ Url.download nullMeterUpdate Nothing url (toOsPath f) startDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> CommandStart @@ -367,7 +367,7 @@ let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f if relaxedOption (downloadOptions opts) then go Url.assumeUrlExists - else Url.withUrlOptions (Url.getUrlInfo url) >>= \case + else Url.withUrlOptions Nothing (Url.getUrlInfo url) >>= \case Right urlinfo -> go urlinfo Left err -> do warning (UnquotedString err) diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -90,7 +90,7 @@ newbackend <- chooseBackend file if (newbackend /= oldbackend || upgradableKey oldbackend || forced) && exists then go False oldbackend newbackend - else if cantweaksize newbackend oldbackend && exists + else if cantweaksize newbackend oldbackend exists then go True oldbackend newbackend else stop where @@ -101,10 +101,10 @@ starting "migrate" (mkActionItem (key, file)) si $ perform onlytweaksize o file key keyrec oldbackend newbackend - cantweaksize newbackend oldbackend + cantweaksize newbackend oldbackend exists | removeSize o = isJust (fromKey keySize key) | newbackend /= oldbackend = False - | isNothing (fromKey keySize key) = True + | isNothing (fromKey keySize key) && exists = True | otherwise = False upgradableKey oldbackend = maybe False (\a -> a key) (canUpgradeKey oldbackend) diff --git a/Command/UpdateCluster.hs b/Command/UpdateCluster.hs --- a/Command/UpdateCluster.hs +++ b/Command/UpdateCluster.hs @@ -38,7 +38,7 @@ Nothing -> return Nothing Just [] -> return Nothing Just clusternames -> - ifM (Command.UpdateProxy.checkCanProxy r "Cannot use this special remote as a cluster node.") + ifM (Command.UpdateProxy.checkCanProxy r "Cannot use this remote as a cluster node.") ( return $ Just $ M.fromList $ zip clusternames (repeat (S.singleton r)) , return Nothing diff --git a/Command/UpdateProxy.hs b/Command/UpdateProxy.hs --- a/Command/UpdateProxy.hs +++ b/Command/UpdateProxy.hs @@ -59,24 +59,32 @@ isproxy r | remoteAnnexProxy (R.gitconfig r) || not (null (remoteAnnexClusterNode (R.gitconfig r))) = - checkCanProxy r "Cannot proxy to this special remote." + checkCanProxy r "Cannot proxy to this remote." | otherwise = pure False checkCanProxy :: Remote -> String -> Annex Bool -checkCanProxy r cannotmessage = - ifM (R.isExportSupported r) - ( if annexObjects (R.config r) - then pure True - else do - warnannexobjects - pure False - , pure True - ) +checkCanProxy r cannotmessage + | R.uuid r == NoUUID = do + warning $ UnquotedString $ unwords + [ R.name r + , "is a git remote without a known annex-uuid." + , cannotmessage + ] + pure False + | otherwise = + ifM (R.isExportSupported r) + ( if annexObjects (R.config r) + then pure True + else do + warnannexobjects + pure False + , pure True + ) where warnannexobjects = warning $ UnquotedString $ unwords [ R.name r - , "is configured with exporttree=yes, but without" - , "annexobjects=yes." + , "is a special remote configured with exporttree=yes," + , "but without annexobjects=yes." , cannotmessage , "Suggest you run: git-annex enableremote" , R.name r diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -103,9 +103,10 @@ urlstyle v = isURI (escapeURIString isUnescapedInURI v) -- git remotes can be written scp style -- [user@]host:dir -- but foo::bar is a git-remote-helper location instead + -- (although '::' can also be part of an IPV6 address) scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v) - && not ("::" `isInfixOf` v) + && not ("::" `isInfixOf` (takeWhile (/= '[') v)) scptourl v = "ssh://" ++ host ++ slash dir where (host, dir) diff --git a/Git/Url.hs b/Git/Url.hs --- a/Git/Url.hs +++ b/Git/Url.hs @@ -36,9 +36,14 @@ len = length rest - 1 fixup x = x -{- Hostname of an URL repo. -} +{- Hostname of an URL repo. + - + - An IPV6 link-local address in an url can include a + - scope, eg "%wlan0". The "%" is necessarily URI-encoded + - as "%25" in the URI. So the hostname gets URI-decoded here. + -} host :: Repo -> Maybe String -host = authpart uriRegName' +host = authpart (unEscapeString . uriRegName') {- Port of an URL repo, if it has a nonstandard one. -} port :: Repo -> Maybe Integer @@ -49,11 +54,14 @@ Just (':':p) -> readish p Just _ -> Nothing -{- Hostname of an URL repo, including any username (ie, "user@host") -} +{- Hostname of an URL repo, including any username (ie, "user@host") + - + - Both the username and hostname are URI-decoded. + -} hostuser :: Repo -> Maybe String hostuser r = (++) - <$> authpart uriUserInfo r - <*> authpart uriRegName' r + <$> authpart (unEscapeString . uriUserInfo) r + <*> host r {- The full authority portion an URL repo. (ie, "user@host:port") -} authority :: Repo -> Maybe String @@ -66,7 +74,7 @@ authpart a Repo { location = Url u } = a <$> uriAuthority u authpart _ _ = Nothing -{- Path part of an URL repo. -} +{- Path part of an URL repo. It is URI-decoded. -} path :: Repo -> Maybe FilePath -path Repo { location = Url u } = Just (uriPath u) +path Repo { location = Url u } = Just $ unEscapeString $ uriPath u path _ = Nothing diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -100,7 +100,7 @@ case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of Nothing -> error "internal" Just baseurl -> do - mgr <- httpManager <$> getUrlOptions + mgr <- httpManager <$> getUrlOptions Nothing let clientenv = mkClientEnv mgr baseurl ccv <- Annex.getRead Annex.gitcredentialcache Git.CredentialCache cc <- liftIO $ atomically $ diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -66,7 +66,7 @@ , cost = cst , name = Git.repoDescribe r , storeKey = uploadKey - , retrieveKeyFile = downloadKey + , retrieveKeyFile = downloadKey gc -- Bittorrent downloads out of order, but downloadTorrentContent -- moves the downloaded file to the destination at the end. , retrieveKeyFileInOrder = pure True @@ -94,12 +94,12 @@ , mkUnavailable = return Nothing , getInfo = return [] , claimUrl = Just (pure . isSupportedUrl) - , checkUrl = Just checkTorrentUrl + , checkUrl = Just (checkTorrentUrl gc) , remoteStateHandle = rs } -downloadKey :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification -downloadKey key _file dest p _ = do +downloadKey :: RemoteGitConfig -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey gc key _file dest p _ = do get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key -- While bittorrent verifies the hash in the torrent file, -- the torrent file itself is downloaded without verification, @@ -112,7 +112,7 @@ ok <- untilTrue urls $ \(u, filenum) -> do registerTorrentCleanup u checkDependencies - ifM (downloadTorrentFile u) + ifM (downloadTorrentFile gc u) ( downloadTorrentContent key u dest filenum p , return False ) @@ -151,11 +151,11 @@ checkbt (Just uri) | "xt=urn:btih:" `isInfixOf` uriQuery uri = True checkbt _ = False -checkTorrentUrl :: URLString -> Annex UrlContents -checkTorrentUrl u = do +checkTorrentUrl :: RemoteGitConfig -> URLString -> Annex UrlContents +checkTorrentUrl gc u = do checkDependencies registerTorrentCleanup u - ifM (downloadTorrentFile u) + ifM (downloadTorrentFile gc u) ( torrentContents u , giveup "could not download torrent file" ) @@ -192,8 +192,8 @@ liftIO . removeWhenExistsWith removeFile =<< tmpTorrentFile u {- Downloads the torrent file. (Not its contents.) -} -downloadTorrentFile :: URLString -> Annex Bool -downloadTorrentFile u = do +downloadTorrentFile :: RemoteGitConfig -> URLString -> Annex Bool +downloadTorrentFile gc u = do torrent <- tmpTorrentFile u ifM (liftIO $ doesFileExist torrent) ( return True @@ -213,7 +213,7 @@ withTmpFileIn othertmp (literalOsPath "torrent") $ \f h -> do liftIO $ hClose h resetAnnexFilePerm f - ok <- Url.withUrlOptions $ + ok <- Url.withUrlOptions (Just gc) $ Url.download nullMeterUpdate Nothing u f when ok $ liftIO $ moveFile f torrent diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -77,9 +77,9 @@ exportUnsupported return $ Just $ specialRemote c readonlyStorer - retrieveUrl + (retrieveUrl gc) readonlyRemoveKey - checkKeyUrl + (checkKeyUrl gc) rmt | otherwise = do c <- parsedRemoteConfig remote rc @@ -834,16 +834,16 @@ where mkmulti (u, s, f) = (u, s, toOsPath f) -retrieveUrl :: Retriever -retrieveUrl = fileRetriever' $ \f k p iv -> do +retrieveUrl :: RemoteGitConfig -> Retriever +retrieveUrl gc = fileRetriever' $ \f k p iv -> do us <- getWebUrls k - unlessM (withUrlOptions $ downloadUrl True k p iv us f) $ + unlessM (withUrlOptions (Just gc) $ downloadUrl True k p iv us f) $ giveup "failed to download content" -checkKeyUrl :: CheckPresent -checkKeyUrl k = do +checkKeyUrl :: RemoteGitConfig -> CheckPresent +checkKeyUrl gc k = do us <- getWebUrls k - anyM (\u -> withUrlOptions $ checkBoth u (fromKey keySize k)) us + anyM (\u -> withUrlOptions (Just gc) $ checkBoth u (fromKey keySize k)) us getWebUrls :: Key -> Annex [URLString] getWebUrls key = filter supported <$> getUrls key diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -142,11 +142,11 @@ - etc. -} gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) -gitSetup Init mu _ c _ = do +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 - r' <- tryGitConfigRead False r False + r' <- tryGitConfigRead gc False r False let u = getUncachedUUID r' if u == NoUUID then giveup "git repository does not have an annex uuid" @@ -187,10 +187,10 @@ case (repoCheap r, annexignore, hasuuid) of (_, True, _) -> return r (True, _, _) - | remoteAnnexCheckUUID gc -> tryGitConfigRead autoinit r hasuuid + | remoteAnnexCheckUUID gc -> tryGitConfigRead gc autoinit r hasuuid | otherwise -> return r (False, _, False) -> configSpecialGitRemotes r >>= \case - Nothing -> tryGitConfigRead autoinit r False + Nothing -> tryGitConfigRead gc autoinit r False Just r' -> return r' _ -> return r @@ -273,8 +273,8 @@ {- Tries to read the config for a specified remote, updates state, and - returns the updated repo. -} -tryGitConfigRead :: Bool -> Git.Repo -> Bool -> Annex Git.Repo -tryGitConfigRead autoinit r hasuuid +tryGitConfigRead :: RemoteGitConfig -> Bool -> Git.Repo -> Bool -> Annex Git.Repo +tryGitConfigRead gc autoinit r hasuuid | haveconfig r = return r -- already read | Git.repoIsSsh r = storeUpdatedRemote $ do v <- Ssh.onRemote NoConsumeStdin r @@ -323,7 +323,7 @@ warning $ UnquotedString $ "Unable to parse git config from " ++ configloc return $ Left exitcode - geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do + geturlconfig = Url.withUrlOptionsPromptingCreds (Just gc) $ \uo -> do let url = Git.repoLocation r ++ "/config" v <- withTmpFile (literalOsPath "git-annex.tmp") $ \tmpfile h -> do liftIO $ hClose h @@ -449,7 +449,7 @@ checkp2phttp = p2pHttpClient rmt giveup (clientCheckPresent key) checkhttp = do gc <- Annex.getGitConfig - Url.withUrlOptionsPromptingCreds $ \uo -> + Url.withUrlOptionsPromptingCreds (Just (gitconfig rmt)) $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key) checkremote = P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt)) key @@ -570,7 +570,7 @@ | isP2PHttp r = copyp2phttp | Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do gc <- Annex.getGitConfig - ok <- Url.withUrlOptionsPromptingCreds $ + ok <- Url.withUrlOptionsPromptingCreds (Just (gitconfig r)) $ Annex.Content.downloadUrl False key meterupdate iv (keyUrls gc repo r key) dest unless ok $ giveup "failed to download content" @@ -890,7 +890,7 @@ rv <- liftIO newEmptyMVar let getrepo = ifM (liftIO $ isEmptyMVar rv) ( do - r' <- tryGitConfigRead False r True + r' <- tryGitConfigRead gc False r True let t = (r', extractGitConfig FromGitConfig r') void $ liftIO $ tryPutMVar rv t return t diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -101,7 +101,7 @@ } return $ Just $ specialRemote' specialcfg c (store rs h) - (retrieve rs h) + (retrieve gc rs h) (remove h) (checkKey rs h) (this c cst h) @@ -367,7 +367,7 @@ -- Not for use in downloading an object. makeSmallAPIRequest :: Request -> Annex (Response L.ByteString) makeSmallAPIRequest req = do - uo <- getUrlOptions + uo <- getUrlOptions Nothing let req' = applyRequest uo req fastDebug "Remote.GitLFS" (show req') resp <- liftIO $ httpLbs req' (httpManager uo) @@ -499,8 +499,8 @@ Just reqs -> forM_ reqs $ makeSmallAPIRequest . setRequestCheckStatus -retrieve :: RemoteStateHandle -> TVar LFSHandle -> Retriever -retrieve rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownload h >>= \case +retrieve :: RemoteGitConfig -> RemoteStateHandle -> TVar LFSHandle -> Retriever +retrieve gc rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownload h >>= \case Nothing -> giveup "unable to connect to git-lfs endpoint" Just endpoint -> mkDownloadRequest rs k >>= \case Nothing -> giveup "unable to download this object from git-lfs" @@ -520,7 +520,7 @@ Just op -> case LFS.downloadOperationRequest op of Nothing -> giveup "unable to parse git-lfs server download url" Just req -> do - uo <- getUrlOptions + uo <- getUrlOptions (Just gc) liftIO $ downloadConduit p iv req dest uo -- Since git-lfs does not support removing content, nothing needs to be diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -8,7 +8,7 @@ {-# LANGUAGE FlexibleContexts, ScopedTypeVariables, PackageImports #-} module Remote.Helper.Encryptable ( - EncryptionIsSetup, + EncryptionIsSetup(..), encryptionSetup, noEncryptionUsed, encryptionAlreadySetup, diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -1,6 +1,6 @@ {- HttpAlso remote (readonly). - - - Copyright 2020-2023 Joey Hess + - Copyright 2020-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,6 +24,7 @@ import Annex.Verify import qualified Annex.Url as Url import Annex.SpecialRemote.Config +import Git.FilePath import Data.Either import qualified Data.Map as M @@ -56,9 +57,9 @@ ll <- liftIO newLearnedLayout return $ Just $ specialRemote c cannotModify - (downloadKey url ll) + (downloadKey gc url ll) cannotModify - (checkKey url ll) + (checkKey gc url ll) (this url c cst) where this url c cst = Remote @@ -78,9 +79,9 @@ , checkPresentCheap = False , exportActions = ExportActions { storeExport = cannotModify - , retrieveExport = retriveExportHttpAlso url + , retrieveExport = retriveExportHttpAlso gc url , removeExport = cannotModify - , checkPresentExport = checkPresentExportHttpAlso url + , checkPresentExport = checkPresentExportHttpAlso gc url , removeExportDirectory = Nothing , renameExport = cannotModify } @@ -120,34 +121,35 @@ gitConfigSpecialRemote u c' [("httpalso", "true")] return (c', u) -downloadKey :: Maybe URLString -> LearnedLayout -> Retriever -downloadKey baseurl ll = fileRetriever' $ \dest key p iv -> - downloadAction dest p iv (keyUrlAction baseurl ll key) +downloadKey :: RemoteGitConfig -> Maybe URLString -> LearnedLayout -> Retriever +downloadKey gc baseurl ll = fileRetriever' $ \dest key p iv -> + downloadAction gc dest p iv (keyUrlAction baseurl ll key) -retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification -retriveExportHttpAlso baseurl key loc dest p = do +retriveExportHttpAlso :: RemoteGitConfig -> Maybe URLString -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification +retriveExportHttpAlso gc baseurl key loc dest p = do verifyKeyContentIncrementally AlwaysVerify key $ \iv -> - downloadAction dest p iv (exportLocationUrlAction baseurl loc) + downloadAction gc dest p iv (exportLocationUrlAction baseurl loc) -downloadAction :: OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () -downloadAction dest p iv run = - Url.withUrlOptions $ \uo -> +downloadAction :: RemoteGitConfig -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () +downloadAction gc dest p iv run = + Url.withUrlOptions (Just gc) $ \uo -> run (\url -> Url.download' p iv url dest uo) >>= either giveup (const (return ())) -checkKey :: Maybe URLString -> LearnedLayout -> CheckPresent -checkKey baseurl ll key = - isRight <$> keyUrlAction baseurl ll key (checkKey' key) +checkKey :: RemoteGitConfig -> Maybe URLString -> LearnedLayout -> CheckPresent +checkKey gc baseurl ll key = + isRight <$> keyUrlAction baseurl ll key (checkKey' gc key) -checkKey' :: Key -> URLString -> Annex (Either String ()) -checkKey' key url = ifM (Url.withUrlOptions $ Url.checkBoth url (fromKey keySize key)) - ( return (Right ()) - , return (Left "content not found") - ) +checkKey' :: RemoteGitConfig -> Key -> URLString -> Annex (Either String ()) +checkKey' gc key url = + ifM (Url.withUrlOptions (Just gc) $ Url.checkBoth url (fromKey keySize key)) + ( return (Right ()) + , return (Left "content not found") + ) -checkPresentExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> Annex Bool -checkPresentExportHttpAlso baseurl key loc = - isRight <$> exportLocationUrlAction baseurl loc (checkKey' key) +checkPresentExportHttpAlso :: RemoteGitConfig -> Maybe URLString -> Key -> ExportLocation -> Annex Bool +checkPresentExportHttpAlso gc baseurl key loc = + isRight <$> exportLocationUrlAction baseurl loc (checkKey' gc key) type LearnedLayout = TVar (Maybe [Key -> URLString]) @@ -228,5 +230,10 @@ ] ] where - mkurl k hasher = baseurl P. fromOsPath (hasher k) P. kf k + mkurl k hasher = baseurl + -- On windows, the hasher uses `\` path separators, + -- but for an url, it needs to use '/'. + -- So, use toInternalGitPath. + P. fromOsPath (toInternalGitPath (hasher k)) + P. kf k kf k = fromOsPath (keyFile k) diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -41,6 +41,7 @@ import qualified Remote.Hook import qualified Remote.External import qualified Remote.Compute +import qualified Remote.Mask remoteTypes :: [RemoteType] remoteTypes = map adjustExportImportRemoteType @@ -65,6 +66,7 @@ , Remote.Hook.remote , Remote.External.remote , Remote.Compute.remote + , Remote.Mask.remote ] {- Builds a list of all Remotes. diff --git a/Remote/Mask.hs b/Remote/Mask.hs new file mode 100644 --- /dev/null +++ b/Remote/Mask.hs @@ -0,0 +1,257 @@ +{- Mask another remote with added encryption + - + - Copyright 2025 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes #-} + +module Remote.Mask (remote) where + +import Annex.Common +import Types.Remote +import Types.Creds +import Types.Crypto +import qualified Git +import qualified Annex +import Remote.Helper.Special +import Remote.Helper.ExportImport +import Config +import Config.Cost +import Annex.UUID +import Types.ProposedAccepted +import Annex.SpecialRemote.Config +import Logs.UUID +import Utility.Metered +import qualified Remote.Git + +import Control.Concurrent.STM +import qualified Data.Map as M + +remote :: RemoteType +remote = specialRemoteType $ RemoteType + { typename = "mask" + , enumerate = const (findSpecialRemotes "mask") + , generate = gen + , configParser = mkRemoteConfigParser + [ optionalStringParser remoteField + (FieldDesc "remote to mask") + ] + , setup = maskSetup + , exportSupported = exportUnsupported + , importSupported = importUnsupported + , thirdPartyPopulated = False + } + +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + maskedremote <- mkMaskedRemote rc gc u + c <- parsedRemoteConfig remote rc + cst <- remoteCost gc c $ encryptedRemoteCostAdj + semiExpensiveRemoteCost + let this = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileInOrder = pure True + , retrieveKeyFileCheap = Nothing + , retrievalSecurityPolicy = RetrievalVerifiableKeysSecure + , removeKey = removeKeyDummy + , lockContent = Nothing + , checkPresent = checkPresentDummy + , checkPresentCheap = False + , exportActions = exportUnsupported + , importActions = importUnsupported + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , getRepo = return r + , gitconfig = gc + , localpath = Nothing + , remotetype = remote + , availability = pure LocallyAvailable + , readonly = False + , appendonly = False + , untrustworthy = False + , mkUnavailable = return Nothing + , getInfo = getInfo =<< getMaskedRemote maskedremote + , claimUrl = Nothing + , checkUrl = Nothing + , remoteStateHandle = rs + } + return $ Just $ specialRemote c + (store maskedremote) + (retrieve maskedremote) + (remove maskedremote) + (checkKey maskedremote) + this + +maskSetup :: SetupStage -> Maybe UUID -> 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 + (r:_) -> return r + [] -> giveup $ "There is no remote named \"" ++ maskremotename ++ "\"" + case setupstage of + Init -> do + maskremotename <- maybe + (giveup "Specify remote=") + (pure . fromProposedAccepted) + (M.lookup remoteField c) + setupremote =<< findnamed maskremotename + _ -> case M.lookup remoteField c of + -- enableremote with remote= overrides the remote + -- name that was used with initremote. + Just (Proposed maskremotename) -> do + r <- findnamed maskremotename + unless (uuid r == maskremoteuuid) $ + giveup $ "Remote \"" ++ maskremotename ++ "\" does not have the expected uuid (" ++ fromUUID maskremoteuuid ++ ")" + setupremote r + _ -> enableremote remotelist + where + setupremote r = do + let c' = M.insert remoteUUIDField + (Proposed (fromUUID (uuid r) :: String)) c + (c'', encsetup) <- encryptionSetup c' gc + verifyencryptionok encsetup r + + u <- maybe (liftIO genUUID) return mu + gitConfigSpecialRemote u c'' [ ("mask", name r) ] + return (c'', u) + + maskremoteuuid = fromMaybe NoUUID $ + toUUID . fromProposedAccepted + <$> M.lookup remoteUUIDField c + + enableremote remotelist = do + case filter (\r -> uuid r == maskremoteuuid) remotelist of + (r:_) -> setupremote r + [] -> case setupstage of + Enable _ -> + missingMaskedRemote maskremoteuuid + -- When autoenabling, the masked remote may + -- get autoenabled later, or need to be + -- manually enabled. + _ -> do + (c', _) <- encryptionSetup c gc + u <- maybe (liftIO genUUID) return mu + gitConfigSpecialRemote u c' [ ("mask", "true") ] + return (c', u) + + verifyencryptionok NoEncryption _ = + giveup "Must use encryption with a mask special remote." + verifyencryptionok EncryptionIsSetup r + | remotetype r == Remote.Git.remote = + verifyencryptionokgit + | otherwise = noop + + verifyencryptionokgit = case parseEncryptionMethod c of + Right SharedEncryption -> + giveup "It's not secure to use encryption=shared with a git remote." + _ -> noop + +newtype MaskedRemote = MaskedRemote { getMaskedRemote :: Annex Remote } + +-- findMaskedRemote won't work until the remote list has been populated, +-- so has to be done on the fly rather than at generation time. +-- This caches it for speed. +mkMaskedRemote :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex MaskedRemote +mkMaskedRemote c gc u = do + v <- liftIO $ newTMVarIO Nothing + return $ MaskedRemote $ + liftIO (atomically (takeTMVar v)) >>= \case + Just maskedremote -> return maskedremote + Nothing -> do + maskedremote <- findMaskedRemote c gc u + liftIO $ atomically $ putTMVar v (Just maskedremote) + return maskedremote + +findMaskedRemote :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex Remote +findMaskedRemote c gc myuuid = case remoteAnnexMask gc of + -- This remote was autoenabled, so use any remote with the + -- uuid of the masked remote, so that it can also be autoenabled. + Just "true" -> + case getmaskedremoteuuid of + Just maskremoteuuid -> + selectremote maskremoteuuid $ \r -> + uuid r == maskremoteuuid + Nothing -> missingMaskedRemote NoUUID + Just maskremotename -> + selectremote (fromMaybe NoUUID getmaskedremoteuuid) $ \r -> + name r == maskremotename + && Just (uuid r) == getmaskedremoteuuid + Nothing -> missingMaskedRemote NoUUID + where + getmaskedremoteuuid = toUUID . fromProposedAccepted + <$> M.lookup remoteUUIDField c + selectremote u f = do + remotelist <- Annex.getState Annex.remotes + case filter f remotelist of + (r:_) + | uuid r == myuuid -> giveup "Mask special remote is configured to mask itself. This is not a valid configuration." + -- Avoid cycles, and there is no benefit + -- to masking a mask special remote. + | remotetype r == remote -> giveup "Mask special remote is configured to mask another mask special remote. This is not supported." + | otherwise -> return r + [] -> missingMaskedRemote u + +missingMaskedRemote :: UUID -> Annex a +missingMaskedRemote maskremoteuuid = do + descmap <- uuidDescMap + let desc = case M.lookup maskremoteuuid descmap of + Just (UUIDDesc d) -> decodeBS d + Nothing -> "" + giveup $ unlines + [ "Before this mask special remote can be used, you must set up the remote it uses:" + , " " ++ fromUUID maskremoteuuid ++ " -- " ++ desc + ] + +store :: MaskedRemote -> Storer +store maskedremote k src p = do + r <- getMaskedRemote maskedremote + storeMasked r k src p + +storeMasked :: Remote -> Storer +storeMasked maskedremote = + fileStorer $ \k f p -> storeKey maskedremote k af (Just f) p + where + af = AssociatedFile Nothing + +retrieve :: MaskedRemote -> Retriever +retrieve maskedremote k p dest iv callback = do + r <- getMaskedRemote maskedremote + fileRetriever (retrieveMasked r) k p dest iv callback + +retrieveMasked :: Remote -> OsPath -> Key -> MeterUpdate -> Annex () +retrieveMasked maskedremote dest k p = + -- The masked remote does not need to verify, because fileRetriever + -- does its own verification. + void $ retrieveKeyFile maskedremote k af dest p NoVerify + where + af = AssociatedFile Nothing + +remove :: MaskedRemote -> Remover +remove maskedremote proof k = do + r <- getMaskedRemote maskedremote + removeMasked r proof k + +removeMasked :: Remote -> Remover +removeMasked maskedremote = removeKey maskedremote + +checkKey :: MaskedRemote -> CheckPresent +checkKey maskedremote k = do + r <- getMaskedRemote maskedremote + checkKeyMasked r k + +checkKeyMasked :: Remote -> CheckPresent +checkKeyMasked maskedremote = checkPresent maskedremote + +remoteField :: RemoteConfigField +remoteField = Accepted "remote" + +remoteUUIDField :: RemoteConfigField +remoteUUIDField = Accepted "remoteuuid" diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -427,7 +427,7 @@ Left failreason -> do warning (UnquotedString failreason) giveup "cannot download content" - Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us f) $ + Right us -> unlessM (withUrlOptions Nothing $ downloadUrl False k p iv us f) $ giveup "failed to download content" Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -475,7 +475,7 @@ warning (UnquotedString failreason) giveup "cannot check content" Right us -> do - let check u = withUrlOptions $ + let check u = withUrlOptions Nothing $ Url.checkBoth u (fromKey keySize k) anyM check us Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -516,7 +516,7 @@ Right h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv Left S3HandleNeedCreds -> case getPublicUrlMaker info of Just geturl -> either giveup return =<< - Url.withUrlOptions + withUrlOptions Nothing (Url.download' p iv (geturl exportloc) f) Nothing -> giveup $ needS3Creds (uuid r) Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -537,7 +537,7 @@ checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case Right h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc)) Left S3HandleNeedCreds -> case getPublicUrlMaker info of - Just geturl -> withUrlOptions $ + Just geturl -> withUrlOptions Nothing $ Url.checkBoth (geturl $ bucketExportLocation info loc) (fromKey keySize k) Nothing -> giveupS3HandleProblem S3HandleNeedCreds (uuid r) Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -913,7 +913,7 @@ Nothing -> return (Left S3HandleNeedCreds) where go awscreds = do - ou <- getUrlOptions + ou <- getUrlOptions Nothing ua <- getUserAgent let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing let s3cfg = s3Configuration (Just ua) c diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -75,7 +75,7 @@ , cost = cst , name = Git.repoDescribe r , storeKey = uploadKey - , retrieveKeyFile = downloadKey urlincludeexclude + , retrieveKeyFile = downloadKey gc urlincludeexclude , retrieveKeyFileInOrder = pure True , retrieveKeyFileCheap = Nothing -- HttpManagerRestricted is used here, so this is @@ -83,7 +83,7 @@ , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = dropKey urlincludeexclude , lockContent = Nothing - , checkPresent = checkKey urlincludeexclude + , checkPresent = checkKey gc urlincludeexclude , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported @@ -115,8 +115,8 @@ gitConfigSpecialRemote u c [("web", "true")] return (c, u) -downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification -downloadKey urlincludeexclude key _af dest p vc = +downloadKey :: RemoteGitConfig -> UrlIncludeExclude -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey gc urlincludeexclude key _af dest p vc = go =<< getWebUrls' urlincludeexclude key where go [] = giveup "no known url" @@ -138,7 +138,7 @@ ) dl (us, ytus) = do iv <- startVerifyKeyContentIncrementally vc key - ifM (Url.withUrlOptions $ downloadUrl True key p iv (map fst us) dest) + ifM (Url.withUrlOptions (Just gc) $ downloadUrl True key p iv (map fst us) dest) ( finishVerifyKeyContentIncrementally iv >>= \case (True, v) -> postdl v (False, _) -> dl ([], ytus) @@ -177,19 +177,21 @@ dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex () dropKey urlincludeexclude _proof k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k -checkKey :: UrlIncludeExclude -> Key -> Annex Bool -checkKey urlincludeexclude key = do +checkKey :: RemoteGitConfig -> UrlIncludeExclude -> Key -> Annex Bool +checkKey gc urlincludeexclude key = do us <- getWebUrls' urlincludeexclude key if null us then return False - else either giveup return =<< checkKey' key us -checkKey' :: Key -> [URLString] -> Annex (Either String Bool) -checkKey' key us = firsthit us (Right False) $ \u -> do + else either giveup return =<< checkKey' gc key us + +checkKey' :: RemoteGitConfig -> Key -> [URLString] -> Annex (Either String Bool) +checkKey' gc key us = firsthit us (Right False) $ \u -> do let (u', downloader) = getDownloader u case downloader of YoutubeDownloader -> youtubeDlCheck u' _ -> catchMsgIO $ - Url.withUrlOptions $ Url.checkBoth u' (fromKey keySize key) + Url.withUrlOptions (Just gc) $ + Url.checkBoth u' (fromKey keySize key) where firsthit [] miss _ = return miss firsthit (u:rest) _ a = do diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -404,6 +404,7 @@ , remoteAnnexBwLimitUpload :: Maybe BwRate , remoteAnnexBwLimitDownload :: Maybe BwRate , remoteAnnexAllowUnverifiedDownloads :: Bool + , remoteAnnexWebOptions :: [String] , remoteAnnexUUID :: Maybe UUID , remoteAnnexConfigUUID :: Maybe UUID , remoteAnnexMaxGitBundles :: Int @@ -440,6 +441,7 @@ , remoteAnnexDdarRepo :: Maybe String , remoteAnnexHookType :: Maybe String , remoteAnnexExternalType :: Maybe String + , remoteAnnexMask :: Maybe String } {- The Git.Repo is the local repository, which has the remote with the @@ -492,6 +494,7 @@ readBwRatePerSecond =<< getmaybe BWLimitDownloadField , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe SecurityAllowUnverifiedDownloadsField + , remoteAnnexWebOptions = getwords WebOptionsField , remoteAnnexUUID = toUUID <$> getmaybe UUIDField , remoteAnnexConfigUUID = toUUID <$> getmaybe ConfigUUIDField , remoteAnnexMaxGitBundles = @@ -539,6 +542,7 @@ , remoteAnnexDdarRepo = getmaybe DdarRepoField , remoteAnnexHookType = notempty $ getmaybe HookTypeField , remoteAnnexExternalType = notempty $ getmaybe ExternalTypeField + , remoteAnnexMask = notempty $ getmaybe MaskField } where getbool k d = fromMaybe d $ getmaybebool k @@ -556,6 +560,7 @@ | B.null b -> Nothing | otherwise -> Just (decodeBS b) _ -> Nothing + getwords k = fromMaybe [] $ words <$> getmaybe k data RemoteGitConfigField = CostField @@ -588,6 +593,7 @@ | UUIDField | ConfigUUIDField | SecurityAllowUnverifiedDownloadsField + | WebOptionsField | MaxGitBundlesField | AllowEncryptedGitRepoField | ProxyField @@ -619,6 +625,7 @@ | DdarRepoField | HookTypeField | ExternalTypeField + | MaskField deriving (Enum, Bounded) remoteGitConfigField :: RemoteGitConfigField -> (MkRemoteConfigKey, ProxyInherited) @@ -656,6 +663,7 @@ UUIDField -> uninherited True "uuid" ConfigUUIDField -> uninherited True "config-uuid" SecurityAllowUnverifiedDownloadsField -> inherited True "security-allow-unverified-downloads" + WebOptionsField -> inherited True "web-options" MaxGitBundlesField -> inherited True "max-git-bundles" AllowEncryptedGitRepoField -> inherited True "allow-encrypted-gitrepo" -- Allow proxy chains. @@ -688,6 +696,7 @@ DdarRepoField -> uninherited True "ddarrepo" HookTypeField -> uninherited True "hooktype" ExternalTypeField -> uninherited True "externaltype" + MaskField -> uninherited True "mask" where inherited True f = (MkRemoteAnnexConfigKey f, ProxyInherited True) inherited False f = (MkRemoteConfigKey f, ProxyInherited True) diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -89,6 +89,8 @@ -- Remotes have a use cost; higher is more expensive , cost :: Cost -- Transfers a key's contents from disk to the remote. + -- The optional OsPath is the location of the key's object file. + -- When not provided, uses the annex object file. -- The key should not appear to be present on the remote until -- all of its contents have been transferred. -- Throws exception on failure. diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -139,7 +139,7 @@ runstartup $ Win32Notify.watchDir dir prune scanevents hooks #else type DirWatcherHandle = () -watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle +watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle watchDir = error "watchDir not defined" #endif #endif diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20250320 +Version: 10.20250416 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -964,6 +964,7 @@ Remote.Hook Remote.List Remote.List.Util + Remote.Mask Remote.P2P Remote.Rclone Remote.Rsync diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -14,11 +14,8 @@ ospath: true packages: - '.' -resolver: nightly-2025-01-20 +resolver: nightly-2025-04-04 extra-deps: -- filepath-bytestring-1.5.2.0.2 -- aws-0.24.4 -- git-lfs-1.2.5 - feed-1.3.2.1 allow-newer: true allow-newer-deps: