File: UpdateProxy.hs

package info (click to toggle)
git-annex 10.20250416-2
  • links: PTS, VCS
  • area: main
  • in suites: trixie
  • size: 73,572 kB
  • sloc: haskell: 90,656; javascript: 9,103; sh: 1,469; makefile: 211; perl: 137; ansic: 44
file content (129 lines) | stat: -rw-r--r-- 3,930 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
{- git-annex command
 -
 - Copyright 2024 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module Command.UpdateProxy where

import Command
import qualified Annex
import Logs.Proxy
import Logs.Cluster
import Annex.UUID
import qualified Remote as R
import qualified Types.Remote as R
import Annex.SpecialRemote.Config
import Utility.SafeOutput

import qualified Data.Map as M
import qualified Data.Set as S

cmd :: Command
cmd = noMessages $ command "updateproxy" SectionSetup 
	"update records with proxy configuration"
	paramNothing (withParams seek)

seek :: CmdParams -> CommandSeek
seek = withNothing (commandAction start)

start :: CommandStart
start = startingCustomOutput (ActionItemOther Nothing) $ do
	rs <- R.remoteList
	remoteproxies <- S.fromList . map mkproxy
		<$> filterM isproxy rs
	clusterproxies <- getClusterProxies remoteproxies
	let proxies = S.union remoteproxies clusterproxies
	u <- getUUID
	oldproxies <- fromMaybe mempty . M.lookup u <$> getProxies
	if oldproxies == proxies
		then liftIO $ putStrLn "No proxy changes to record."
		else do
			describechanges oldproxies proxies
			recordProxies proxies
	next $ return True
  where
	describechanges oldproxies proxies =
		forM_ (S.toList $ S.union oldproxies proxies) $ \p ->
			case (S.member p oldproxies, S.member p proxies) of
				(False, True) -> liftIO $
					putStrLn $ safeOutput $
						"Started proxying for " ++ proxyRemoteName p
				(True, False) -> liftIO $
					putStrLn $ safeOutput $
						"Stopped proxying for " ++ proxyRemoteName p
				_ -> noop
	
	mkproxy r = Proxy (R.uuid r) (R.name r)
	
	isproxy r
		| remoteAnnexProxy (R.gitconfig r) || not (null (remoteAnnexClusterNode (R.gitconfig r))) = 
			checkCanProxy r "Cannot proxy to this remote."
		| otherwise = pure False

checkCanProxy :: Remote -> String -> Annex Bool
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 a special remote configured with exporttree=yes,"
		, "but without annexobjects=yes."
		, cannotmessage
		, "Suggest you run: git-annex enableremote"
		, R.name r
		, "annexobjects=yes"
		]

-- Automatically proxy nodes of any cluster this repository is configured
-- to serve as a gateway for. Also proxy other cluster nodes that are
-- themselves proxied via other remotes.
getClusterProxies :: S.Set Proxy -> Annex (S.Set Proxy)
getClusterProxies remoteproxies = do
	myclusters <- (map mkclusterproxy . M.toList . annexClusters)
		<$> Annex.getGitConfig
	remoteproxiednodes <- findRemoteProxiedClusterNodes
	let myproxieduuids = S.map proxyRemoteUUID remoteproxies 
		<> S.fromList (map proxyRemoteUUID myclusters)
	-- filter out nodes we proxy for from the remote proxied nodes
	-- to avoid cycles
	let remoteproxiednodes' = filter
		(\n -> proxyRemoteUUID n `S.notMember` myproxieduuids)
		remoteproxiednodes
	return (S.fromList (myclusters ++ remoteproxiednodes'))
  where
	mkclusterproxy (remotename, cu) = 
		Proxy (fromClusterUUID cu) remotename

findRemoteProxiedClusterNodes :: Annex [Proxy]
findRemoteProxiedClusterNodes = do
	myclusters <- (S.fromList . M.elems . annexClusters)
		<$> Annex.getGitConfig
	clusternodes <- clusterNodeUUIDs <$> getClusters
	let isproxiedclusternode r
		| isJust (remoteAnnexProxiedBy (R.gitconfig r)) =
			case M.lookup (ClusterNodeUUID (R.uuid r)) clusternodes of
				Nothing -> False
				Just s -> not $ S.null $ 
					S.intersection s myclusters
		| otherwise = False
	(map asproxy . filter isproxiedclusternode)
		<$> R.remoteList
  where
	asproxy r = Proxy (R.uuid r) (R.name r)