diff options
| -rw-r--r-- | Command/Map.hs | 117 | ||||
| -rw-r--r-- | GitRepo.hs | 20 | ||||
| -rw-r--r-- | Remotes.hs | 8 | ||||
| -rw-r--r-- | UUID.hs | 3 |
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 @@ -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" "" |