blob: 753d6ebdcb7d4585119d18f0525233695a3c1073 (
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
|
{- 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 Command
import qualified Annex
import qualified GitRepo as Git
import qualified Remotes
import Messages
import Types
import Utility
-- 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
liftIO $ writeFile file (dotGraph rs)
showLongNote $ "running: dot -Tx11 " ++ file ++ "\n"
r <- liftIO $ boolSystem "dot" ["-Tx11", file]
return $ Just $ return $ Just $ return r
where
file = "map.dot"
{- Generates a graph for dot(1). Each repository is displayed
- as a node, and each of its remotes is represented as an edge
- pointing at the node for the remote. -}
dotGraph :: [Git.Repo] -> String
dotGraph rs = unlines $ [header] ++ map dotGraphRepo rs ++ [footer]
where
header = "digraph map {"
footer= "}"
dotGraphRepo :: Git.Repo -> String
dotGraphRepo r = unlines $ map dotline (node:edges)
where
node = nodename r ++
" [ label=" ++ dotquote (Git.repoDescribe r) ++ " ]"
edges = map edge (Git.remotes r)
edge e = nodename r ++ " -> " ++ nodename (makeabs r e)
nodename n = dotquote (Git.repoLocation n)
dotquote s = "\"" ++ s ++ "\""
dotline s = "\t" ++ s ++ ";"
{- 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.urlHost 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.urlHost && 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.urlHost 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
|
