summaryrefslogtreecommitdiff
path: root/Command/Map.hs
blob: e7789bdac7531c1682c42caacb23b9c9a1ae0396 (plain)
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
{- git-annex command
 -
 - Copyright 2010 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Map where

import qualified Data.Map as M

import Common.Annex
import Command
import qualified Git
import qualified Git.Url
import qualified Git.Config
import qualified Git.Construct
import qualified Remote
import qualified Annex
import Annex.UUID
import Logs.UUID
import Logs.Trust
import qualified Remote.Helper.Ssh as Ssh
import qualified Utility.Dot as Dot

-- a link from the first repository to the second (its remote)
data Link = Link Git.Repo Git.Repo

cmd :: Command
cmd = dontCheck repoExists $
	command "map" SectionQuery
		"generate map of repositories"
		paramNothing (withParams seek)

seek :: CmdParams -> CommandSeek
seek = withNothing start

start :: CommandStart
start = do
	rs <- combineSame <$> (spider =<< gitRepo)

	umap <- uuidMap
	trusted <- trustGet Trusted
		
	file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"

	liftIO $ writeFile file (drawMap rs umap trusted)
	next $ next $
		ifM (Annex.getState Annex.fast)
			( do
				showLongNote $ "left map in " ++ file
				return True
			, do
				showLongNote $ "running: dot -Tx11 " ++ file
				showOutput
				liftIO $ boolSystem "dot" [Param "-Tx11", File file]
			)

{- Generates a graph for dot(1). Each repository, and any other uuids, are
 - displayed as a node, and each of its remotes is represented as an edge
 - pointing at the node for the remote.
 -
 - The order nodes are added to the graph matters, since dot will draw
 - the first ones near to the top and left. So it looks better to put
 - the repositories first, followed by uuids that were not matched
 - to a repository.
 -}
drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String
drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
  where
	repos = map (node umap rs) rs
	ruuids = ts ++ map getUncachedUUID rs
	others = map (unreachable . uuidnode) $
		filter (`notElem` ruuids) (M.keys umap)
	trusted = map (trustworthy . uuidnode) ts
	uuidnode u = Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap

hostname :: Git.Repo -> String
hostname r
	| Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r)
	| otherwise = "localhost"

basehostname :: Git.Repo -> String
basehostname r = fromMaybe "" $ headMaybe $ split "." $ hostname r

{- A name to display for a repo. Uses the name from uuid.log if available,
 - or the remote name if not. -}
repoName :: M.Map UUID String -> Git.Repo -> String
repoName umap r
	| repouuid == NoUUID = fallback
	| otherwise = M.findWithDefault fallback repouuid umap
  where
	repouuid = getUncachedUUID r
	fallback = fromMaybe "unknown" $ Git.remoteName r

{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String
nodeId r =
	case getUncachedUUID r of
		NoUUID -> Git.repoLocation r
		UUID u -> u

{- A node representing a repo. -}
node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String
node umap fullinfo r = unlines $ n:edges
  where
	n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
		decorate $ Dot.graphNode (nodeId r) (repoName umap r)
	edges = map (edge umap fullinfo r) (Git.remotes r)
	decorate
		| Git.config r == M.empty = unreachable
		| otherwise = reachable

{- An edge between two repos. The second repo is a remote of the first. -}
edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String	
edge umap fullinfo from to =
	Dot.graphEdge (nodeId from) (nodeId fullto) edgename
  where
	-- get the full info for the remote, to get its UUID
	fullto = findfullinfo to
	findfullinfo n =
		case filter (same n) fullinfo of
			[] -> n
			(n':_) -> n'
	{- Only name an edge if the name is different than the name
	 - that will be used for the destination node, and is
	 - different from its hostname. (This reduces visual clutter.) -}
	edgename = maybe Nothing calcname $ Git.remoteName to
	calcname n
		| n `elem` [repoName umap fullto, hostname fullto] = Nothing
		| otherwise = Just n

unreachable :: String -> String
unreachable = Dot.fillColor "red"
reachable :: String -> String
reachable = Dot.fillColor "white"
trustworthy :: String -> String
trustworthy = Dot.fillColor "green"

{- Recursively searches out remotes starting with the specified repo. -}
spider :: Git.Repo -> Annex [Git.Repo]
spider r = spider' [r] []
spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo]
spider' [] known = return known
spider' (r:rs) known
	| any (same r) known = spider' rs known
	| otherwise = do
		r' <- scan r

		-- The remotes will be relative to r', and need to be
		-- made absolute for later use.
		remotes <- mapM (absRepo r') (Git.remotes r')
		let r'' = r' { Git.remotes = remotes }

		spider' (rs ++ remotes) (r'':known)

{- Converts repos to a common absolute form. -}
absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
absRepo reference r
	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
	| Git.repoIsUrl r = return r
	| otherwise = liftIO $ do
		r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)
		r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r'
		return (fromMaybe r' r'')

{- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool
same a b
	| both Git.repoIsUrl = matching Git.Url.scheme && matching Git.Url.authority && matching Git.repoPath
	| neither Git.repoIsUrl = matching Git.repoPath
	| otherwise = False
  where
	matching t = t a == t b
	both t = t a && t b
	neither t = not (t a) && not (t b)

{- reads the config of a remote, with progress display -}
scan :: Git.Repo -> Annex Git.Repo
scan r = do
	showStart "map" $ Git.repoDescribe r
	v <- tryScan r
	case v of
		Just r' -> do
			showEndOk
			return r'
		Nothing -> do
			showOutput
			showEndFail
			return r

{- tries to read the config of a remote, returning it only if it can
 - be accessed -}
tryScan :: Git.Repo -> Annex (Maybe Git.Repo)
tryScan r
	| Git.repoIsSsh r = sshscan
	| Git.repoIsUrl r = case Git.remoteName r of
		-- Can't scan a non-ssh url, so use any cached uuid for it.
		Just n -> Just <$> (either
			(const (pure r))
			(liftIO . setUUID r . Remote.uuid)
			=<< Remote.byName' n)
		Nothing -> return $ Just r
	| otherwise = liftIO $ safely $ Git.Config.read r
  where
	pipedconfig pcmd params = liftIO $ safely $
		withHandle StdoutHandle createProcessSuccess p $
			Git.Config.hRead r
	  where
		p = proc pcmd $ toCommand params

	configlist = Ssh.onRemote r (pipedconfig, return Nothing) "configlist" [] []
	manualconfiglist = do
		gc <- Annex.getRemoteGitConfig r
		sshparams <- Ssh.toRepo r gc [Param sshcmd]
		liftIO $ pipedconfig "ssh" sshparams
	  where
		sshcmd = "sh -c " ++ shellEscape
			(cddir ++ " && " ++ "git config --null --list")
		dir = Git.repoPath r
		cddir
			| "/~" `isPrefixOf` dir =
				let (userhome, reldir) = span (/= '/') (drop 1 dir)
				in "cd " ++ userhome ++ " && " ++ cdto (drop 1 reldir)
			| otherwise = cdto dir
		cdto p = "if ! cd " ++ shellEscape p ++ " 2>/dev/null; then cd " ++ shellEscape p ++ ".git; fi"

	-- First, try sshing and running git config manually,
	-- only fall back to git-annex-shell configlist if that
	-- fails.
	-- 
	-- This is done for two reasons, first I'd like this
	-- subcommand to be usable on non-git-annex repos.
	-- Secondly, configlist doesn't include information about
	-- the remote's remotes.
	sshscan = do
		sshnote
		v <- manualconfiglist
		case v of
			Nothing -> do
				sshnote
				configlist
			ok -> return ok

	sshnote = do
		showAction "sshing"
		showOutput

{- Spidering can find multiple paths to the same repo, so this is used
 - to combine (really remove) duplicate repos with the same UUID. -}
combineSame :: [Git.Repo] -> [Git.Repo]
combineSame = map snd . nubBy sameuuid . map pair
  where
	sameuuid (u1, _) (u2, _) = u1 == u2 && u1 /= NoUUID
	pair r = (getUncachedUUID r, r)

safely :: IO Git.Repo -> IO (Maybe Git.Repo)
safely a = do
	result <- tryNonAsync a
	case result of
		Left _ -> return Nothing
		Right r' -> return $ Just r'