mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

use annex+http for accessing proxies

Browse source 
Doesn't work yet on the http server side, which is throwing 502 bad
gateway.
This commit is contained in:
Joey Hess 2024-07-25 12:00:57 -04:00
parent ba0ecbf47e
commit 0bdeafc2c4
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 112 additions and 84 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Command/ExtendCluster.hs
View file

@ -50,7 +50,7 @@ start cu clustername gatewayremote = starting "extendcluster" ai si $ do
let setcus f = setConfig f (fromUUID (fromClusterUUID cu)) let setcus f = setConfig f (fromUUID (fromClusterUUID cu))
unless (M.member clustername myclusters) $ do unless (M.member clustername myclusters) $ do
setcus $ annexConfig ("cluster." <> encodeBS clustername) setcus $ annexConfig ("cluster." <> encodeBS clustername)
setcus $ remoteAnnexConfig gatewayremote $ setcus $ mkRemoteConfigKey gatewayremote $
remoteGitConfigKey ClusterGatewayField remoteGitConfigKey ClusterGatewayField
next $ return True next $ return True
where where

22
Remote/Git.hs
View file

@ -954,6 +954,7 @@ listProxied proxies rs = concat <$> mapM go rs
annexconfigadjuster clusters r' = annexconfigadjuster clusters r' =
let c = adduuid (configRepoUUID renamedr) $ let c = adduuid (configRepoUUID renamedr) $
addurl $ addurl $
addp2phttpurl $
addproxiedby $ addproxiedby $
adjustclusternode clusters $ adjustclusternode clusters $
inheritconfigs $ Git.fullconfig r' inheritconfigs $ Git.fullconfig r'
@ -965,9 +966,16 @@ listProxied proxies rs = concat <$> mapM go rs
adduuid ck = M.insert ck adduuid ck = M.insert ck
[Git.ConfigValue $ fromUUID $ proxyRemoteUUID p] [Git.ConfigValue $ fromUUID $ proxyRemoteUUID p]
addurl = M.insert (remoteConfig renamedr (remoteGitConfigKey UrlField)) addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField))
[Git.ConfigValue $ encodeBS $ Git.repoLocation r] [Git.ConfigValue $ encodeBS $ Git.repoLocation r]
addp2phttpurl = case remoteAnnexP2PHttpUrl gc of
Just u -> addremoteannexfield AnnexUrlField
[Git.ConfigValue $ encodeBS $
p2pHttpUrlWithoutUUID (p2pHttpUrlString u)
++ fromUUID (proxyRemoteUUID p)]
Nothing -> id
addproxiedby = case remoteAnnexUUID gc of addproxiedby = case remoteAnnexUUID gc of
Just u -> addremoteannexfield ProxiedByField Just u -> addremoteannexfield ProxiedByField
[Git.ConfigValue $ fromUUID u] [Git.ConfigValue $ fromUUID u]
@ -993,7 +1001,7 @@ listProxied proxies rs = concat <$> mapM go rs
proxieduuids = S.map proxyRemoteUUID proxied proxieduuids = S.map proxyRemoteUUID proxied
addremoteannexfield f = M.insert addremoteannexfield f = M.insert
(remoteAnnexConfig renamedr (remoteGitConfigKey f)) (mkRemoteConfigKey renamedr (remoteGitConfigKey f))
inheritconfigs c = foldl' inheritconfig c proxyInheritedFields inheritconfigs c = foldl' inheritconfig c proxyInheritedFields
@ -1001,8 +1009,8 @@ listProxied proxies rs = concat <$> mapM go rs
(Nothing, Just v) -> M.insert dest v c (Nothing, Just v) -> M.insert dest v c
_ -> c _ -> c
where where
src = remoteAnnexConfig r k src = mkRemoteConfigKey r k
dest = remoteAnnexConfig renamedr k dest = mkRemoteConfigKey renamedr k
-- When the git config has anything set for a remote, -- When the git config has anything set for a remote,
-- avoid making a proxied remote with the same name. -- avoid making a proxied remote with the same name.
@ -1019,11 +1027,15 @@ listProxied proxies rs = concat <$> mapM go rs
-- Proxing is also yet supported for remotes using P2P -- Proxing is also yet supported for remotes using P2P
-- addresses. -- addresses.
canproxy gc r canproxy gc r
| isP2PHttp' gc = True
| remoteAnnexGitLFS gc = False | remoteAnnexGitLFS gc = False
| Git.GCrypt.isEncrypted r = False | Git.GCrypt.isEncrypted r = False
| Git.repoIsLocal r || Git.repoIsLocalUnknown r = False | Git.repoIsLocal r || Git.repoIsLocalUnknown r = False
| otherwise = isNothing (repoP2PAddress r) | otherwise = isNothing (repoP2PAddress r)
isP2PHttp :: Remote -> Bool isP2PHttp :: Remote -> Bool
isP2PHttp = isJust . remoteAnnexP2PHttpUrl . gitconfig isP2PHttp = isP2PHttp' . gitconfig
isP2PHttp' :: RemoteGitConfig -> Bool
isP2PHttp' = isJust . remoteAnnexP2PHttpUrl

168
Types/GitConfig.hs
View file

@ -25,8 +25,12 @@ module Types.GitConfig (
RemoteGitConfigField(..), RemoteGitConfigField(..),
remoteGitConfigKey, remoteGitConfigKey,
proxyInheritedFields, proxyInheritedFields,
MkRemoteConfigKey,
mkRemoteConfigKey,
) where ) where
import Debug.Trace
import Common import Common
import qualified Git import qualified Git
import qualified Git.Config import qualified Git.Config
@ -489,14 +493,14 @@ extractRemoteGitConfig r remotename = do
, remoteAnnexClusterGateway = fromMaybe [] $ , remoteAnnexClusterGateway = fromMaybe [] $
(mapMaybe (mkClusterUUID . toUUID) . words) (mapMaybe (mkClusterUUID . toUUID) . words)
<$> getmaybe ClusterGatewayField <$> getmaybe ClusterGatewayField
, remoteUrl = , remoteUrl = traceShow (mkRemoteConfigKey remotename (remoteGitConfigKey UrlField)) $
case Git.Config.getMaybe (remoteConfig remotename (remoteGitConfigKey UrlField)) r of case Git.Config.getMaybe (mkRemoteConfigKey remotename (remoteGitConfigKey UrlField)) r of
Just (ConfigValue b) Just (ConfigValue b)
| B.null b -> Nothing | B.null b -> Nothing
| otherwise -> Just (decodeBS b) | otherwise -> Just (decodeBS b)
_ -> Nothing _ -> Nothing
, remoteAnnexP2PHttpUrl = , remoteAnnexP2PHttpUrl =
case Git.Config.getMaybe (remoteConfig remotename (remoteGitConfigKey AnnexUrlField)) r of case Git.Config.getMaybe (mkRemoteConfigKey remotename (remoteGitConfigKey AnnexUrlField)) r of
Just (ConfigValue b) -> Just (ConfigValue b) ->
parseP2PHttpUrl (decodeBS b) parseP2PHttpUrl (decodeBS b)
_ -> Nothing _ -> Nothing
@ -534,8 +538,8 @@ extractRemoteGitConfig r remotename = do
getmaybe' :: RemoteGitConfigField -> Maybe ConfigValue getmaybe' :: RemoteGitConfigField -> Maybe ConfigValue
getmaybe' f = getmaybe' f =
let k = remoteGitConfigKey f let k = remoteGitConfigKey f
in Git.Config.getMaybe (remoteAnnexConfig remotename k) r in Git.Config.getMaybe (mkRemoteConfigKey remotename k) r
<|> Git.Config.getMaybe (annexConfig k) r <|> Git.Config.getMaybe (mkAnnexConfigKey k) r
getoptions k = fromMaybe [] $ words <$> getmaybe k getoptions k = fromMaybe [] $ words <$> getmaybe k
data RemoteGitConfigField data RemoteGitConfigField
@ -602,87 +606,89 @@ data RemoteGitConfigField
| ExternalTypeField | ExternalTypeField
deriving (Enum, Bounded) deriving (Enum, Bounded)
remoteGitConfigField :: RemoteGitConfigField -> (UnqualifiedConfigKey, ProxyInherited) remoteGitConfigField :: RemoteGitConfigField -> (MkRemoteConfigKey, ProxyInherited)
remoteGitConfigField = \case remoteGitConfigField = \case
-- Hard to know the true cost of accessing eg a slow special -- Hard to know the true cost of accessing eg a slow special
-- remote via the proxy. The cost of the proxy is the best guess -- remote via the proxy. The cost of the proxy is the best guess
-- so do inherit it. -- so do inherit it.
CostField -> inherited "cost" CostField -> inherited True "cost"
CostCommandField -> inherited "cost-command" CostCommandField -> inherited True "cost-command"
IgnoreField -> inherited "ignore" IgnoreField -> inherited True "ignore"
IgnoreCommandField -> inherited "ignore-command" IgnoreCommandField -> inherited True "ignore-command"
SyncField -> inherited "sync" SyncField -> inherited True "sync"
SyncCommandField -> inherited "sync-command" SyncCommandField -> inherited True "sync-command"
PullField -> inherited "pull" PullField -> inherited True "pull"
PushField -> inherited "push" PushField -> inherited True "push"
ReadOnlyField -> inherited "readonly" ReadOnlyField -> inherited True "readonly"
CheckUUIDField -> uninherited "checkuuid" CheckUUIDField -> uninherited True "checkuuid"
VerifyField -> inherited "verify" VerifyField -> inherited True "verify"
TrackingBranchField -> uninherited "tracking-branch" TrackingBranchField -> uninherited True "tracking-branch"
ExportTrackingField -> uninherited "export-tracking" ExportTrackingField -> uninherited True "export-tracking"
TrustLevelField -> uninherited "trustlevel" TrustLevelField -> uninherited True "trustlevel"
StartCommandField -> uninherited "start-command" StartCommandField -> uninherited True "start-command"
StopCommandField -> uninherited "stop-command" StopCommandField -> uninherited True "stop-command"
SpeculatePresentField -> inherited "speculate-present" SpeculatePresentField -> inherited True "speculate-present"
BareField -> inherited "bare" BareField -> inherited True "bare"
RetryField -> inherited "retry" RetryField -> inherited True "retry"
ForwardRetryField -> inherited "forward-retry" ForwardRetryField -> inherited True "forward-retry"
RetryDelayField -> inherited "retrydelay" RetryDelayField -> inherited True "retrydelay"
StallDetectionField -> inherited "stalldetection" StallDetectionField -> inherited True "stalldetection"
StallDetectionUploadField -> inherited "stalldetection-upload" StallDetectionUploadField -> inherited True "stalldetection-upload"
StallDetectionDownloadField -> inherited "stalldetection-download" StallDetectionDownloadField -> inherited True "stalldetection-download"
BWLimitField -> inherited "bwlimit" BWLimitField -> inherited True "bwlimit"
BWLimitUploadField -> inherited "bwlimit-upload" BWLimitUploadField -> inherited True "bwlimit-upload"
BWLimitDownloadField -> inherited "bwlimit-upload" BWLimitDownloadField -> inherited True "bwlimit-upload"
UUIDField -> uninherited "uuid" UUIDField -> uninherited True "uuid"
ConfigUUIDField -> uninherited "config-uuid" ConfigUUIDField -> uninherited True "config-uuid"
SecurityAllowUnverifiedDownloadsField -> inherited "security-allow-unverified-downloads" SecurityAllowUnverifiedDownloadsField -> inherited True "security-allow-unverified-downloads"
MaxGitBundlesField -> inherited "max-git-bundles" MaxGitBundlesField -> inherited True "max-git-bundles"
AllowEncryptedGitRepoField -> inherited "allow-encrypted-gitrepo" AllowEncryptedGitRepoField -> inherited True "allow-encrypted-gitrepo"
-- Allow proxy chains. -- Allow proxy chains.
ProxyField -> inherited "proxy" ProxyField -> inherited True "proxy"
ProxiedByField -> uninherited "proxied-by" ProxiedByField -> uninherited True "proxied-by"
ClusterNodeField -> uninherited "cluster-node" ClusterNodeField -> uninherited True "cluster-node"
ClusterGatewayField -> uninherited "cluster-gateway" ClusterGatewayField -> uninherited True "cluster-gateway"
UrlField -> uninherited "url" UrlField -> uninherited False "url"
AnnexUrlField -> uninherited "annexurl" AnnexUrlField -> uninherited False "annexurl"
ShellField -> inherited "shell" ShellField -> inherited True "shell"
SshOptionsField -> inherited "ssh-options" SshOptionsField -> inherited True "ssh-options"
RsyncOptionsField -> inherited "rsync-options" RsyncOptionsField -> inherited True "rsync-options"
RsyncDownloadOptionsField -> inherited "rsync-download-options" RsyncDownloadOptionsField -> inherited True "rsync-download-options"
RsyncUploadOptionsField -> inherited "rsync-upload-options" RsyncUploadOptionsField -> inherited True "rsync-upload-options"
RsyncTransportField -> inherited "rsync-transport" RsyncTransportField -> inherited True "rsync-transport"
GnupgOptionsField -> inherited "gnupg-options" GnupgOptionsField -> inherited True "gnupg-options"
GnupgDecryptOptionsField -> inherited "gnupg-decrypt-options" GnupgDecryptOptionsField -> inherited True "gnupg-decrypt-options"
SharedSOPCommandField -> inherited "shared-sop-command" SharedSOPCommandField -> inherited True "shared-sop-command"
SharedSOPProfileField -> inherited "shared-sop-profile" SharedSOPProfileField -> inherited True "shared-sop-profile"
RsyncUrlField -> uninherited "rsyncurl" RsyncUrlField -> uninherited True "rsyncurl"
BupRepoField -> uninherited "buprepo" BupRepoField -> uninherited True "buprepo"
BorgRepoField -> uninherited "borgrepo" BorgRepoField -> uninherited True "borgrepo"
TahoeField -> uninherited "tahoe" TahoeField -> uninherited True "tahoe"
BupSplitOptionsField -> uninherited "bup-split-options" BupSplitOptionsField -> uninherited True "bup-split-options"
DirectoryField -> uninherited "directory" DirectoryField -> uninherited True "directory"
AndroidDirectoryField -> uninherited "androiddirectory" AndroidDirectoryField -> uninherited True "androiddirectory"
AndroidSerialField -> uninherited "androidserial" AndroidSerialField -> uninherited True "androidserial"
GCryptField -> uninherited "gcrypt" GCryptField -> uninherited True "gcrypt"
GitLFSField -> uninherited "git-lfs" GitLFSField -> uninherited True "git-lfs"
DdarRepoField -> uninherited "ddarrepo" DdarRepoField -> uninherited True "ddarrepo"
HookTypeField -> uninherited "hooktype" HookTypeField -> uninherited True "hooktype"
ExternalTypeField -> uninherited "externaltype" ExternalTypeField -> uninherited True "externaltype"
where where
inherited f = (f, ProxyInherited True) inherited True f = (MkRemoteAnnexConfigKey f, ProxyInherited True)
uninherited f = (f, ProxyInherited False) inherited False f = (MkRemoteConfigKey f, ProxyInherited True)
uninherited True f = (MkRemoteAnnexConfigKey f, ProxyInherited False)
uninherited False f = (MkRemoteConfigKey f, ProxyInherited False)
newtype ProxyInherited = ProxyInherited Bool newtype ProxyInherited = ProxyInherited Bool
-- All remote config fields that are inherited from a proxy. -- All remote config fields that are inherited from a proxy.
proxyInheritedFields :: [UnqualifiedConfigKey] proxyInheritedFields :: [MkRemoteConfigKey]
proxyInheritedFields = proxyInheritedFields =
map fst $ map fst $
filter (\(_, ProxyInherited p) -> p) $ filter (\(_, ProxyInherited p) -> p) $
map remoteGitConfigField [minBound..maxBound] map remoteGitConfigField [minBound..maxBound]
remoteGitConfigKey :: RemoteGitConfigField -> UnqualifiedConfigKey remoteGitConfigKey :: RemoteGitConfigField -> MkRemoteConfigKey
remoteGitConfigKey = fst . remoteGitConfigField remoteGitConfigKey = fst . remoteGitConfigField
notempty :: Maybe String -> Maybe String notempty :: Maybe String -> Maybe String
@ -694,13 +700,23 @@ dummyRemoteGitConfig :: IO RemoteGitConfig
dummyRemoteGitConfig = atomically $ dummyRemoteGitConfig = atomically $
extractRemoteGitConfig Git.Construct.fromUnknown "dummy" extractRemoteGitConfig Git.Construct.fromUnknown "dummy"
type UnqualifiedConfigKey = B.ByteString data MkRemoteConfigKey
= MkRemoteAnnexConfigKey B.ByteString
| MkRemoteConfigKey B.ByteString
mkRemoteConfigKey :: RemoteNameable r => r -> MkRemoteConfigKey -> ConfigKey
mkRemoteConfigKey r (MkRemoteAnnexConfigKey b) = remoteAnnexConfig r b
mkRemoteConfigKey r (MkRemoteConfigKey b) = remoteConfig r b
mkAnnexConfigKey :: MkRemoteConfigKey -> ConfigKey
mkAnnexConfigKey (MkRemoteAnnexConfigKey b) = annexConfig b
mkAnnexConfigKey (MkRemoteConfigKey b) = annexConfig b
annexConfigPrefix :: B.ByteString annexConfigPrefix :: B.ByteString
annexConfigPrefix = "annex." annexConfigPrefix = "annex."
{- A global annex setting in git config. -} {- A global annex setting in git config. -}
annexConfig :: UnqualifiedConfigKey -> ConfigKey annexConfig :: B.ByteString -> ConfigKey
annexConfig key = ConfigKey (annexConfigPrefix <> key) annexConfig key = ConfigKey (annexConfigPrefix <> key)
class RemoteNameable r where class RemoteNameable r where
@ -713,13 +729,13 @@ instance RemoteNameable RemoteName where
getRemoteName = id getRemoteName = id
{- A per-remote annex setting in git config. -} {- A per-remote annex setting in git config. -}
remoteAnnexConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteAnnexConfig :: RemoteNameable r => r -> B.ByteString -> ConfigKey
remoteAnnexConfig r = remoteConfig r . remoteAnnexConfigEnd remoteAnnexConfig r = remoteConfig r . remoteAnnexConfigEnd
remoteAnnexConfigEnd :: UnqualifiedConfigKey -> UnqualifiedConfigKey remoteAnnexConfigEnd :: B.ByteString -> B.ByteString
remoteAnnexConfigEnd key = "annex-" <> key remoteAnnexConfigEnd key = "annex-" <> key
{- A per-remote setting in git config. -} {- A per-remote setting in git config. -}
remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig :: RemoteNameable r => r -> B.ByteString -> ConfigKey
remoteConfig r key = ConfigKey $ remoteConfig r key = ConfigKey $
"remote." <> encodeBS (getRemoteName r) <> "." <> key "remote." <> encodeBS (getRemoteName r) <> "." <> key