summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Command/Map.hs117
-rw-r--r--GitRepo.hs20
-rw-r--r--Remotes.hs8
-rw-r--r--UUID.hs3
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" ""