summaryrefslogtreecommitdiff
path: root/Command/Map.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-02-03 22:20:55 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-02-03 22:20:55 -0400
commit17829be0fd2ec090c2854f05856e91ca4359e71c (patch)
tree6b6ab5d32d6bb99f518dba0232fd4c906c9778ca /Command/Map.hs
parent0c7d17ae062c136e549cc9800dae85f3e3793237 (diff)
map improvements
added uuid.log repos group repos by host avoid displaying most urls display remote names on edges still some bugs
Diffstat (limited to 'Command/Map.hs')
-rw-r--r--Command/Map.hs117
1 files changed, 99 insertions, 18 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