map improvements

added uuid.log repos

group repos by host

avoid displaying most urls

display remote names on edges

still some bugs

4 files changed, 119 insertions, 29 deletions

diff --git a/Command/Map.hs b/Command/Map.hs
index 753d6ebdc..b89f8f89b 100644
--- a/Command/Map.hs
+++ b/Command/Map.hs
@@ -10,6 +10,8 @@ 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
@@ -18,6 +20,7 @@ import qualified Remotes
 import Messages
 import Types
 import Utility
+import UUID
 
 -- a link from the first repository to the second (its remote)
 data Link = Link Git.Repo Git.Repo
@@ -33,32 +36,110 @@ start = do
 	g <- Annex.gitRepo
 	rs <- spider g
 
-	liftIO $ writeFile file (dotGraph rs)
-	showLongNote $ "running: dot -Tx11 " ++ file ++ "\n"
+	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 is displayed
- - as a node, and each of its remotes is represented as an edge
+{- 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. -}
-dotGraph :: [Git.Repo] -> String
-dotGraph rs = unlines $ [header] ++ map dotGraphRepo rs ++ [footer]
+drawMap :: [Git.Repo] -> (M.Map UUID String) -> String
+drawMap rs umap = dotGraph $ repos ++ others
+	where
+		repos = map (dotGraphRepo umap rs) rs
+		others = map uuidnode (M.keys umap)
+		uuidnode u = dotGraphNode u $ M.findWithDefault "" u umap
+
+dotGraphRepo :: (M.Map UUID String) -> [Git.Repo] -> Git.Repo -> String
+dotGraphRepo umap fullinfo r = unlines $ node:edges
+	where
+		node = inhost $ dotGraphNode (nodeid r) (repoName umap r)
+		edges = map edge (Git.remotes r)
+
+		inhost a
+			| Git.repoIsUrl r = dotSubGraph hostname a
+			| otherwise = a
+
+		hostname = head $ split "." $ Git.urlHost r
+
+		edge to =
+			-- get the full info for the repo since its UUID
+			-- is in there
+			let to' = findfullinfo to
+			in dotGraphEdge
+				(nodeid r)
+				(nodeid $ makeabs r to')
+				(edgename to to')
+		
+		-- Only name an edge if the name is different than the name
+		-- that will be used for the destination node. (This
+		-- reduces visual clutter.)
+		edgename to to' =
+			case (Git.repoRemoteName to) of
+				Nothing -> Nothing
+				Just n ->
+					if (n == repoName umap to')
+						then Nothing
+						else Just n
+
+		nodeid n =
+			case (getUncachedUUID n) of
+				"" -> Git.repoLocation n
+				u -> u
+		findfullinfo n =
+			case (filter (same n) fullinfo) of
+				[] -> n
+				(n':_) -> n'
+
+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"
+
+dotGraphNode :: String -> String -> String
+dotGraphNode nodeid desc = dotLineLabeled desc $ dotQuote nodeid
+
+dotGraphEdge :: String -> String -> Maybe String -> String
+dotGraphEdge fromid toid d =
+	case d of
+		Nothing -> dotLine edge
+		Just desc -> dotLineLabeled desc edge
+	where
+		edge = dotQuote fromid ++ " -> " ++ dotQuote toid
+
+dotGraph :: [String] -> String
+dotGraph s = unlines $ [header] ++ s ++ [footer]
 	where
 		header = "digraph map {"
 		footer= "}"
 
-dotGraphRepo :: Git.Repo -> String
-dotGraphRepo r = unlines $ map dotline (node:edges)
+dotQuote :: String -> String
+dotQuote s = "\"" ++ s ++ "\""
+
+dotLine :: String -> String
+dotLine s = "\t" ++ s ++ ";"
+
+dotLineLabeled :: String -> String -> String
+dotLineLabeled label s = dotLine $ s ++ " [ label=" ++ dotQuote label ++ " ]"
+
+dotSubGraph :: String -> String -> String
+dotSubGraph label s = "subgraph " ++ name ++ "{ " ++ setlabel ++ s ++ " }"
 	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 ++ ";"
+		-- the "cluster_" makes dot draw a box
+		name = dotQuote ("cluster_ " ++ label)
+		setlabel = dotLine $ "label=" ++ dotQuote label
 
 {- Recursively searches out remotes starting with the specified repo. -}
 spider :: Git.Repo -> Annex [Git.Repo]
@@ -81,13 +162,13 @@ makeabs repo remote
 		where
 			combinedurl =
 				Git.urlScheme repo ++ "//" ++
-				Git.urlHost 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.urlHost && matching Git.workTree
+	| both Git.repoIsSsh = matching Git.urlHostFull && matching Git.workTree
 	| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
 	| otherwise = False
 		
@@ -134,7 +215,7 @@ tryScan r
 				"cd " ++ shellEscape(Git.workTree r) ++ " && " ++
 				"git config --list"
 			liftIO $ pipedconfig "ssh" $
-				words sshoptions ++ [Git.urlHost r, sshcmd]
+				words sshoptions ++ [Git.urlHostFull r, sshcmd]
 
 		-- First, try sshing and running git config manually,
 		-- only fall back to git-annex-shell configlist if that
diff --git a/GitRepo.hs b/GitRepo.hs
index b5a94d426..4b252868f 100644
--- a/GitRepo.hs
+++ b/GitRepo.hs
@@ -22,6 +22,7 @@ module GitRepo (
 	relative,
 	urlPath,
 	urlHost,
+	urlHostFull,
 	urlScheme,
 	configGet,
 	configMap,
@@ -124,11 +125,11 @@ repoLocation Repo { location = Dir dir } = dir
 remotesAdd :: Repo -> [Repo] -> Repo
 remotesAdd repo rs = repo { remotes = rs }
 
-{- Returns the name of the remote that corresponds to the repo, if 
- - it is a remote. Otherwise, "" -}
-repoRemoteName :: Repo -> String
-repoRemoteName Repo { remoteName = Just name } = name
-repoRemoteName _ = ""
+{- Returns the name of the remote that corresponds to the repo, if
+ - it is a remote. -}
+repoRemoteName :: Repo -> Maybe String
+repoRemoteName Repo { remoteName = Just name } = Just name
+repoRemoteName _ = Nothing
 
 {- Some code needs to vary between URL and normal repos,
  - or bare and non-bare, these functions help with that. -}
@@ -209,11 +210,18 @@ urlScheme repo = assertUrl repo $ error "internal"
 
 {- Hostname of an URL repo. (May include a username and/or port too.) -}
 urlHost :: Repo -> String
-urlHost Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
+urlHost Repo { location = Url u } = uriRegName a
 	where
 		a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
 urlHost repo = assertUrl repo $ error "internal"
 
+{- Full hostname of an URL repo. (May include a username and/or port too.) -}
+urlHostFull :: Repo -> String
+urlHostFull Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
+	where
+		a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
+urlHostFull repo = assertUrl repo $ error "internal"
+
 {- Path of an URL repo. -}
 urlPath :: Repo -> String
 urlPath Repo { location = Url u } = uriPath u
diff --git a/Remotes.hs b/Remotes.hs
index 89b403247..15f5185b9 100644
--- a/Remotes.hs
+++ b/Remotes.hs
@@ -205,7 +205,7 @@ repoNotIgnored r = do
 			name <- Annex.getState a
 			case name of
 				Nothing -> return False
-				Just n -> return $ n == Git.repoRemoteName r
+				n -> return $ n == Git.repoRemoteName r
 
 {- Checks if two repos are the same, by comparing their remote names. -}
 same :: Git.Repo -> Git.Repo -> Bool
@@ -217,7 +217,7 @@ byName "." = Annex.gitRepo -- special case to refer to current repository
 byName name = do
 	when (null name) $ error "no remote specified"
 	g <- Annex.gitRepo
-	let match = filter (\r -> name == Git.repoRemoteName r) $
+	let match = filter (\r -> Just name == Git.repoRemoteName r) $
 		Git.remotes g
 	when (null match) $ error $
 		"there is no git remote named \"" ++ name ++ "\""
@@ -309,7 +309,7 @@ git_annex_shell r command params
 	| Git.repoIsSsh r = do
 		sshoptions <- repoConfig r "ssh-options" ""
 		return $ Just $ ["ssh"] ++ words sshoptions ++ 
-			[Git.urlHost r, sshcmd]
+			[Git.urlHostFull r, sshcmd]
 	| otherwise = return Nothing
 	where
 		dir = Git.workTree r
@@ -325,5 +325,5 @@ repoConfig r key def = do
 	let def' = Git.configGet g global def
 	return $ Git.configGet g local def'
 	where
-		local = "remote." ++ Git.repoRemoteName r ++ ".annex-" ++ key
+		local = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key
 		global = "annex." ++ key
diff --git a/UUID.hs b/UUID.hs
index 6c719b41e..67cba3031 100644
--- a/UUID.hs
+++ b/UUID.hs
@@ -26,6 +26,7 @@ import Control.Monad.State
 import System.Cmd.Utils
 import System.IO
 import qualified Data.Map as M
+import Data.Maybe
 
 import qualified GitRepo as Git
 import Types
@@ -72,7 +73,7 @@ getUUID r = do
 	where
 		cached g = Git.configGet g cachekey ""
 		updatecache g u = when (g /= r) $ Annex.setConfig cachekey u
-		cachekey = "remote." ++ Git.repoRemoteName r ++ ".annex-uuid"
+		cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid"
 
 getUncachedUUID :: Git.Repo -> UUID
 getUncachedUUID r = Git.configGet r "annex.uuid" ""