new map subcommand, basically working

Still todo:

- add repos from uuid.log that were not directly found
- group repos into their respective hosts
- display inaccessible repos and broken remote connections in red
- anonymize the url display somewhat, so the maps can be shared
- use uuid info to tell when two apparently different repos are actually
  the same repo accessed in different ways

1 files changed, 153 insertions, 0 deletions

diff --git a/Command/Map.hs b/Command/Map.hs
new file mode 100644
index 000000000..753d6ebdc
--- /dev/null
+++ b/Command/Map.hs
@@ -0,0 +1,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