summaryrefslogtreecommitdiff
path: root/Command/Map.hs
blob: 1d38bc42fe67d86de709a5b18a69a7222f158c67 (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
{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Map where

import Control.Monad.State (liftIO)
import Control.Exception.Extensible
import System.Cmd.Utils
import qualified Data.Map as M
import Data.List.Utils

import Command
import qualified Annex
import qualified GitRepo as Git
import qualified Remotes
import Messages
import Types
import Utility
import UUID
import qualified Dot

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

command :: [Command]
command = [Command "map" paramNothing seek "generate map of repositories"]

seek :: [CommandSeek]
seek = [withNothing start]

start :: CommandStartNothing
start = do
	g <- Annex.gitRepo
	rs <- spider g

	umap <- uuidMap

	liftIO $ writeFile file (drawMap rs umap)
	showLongNote $ "running: dot -Tx11 " ++ file
	showProgress
	r <- liftIO $ boolSystem "dot" ["-Tx11", file]
	return $ Just $ return $ Just $ return r
	where
		file = "map.dot"

{- 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. -}
drawMap :: [Git.Repo] -> (M.Map UUID String) -> String
drawMap rs umap = Dot.graph $ repos ++ others
	where
		repos = map (node umap rs) rs
		others = map uuidnode (M.keys umap)
		uuidnode u = Dot.graphNode u $ M.findWithDefault "" u umap

hostname :: Git.Repo -> String
hostname r
	| Git.repoIsUrl r = Git.urlHost r
	| otherwise = "localhost"

basehostname :: Git.Repo -> String
basehostname r = head $ 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
	| null repouuid = fallback
	| otherwise = M.findWithDefault fallback repouuid umap
	where
		repouuid = getUncachedUUID r
		fallback =
			case (Git.repoRemoteName r) of
				Just n -> n
				Nothing -> "unknown"

{- A unique id for the node. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String
nodeId r =
	case (getUncachedUUID r) of
		"" -> Git.repoLocation r
		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) $
			Dot.graphNode (nodeId r) (repoName umap r)
		edges = map (edge umap fullinfo r) (Git.remotes r)

{- 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 $ makeabs from 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 =
			case (Git.repoRemoteName to) of
				Nothing -> Nothing
				Just n ->
					if (n == repoName umap fullto || n == hostname fullto)
						then Nothing
						else Just n

{- 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
		let remotes = map (makeabs r') (Git.remotes r')
		spider' (rs ++ remotes) (r':known)

{- Makes a remote have an absolute url, rather than a host-local path. -}
makeabs :: Git.Repo -> Git.Repo -> Git.Repo
makeabs repo remote
	| Git.repoIsUrl remote = remote
	| not $ Git.repoIsUrl repo = remote
	| otherwise = Git.repoFromUrl combinedurl
		where
			combinedurl =
				Git.urlScheme repo ++ "//" ++
				Git.urlHostFull repo ++
				Git.workTree remote

{- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool
same a b
	| both Git.repoIsSsh = matching Git.urlHostFull && matching Git.workTree
	| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
	| 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
			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 = return Nothing
	| otherwise = safely $ Git.configRead r
	where
		safely a = do
			result <- liftIO (try (a)::IO (Either SomeException Git.Repo))
			case result of
				Left _ -> return Nothing
				Right r' -> return $ Just r'
		pipedconfig cmd params = safely $
			pOpen ReadFromPipe cmd params $
				Git.hConfigRead r

		configlist =
			Remotes.onRemote r (pipedconfig, Nothing) "configlist" []
		manualconfiglist = do
			sshoptions <- Remotes.repoConfig r "ssh-options" ""
			let sshcmd =
				"cd " ++ shellEscape(Git.workTree r) ++ " && " ++
				"git config --list"
			liftIO $ pipedconfig "ssh" $
				words sshoptions ++ [Git.urlHostFull r, sshcmd]

		-- 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
			showNote "sshing..."
			showProgress
			v <- manualconfiglist
			case v of
				Nothing -> configlist
				ok -> return ok