map improvements

added uuid.log repos

group repos by host

avoid displaying most urls

display remote names on edges

still some bugs
This commit is contained in:
Joey Hess 2011-02-03 22:20:55 -04:00
parent 0c7d17ae06
commit 17829be0fd
4 changed files with 119 additions and 29 deletions

View file

@ -10,6 +10,8 @@ module Command.Map where
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
import Control.Exception.Extensible import Control.Exception.Extensible
import System.Cmd.Utils import System.Cmd.Utils
import qualified Data.Map as M
import Data.List.Utils
import Command import Command
import qualified Annex import qualified Annex
@ -18,6 +20,7 @@ import qualified Remotes
import Messages import Messages
import Types import Types
import Utility import Utility
import UUID
-- a link from the first repository to the second (its remote) -- a link from the first repository to the second (its remote)
data Link = Link Git.Repo Git.Repo data Link = Link Git.Repo Git.Repo
@ -33,32 +36,110 @@ start = do
g <- Annex.gitRepo g <- Annex.gitRepo
rs <- spider g rs <- spider g
liftIO $ writeFile file (dotGraph rs) umap <- uuidMap
showLongNote $ "running: dot -Tx11 " ++ file ++ "\n"
liftIO $ writeFile file (drawMap rs umap)
showLongNote $ "running: dot -Tx11 " ++ file
showProgress
r <- liftIO $ boolSystem "dot" ["-Tx11", file] r <- liftIO $ boolSystem "dot" ["-Tx11", file]
return $ Just $ return $ Just $ return r return $ Just $ return $ Just $ return r
where where
file = "map.dot" file = "map.dot"
{- Generates a graph for dot(1). Each repository is displayed {- Generates a graph for dot(1). Each repository, and any other uuids, are
- as a node, and each of its remotes is represented as an edge - displayed as a node, and each of its remotes is represented as an edge
- pointing at the node for the remote. -} - pointing at the node for the remote. -}
dotGraph :: [Git.Repo] -> String drawMap :: [Git.Repo] -> (M.Map UUID String) -> String
dotGraph rs = unlines $ [header] ++ map dotGraphRepo rs ++ [footer] 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 where
header = "digraph map {" header = "digraph map {"
footer= "}" footer= "}"
dotGraphRepo :: Git.Repo -> String dotQuote :: String -> String
dotGraphRepo r = unlines $ map dotline (node:edges) 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 where
node = nodename r ++ -- the "cluster_" makes dot draw a box
" [ label=" ++ dotquote (Git.repoDescribe r) ++ " ]" name = dotQuote ("cluster_ " ++ label)
edges = map edge (Git.remotes r) setlabel = dotLine $ "label=" ++ dotQuote label
edge e = nodename r ++ " -> " ++ nodename (makeabs r e)
nodename n = dotquote (Git.repoLocation n)
dotquote s = "\"" ++ s ++ "\""
dotline s = "\t" ++ s ++ ";"
{- Recursively searches out remotes starting with the specified repo. -} {- Recursively searches out remotes starting with the specified repo. -}
spider :: Git.Repo -> Annex [Git.Repo] spider :: Git.Repo -> Annex [Git.Repo]
@ -81,13 +162,13 @@ makeabs repo remote
where where
combinedurl = combinedurl =
Git.urlScheme repo ++ "//" ++ Git.urlScheme repo ++ "//" ++
Git.urlHost repo ++ Git.urlHostFull repo ++
Git.workTree remote Git.workTree remote
{- Checks if two repos are the same. -} {- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool same :: Git.Repo -> Git.Repo -> Bool
same a b 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 | both Git.repoIsUrl && neither Git.repoIsSsh = matching show
| otherwise = False | otherwise = False
@ -134,7 +215,7 @@ tryScan r
"cd " ++ shellEscape(Git.workTree r) ++ " && " ++ "cd " ++ shellEscape(Git.workTree r) ++ " && " ++
"git config --list" "git config --list"
liftIO $ pipedconfig "ssh" $ liftIO $ pipedconfig "ssh" $
words sshoptions ++ [Git.urlHost r, sshcmd] words sshoptions ++ [Git.urlHostFull r, sshcmd]
-- First, try sshing and running git config manually, -- First, try sshing and running git config manually,
-- only fall back to git-annex-shell configlist if that -- only fall back to git-annex-shell configlist if that

View file

@ -22,6 +22,7 @@ module GitRepo (
relative, relative,
urlPath, urlPath,
urlHost, urlHost,
urlHostFull,
urlScheme, urlScheme,
configGet, configGet,
configMap, configMap,
@ -125,10 +126,10 @@ remotesAdd :: Repo -> [Repo] -> Repo
remotesAdd repo rs = repo { remotes = rs } remotesAdd repo rs = repo { remotes = rs }
{- Returns the name of the remote that corresponds to the repo, if {- Returns the name of the remote that corresponds to the repo, if
- it is a remote. Otherwise, "" -} - it is a remote. -}
repoRemoteName :: Repo -> String repoRemoteName :: Repo -> Maybe String
repoRemoteName Repo { remoteName = Just name } = name repoRemoteName Repo { remoteName = Just name } = Just name
repoRemoteName _ = "" repoRemoteName _ = Nothing
{- Some code needs to vary between URL and normal repos, {- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -} - 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.) -} {- Hostname of an URL repo. (May include a username and/or port too.) -}
urlHost :: Repo -> String urlHost :: Repo -> String
urlHost Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a urlHost Repo { location = Url u } = uriRegName a
where where
a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u) a = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
urlHost repo = assertUrl repo $ error "internal" 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. -} {- Path of an URL repo. -}
urlPath :: Repo -> String urlPath :: Repo -> String
urlPath Repo { location = Url u } = uriPath u urlPath Repo { location = Url u } = uriPath u

View file

@ -205,7 +205,7 @@ repoNotIgnored r = do
name <- Annex.getState a name <- Annex.getState a
case name of case name of
Nothing -> return False 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. -} {- Checks if two repos are the same, by comparing their remote names. -}
same :: Git.Repo -> Git.Repo -> Bool same :: Git.Repo -> Git.Repo -> Bool
@ -217,7 +217,7 @@ byName "." = Annex.gitRepo -- special case to refer to current repository
byName name = do byName name = do
when (null name) $ error "no remote specified" when (null name) $ error "no remote specified"
g <- Annex.gitRepo g <- Annex.gitRepo
let match = filter (\r -> name == Git.repoRemoteName r) $ let match = filter (\r -> Just name == Git.repoRemoteName r) $
Git.remotes g Git.remotes g
when (null match) $ error $ when (null match) $ error $
"there is no git remote named \"" ++ name ++ "\"" "there is no git remote named \"" ++ name ++ "\""
@ -309,7 +309,7 @@ git_annex_shell r command params
| Git.repoIsSsh r = do | Git.repoIsSsh r = do
sshoptions <- repoConfig r "ssh-options" "" sshoptions <- repoConfig r "ssh-options" ""
return $ Just $ ["ssh"] ++ words sshoptions ++ return $ Just $ ["ssh"] ++ words sshoptions ++
[Git.urlHost r, sshcmd] [Git.urlHostFull r, sshcmd]
| otherwise = return Nothing | otherwise = return Nothing
where where
dir = Git.workTree r dir = Git.workTree r
@ -325,5 +325,5 @@ repoConfig r key def = do
let def' = Git.configGet g global def let def' = Git.configGet g global def
return $ Git.configGet g local def' return $ Git.configGet g local def'
where where
local = "remote." ++ Git.repoRemoteName r ++ ".annex-" ++ key local = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key
global = "annex." ++ key global = "annex." ++ key

View file

@ -26,6 +26,7 @@ import Control.Monad.State
import System.Cmd.Utils import System.Cmd.Utils
import System.IO import System.IO
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe
import qualified GitRepo as Git import qualified GitRepo as Git
import Types import Types
@ -72,7 +73,7 @@ getUUID r = do
where where
cached g = Git.configGet g cachekey "" cached g = Git.configGet g cachekey ""
updatecache g u = when (g /= r) $ Annex.setConfig cachekey u 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 :: Git.Repo -> UUID
getUncachedUUID r = Git.configGet r "annex.uuid" "" getUncachedUUID r = Git.configGet r "annex.uuid" ""