split more stuff out of Git.hs

This commit is contained in:
Joey Hess 2011-12-14 15:30:14 -04:00
parent 2b24e16a63
commit 02f1bd2bf4
20 changed files with 197 additions and 179 deletions

View file

@ -13,6 +13,7 @@ import qualified Data.Map as M
import Common.Annex
import Command
import qualified Git
import qualified Git.Url
import qualified Git.Config
import qualified Git.Construct
import Annex.UUID
@ -68,7 +69,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
hostname :: Git.Repo -> String
hostname r
| Git.repoIsUrl r = Git.urlHost r
| Git.repoIsUrl r = Git.Url.host r
| otherwise = "localhost"
basehostname :: Git.Repo -> String
@ -82,7 +83,7 @@ repoName umap r
| otherwise = M.findWithDefault fallback repouuid umap
where
repouuid = getUncachedUUID r
fallback = fromMaybe "unknown" $ Git.repoRemoteName r
fallback = fromMaybe "unknown" $ Git.remoteName r
{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String
@ -99,7 +100,7 @@ node umap fullinfo r = unlines $ n:edges
decorate $ Dot.graphNode (nodeId r) (repoName umap r)
edges = map (edge umap fullinfo r) (Git.remotes r)
decorate
| Git.configMap r == M.empty = unreachable
| Git.config r == M.empty = unreachable
| otherwise = reachable
{- An edge between two repos. The second repo is a remote of the first. -}
@ -116,7 +117,7 @@ edge umap fullinfo from to =
{- Only name an edge if the name is different than the name
- that will be used for the destination node, and is
- different from its hostname. (This reduces visual clutter.) -}
edgename = maybe Nothing calcname $ Git.repoRemoteName to
edgename = maybe Nothing calcname $ Git.remoteName to
calcname n
| n `elem` [repoName umap fullto, hostname fullto] = Nothing
| otherwise = Just n
@ -141,7 +142,7 @@ spider' (r:rs) known
-- The remotes will be relative to r', and need to be
-- made absolute for later use.
remotes <- mapM (absRepo r') (Git.remotes r')
let r'' = Git.remotesAdd r' remotes
let r'' = r' { Git.remotes = remotes }
spider' (rs ++ remotes) (r'':known)
@ -154,7 +155,7 @@ absRepo reference r
{- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool
same a b
| both Git.repoIsSsh = matching Git.urlAuthority && matching Git.workTree
| both Git.repoIsSsh = matching Git.Url.authority && matching Git.workTree
| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
| neither Git.repoIsSsh = matching Git.workTree
| otherwise = False