diff options
| -rw-r--r-- | Command/Map.hs | 30 | ||||
| -rw-r--r-- | Dot.hs | 13 |
2 files changed, 30 insertions, 13 deletions
diff --git a/Command/Map.hs b/Command/Map.hs index d8dd0e94c..0a3bb9fff 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -21,6 +21,7 @@ import Messages import Types import Utility import UUID +import Trust import qualified Dot -- a link from the first repository to the second (its remote) @@ -38,8 +39,9 @@ start = do rs <- spider g umap <- uuidMap + trusted <- trustGet Trusted - liftIO $ writeFile file (drawMap rs umap) + liftIO $ writeFile file (drawMap rs umap trusted) showLongNote $ "running: dot -Tx11 " ++ file showProgress r <- liftIO $ boolSystem "dot" ["-Tx11", file] @@ -56,14 +58,15 @@ start = do - the repositories first, followed by uuids that were not matched - to a repository. -} -drawMap :: [Git.Repo] -> (M.Map UUID String) -> String -drawMap rs umap = Dot.graph $ repos ++ others +drawMap :: [Git.Repo] -> (M.Map UUID String) -> [UUID] -> String +drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others where repos = map (node umap rs) rs - ruuids = map getUncachedUUID rs - others = map uuidnode $ filter (`notElem` ruuids) (M.keys umap) - uuidnode u = unreachable $ - Dot.graphNode u $ M.findWithDefault "" u umap + ruuids = ts ++ map getUncachedUUID rs + others = map (unreachable . uuidnode) $ + filter (`notElem` ruuids) (M.keys umap) + trusted = map (trustworthy . uuidnode) ts + uuidnode u = Dot.graphNode u $ M.findWithDefault "" u umap hostname :: Git.Repo -> String hostname r @@ -97,7 +100,7 @@ nodeId r = 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) $ + n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $ decorate $ Dot.graphNode (nodeId r) (repoName umap r) edges = map (edge umap fullinfo r) (Git.remotes r) decorate @@ -107,7 +110,7 @@ node umap fullinfo r = unlines $ n:edges {- 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 $ absRepo from fullto) edgename + Dot.graphEdge (nodeId from) (nodeId fullto) edgename where -- get the full info for the remote, to get its UUID fullto = findfullinfo to @@ -130,6 +133,8 @@ unreachable :: String -> String unreachable = Dot.fillColor "red" reachable :: String -> String reachable = Dot.fillColor "white" +trustworthy :: String -> String +trustworthy = Dot.fillColor "green" {- Recursively searches out remotes starting with the specified repo. -} spider :: Git.Repo -> Annex [Git.Repo] @@ -140,8 +145,13 @@ spider' (r:rs) known | any (same r) known = spider' rs known | otherwise = do r' <- scan r + + -- The remotes will be relative to r', and need to be + -- made absolute for later use. let remotes = map (absRepo r') (Git.remotes r') - spider' (rs ++ remotes) (r':known) + let r'' = Git.remotesAdd r' remotes + + spider' (rs ++ remotes) (r'':known) absRepo :: Git.Repo -> Git.Repo -> Git.Repo absRepo reference r @@ -41,13 +41,20 @@ fillColor :: String -> String -> String fillColor color s = attr "fillcolor" color $ attr "style" "filled" $ s {- apply to graphNode to put the node in a labeled box -} -subGraph :: String -> String -> String -> String -subGraph subid l s = - "subgraph " ++ name ++ " {\n" ++ ii setlabel ++ ii s ++ indent "}" +subGraph :: String -> String -> String -> String -> String +subGraph subid l color s = + "subgraph " ++ name ++ " {\n" ++ + ii setlabel ++ + ii setfilled ++ + ii setcolor ++ + ii s ++ + indent "}" where -- the "cluster_" makes dot draw a box name = quote ("cluster_" ++ subid) setlabel = "label=" ++ quote l + setfilled = "style=" ++ quote "filled" + setcolor = "fillcolor=" ++ quote color ii x = (indent $ indent x) ++ "\n" indent ::String -> String |