diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -197,7 +197,7 @@ , preferredcontentmap :: Maybe (FileMatcherMap Annex) , requiredcontentmap :: Maybe (FileMatcherMap Annex) , remoteconfigmap :: Maybe (M.Map UUID RemoteConfig) - , clusters :: Maybe Clusters + , clusters :: Maybe (Annex Clusters) , forcetrust :: TrustMap , trustmap :: Maybe TrustMap , groupmap :: Maybe GroupMap diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -210,7 +210,6 @@ storetofile _ _ n [] = pure n storetofile iv h n (b:bs) = do writeVerifyChunk iv h b - B.hPut h b storetofile iv h (n - fromIntegral (B.length b)) bs proxyget offset af k = withproxytmpfile k $ \tmpfile -> do diff --git a/Annex/Startup.hs b/Annex/Startup.hs --- a/Annex/Startup.hs +++ b/Annex/Startup.hs @@ -35,10 +35,10 @@ -} startupAnnex :: Annex () startupAnnex = doQuietAction $ - -- Logs.Location needs clusters to be loaded before it is used, - -- in order for a cluster to be treated as the location of keys + -- Logs.Location needs this before it is used, in order for a + -- cluster to be treated as the location of keys -- that are located in any of its nodes. - void loadClusters + preLoadClusters startupSignals :: Annex () startupSignals = do diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,14 @@ +git-annex (10.20240808) upstream; urgency=medium + + * Remove debug output (to stderr) accidentially included in + last version. + * When getting from a P2P HTTP remote, prompt for credentials when + required, instead of failing. + * When proxying an upload to a special remote, verify the hash. + * Avoid loading cluster log at startup. + + -- Joey Hess Thu, 08 Aug 2024 15:26:26 -0400 + git-annex (10.20240731) upstream; urgency=medium * New HTTP API that is equivilant to the P2P protocol. diff --git a/Logs/Cluster.hs b/Logs/Cluster.hs --- a/Logs/Cluster.hs +++ b/Logs/Cluster.hs @@ -11,6 +11,7 @@ module Types.Cluster, getClusters, loadClusters, + preLoadClusters, recordCluster, ) where @@ -24,8 +25,13 @@ import qualified Data.Set as S getClusters :: Annex Clusters -getClusters = maybe loadClusters return =<< Annex.getState Annex.clusters +getClusters = maybe loadClusters id =<< Annex.getState Annex.clusters +{- This works around a module dependency loop. -} +preLoadClusters :: Annex () +preLoadClusters = Annex.changeState $ \s -> + s { Annex.clusters = Just loadClusters } + {- Loads the clusters and caches it for later. - - This takes care of removing dead nodes from clusters, @@ -37,5 +43,5 @@ dead <- (S.fromList . map ClusterNodeUUID) <$> trustGet DeadTrusted clusters <- getClustersWith (M.map (`S.difference` dead)) - Annex.changeState $ \s -> s { Annex.clusters = Just clusters } + Annex.changeState $ \s -> s { Annex.clusters = Just (pure clusters) } return clusters diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -252,4 +252,4 @@ -- Cannot import Logs.Cluster due to a cycle. -- Annex.clusters gets populated when starting up git-annex. getClusters :: Annex Clusters -getClusters = fromMaybe noClusters <$> Annex.getState Annex.clusters +getClusters = maybe (pure noClusters) id =<< Annex.getState Annex.clusters diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -9,6 +9,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds, TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module P2P.Http.Client ( @@ -99,7 +100,7 @@ versions = filter allowedversion allProtocolVersions go clientenv mcred credcached mauth (v:vs) = do myuuid <- getUUID - res <- clientaction clientenv v + res <- catchclienterror $ clientaction clientenv v (B64UUID (uuid rmt)) (B64UUID myuuid) [] @@ -125,6 +126,8 @@ Left clienterror -> Just <$> fallback ("git-annex HTTP API server returned an unexpected response: " ++ show clienterror) go _ _ _ _ [] = return Nothing + + catchclienterror a = a `catch` \(ex :: ClientError) -> pure (Left ex) authrequired clientenv vs = do cred <- prompt $ diff --git a/P2P/Http/Url.hs b/P2P/Http/Url.hs --- a/P2P/Http/Url.hs +++ b/P2P/Http/Url.hs @@ -11,8 +11,8 @@ import Data.List import Network.URI -import System.FilePath.Posix as P #ifdef WITH_SERVANT +import System.FilePath.Posix as P import Servant.Client (BaseUrl(..), Scheme(..)) import Text.Read #endif @@ -37,13 +37,14 @@ parseP2PHttpUrl us | isP2PHttpProtocolUrl us = case parseURI (drop prefixlen us) of Nothing -> Nothing - Just u -> #ifdef WITH_SERVANT + Just u -> case uriScheme u of "http:" -> mkbaseurl Http u "https:" -> mkbaseurl Https u _ -> Nothing #else + Just _u -> Just $ P2PHttpUrl us #endif | otherwise = Nothing diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -29,8 +29,6 @@ mkRemoteConfigKey, ) where -import Debug.Trace - import Common import qualified Git import qualified Git.Config @@ -495,12 +493,11 @@ , remoteAnnexClusterGateway = fromMaybe [] $ (mapMaybe (mkClusterUUID . toUUID) . words) <$> getmaybe ClusterGatewayField - , remoteUrl = traceShow (mkRemoteConfigKey remotename (remoteGitConfigKey UrlField)) $ - case Git.Config.getMaybe (mkRemoteConfigKey remotename (remoteGitConfigKey UrlField)) r of - Just (ConfigValue b) - | B.null b -> Nothing - | otherwise -> Just (decodeBS b) - _ -> Nothing + , remoteUrl = case Git.Config.getMaybe (mkRemoteConfigKey remotename (remoteGitConfigKey UrlField)) r of + Just (ConfigValue b) + | B.null b -> Nothing + | otherwise -> Just (decodeBS b) + _ -> Nothing , remoteAnnexP2PHttpUrl = case Git.Config.getMaybe (mkRemoteConfigKey remotename (remoteGitConfigKey AnnexUrlField)) r of Just (ConfigValue b) -> 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.20240731 +Version: 10.20240808 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess