diff options
| -rw-r--r-- | Command/Map.hs | 30 | ||||
| -rw-r--r-- | GitRepo.hs | 16 |
2 files changed, 29 insertions, 17 deletions
diff --git a/Command/Map.hs b/Command/Map.hs index 83207d551..d8dd0e94c 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -107,7 +107,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 $ makeabs from fullto) edgename + Dot.graphEdge (nodeId from) (nodeId $ absRepo from fullto) edgename where -- get the full info for the remote, to get its UUID fullto = findfullinfo to @@ -140,20 +140,13 @@ spider' (r:rs) known | any (same r) known = spider' rs known | otherwise = do r' <- scan r - let remotes = map (makeabs r') (Git.remotes r') + let remotes = map (absRepo r') (Git.remotes r') spider' (rs ++ remotes) (r':known) -{- Makes a remote have an absolute url, rather than a host-local path. -} -makeabs :: Git.Repo -> Git.Repo -> Git.Repo -makeabs repo remote - | Git.repoIsUrl remote = remote - | not $ Git.repoIsUrl repo = remote - | otherwise = Git.repoFromUrl combinedurl - where - combinedurl = - Git.urlScheme repo ++ "//" ++ - Git.urlHostFull repo ++ - Git.workTree remote +absRepo :: Git.Repo -> Git.Repo -> Git.Repo +absRepo reference r + | Git.repoIsUrl reference = Git.localToUrl reference r + | otherwise = r {- Checks if two repos are the same. -} same :: Git.Repo -> Git.Repo -> Bool @@ -217,9 +210,14 @@ tryScan r -- Secondly, configlist doesn't include information about -- the remote's remotes. sshscan = do - showNote "sshing..." - showProgress + sshnote v <- manualconfiglist case v of - Nothing -> configlist + Nothing -> do + sshnote + configlist ok -> return ok + + sshnote = do + showNote "sshing..." + showProgress diff --git a/GitRepo.hs b/GitRepo.hs index 4b252868f..7bb20fc53 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -13,6 +13,7 @@ module GitRepo ( repoFromCwd, repoFromPath, repoFromUrl, + localToUrl, repoIsUrl, repoIsSsh, repoDescribe, @@ -109,6 +110,19 @@ repoFromUrl url Just v -> v Nothing -> error $ "bad url " ++ url +{- Converts a Local Repo into a remote repo, using the reference repo + - which is assumed to be on the same host. -} +localToUrl :: Repo -> Repo -> Repo +localToUrl reference r + | not $ repoIsUrl reference = error "internal error; reference repo not url" + | repoIsUrl r = r + | otherwise = r { location = Url $ fromJust $ parseURI absurl } + where + absurl = + urlScheme reference ++ "//" ++ + urlHostFull reference ++ + workTree r + {- User-visible description of a git repo. -} repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name @@ -338,7 +352,7 @@ configStore :: Repo -> String -> Repo configStore repo s = r { remotes = configRemotes r } where r = repo { config = configParse s } -{- Checks if a string fron git config is a true value. -} +{- Checks if a string from git config is a true value. -} configTrue :: String -> Bool configTrue s = map toLower s == "true" |