git-annex/Command/Map.hs

{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Map where

import Control.Exception.Extensible
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 qualified Annex
import Annex.UUID
import Logs.UUID
import Logs.Trust
import Annex.Ssh
import qualified Utility.Dot as Dot

-- a link from the first repository to the second (its remote)
data Link = Link Git.Repo Git.Repo

def :: [Command]
def = [dontCheck repoExists $
	command "map" paramNothing seek "generate map of repositories"]

seek :: [CommandSeek]
seek = [withNothing start]

start :: CommandStart
start = do
	rs <- spider =<< gitRepo

	umap <- uuidMap
	trusted <- trustGet Trusted

	liftIO $ writeFile file (drawMap rs umap trusted)
	next $ next $ do
		fast <- Annex.getState Annex.fast
		if fast
			then return True
			else do
				showLongNote $ "running: dot -Tx11 " ++ file
				showOutput
				liftIO $ boolSystem "dot" [Param "-Tx11", File file]
	where
		file = "map.dot"

{- 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.
 -
 - The order nodes are added to the graph matters, since dot will draw
 - the first ones near to the top and left. So it looks better to put
 - the repositories first, followed by uuids that were not matched
 - to a repository.
 -}
drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String
drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
	where
		repos = map (node umap rs) rs
		ruuids = ts ++ map getUncachedUUID rs
		others = map (unreachable . uuidnode) $
			filter (`notElem` ruuids) (M.keys umap)
		trusted = map (trustworthy . uuidnode) ts
		uuidnode u = Dot.graphNode (fromUUID u) $
			M.findWithDefault "" u umap

hostname :: Git.Repo -> String
hostname r
	| Git.repoIsUrl r = Git.Url.host r
	| otherwise = "localhost"

basehostname :: Git.Repo -> String
basehostname r = Prelude.head $ split "." $ hostname r

{- A name to display for a repo. Uses the name from uuid.log if available,
 - or the remote name if not. -}
repoName :: M.Map UUID String -> Git.Repo -> String
repoName umap r
	| repouuid == NoUUID = fallback
	| otherwise = M.findWithDefault fallback repouuid umap
	where
		repouuid = getUncachedUUID 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
nodeId r =
	case getUncachedUUID r of
		NoUUID -> Git.repoLocation r
		UUID u -> u

{- A node representing a repo. -}
node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String
node umap fullinfo r = unlines $ n:edges
	where
		n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
			decorate $ Dot.graphNode (nodeId r) (repoName umap r)
		edges = map (edge umap fullinfo r) (Git.remotes r)
		decorate
			| Git.config r == M.empty = unreachable
			| otherwise = reachable

{- 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 fullto) edgename
	where
		-- get the full info for the remote, to get its UUID
		fullto = findfullinfo to
		findfullinfo n =
			case filter (same n) fullinfo of
				[] -> n
				(n':_) -> n'
		{- 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.remoteName to
		calcname n
			| n `elem` [repoName umap fullto, hostname fullto] = Nothing
			| otherwise = Just n

unreachable :: String -> String
unreachable = Dot.fillColor "red"
reachable :: String -> String
reachable = Dot.fillColor "white"
trustworthy :: String -> String
trustworthy = Dot.fillColor "green"

{- Recursively searches out remotes starting with the specified repo. -}
spider :: Git.Repo -> Annex [Git.Repo]
spider r = spider' [r] []
spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo]
spider' [] known = return known
spider' (r:rs) known
	| any (same r) known = spider' rs known
	| otherwise = do
		r' <- scan r

		-- 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'' = r' { Git.remotes = remotes }

		spider' (rs ++ remotes) (r'':known)

{- Converts repos to a common absolute form. -}
absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo
absRepo reference r
	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r
	| otherwise = liftIO $ Git.Construct.fromAbsPath =<< absPath (Git.workTree r)

{- Checks if two repos are the same. -}
same :: Git.Repo -> Git.Repo -> Bool
same a b
	| 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
		
	where
		matching t = t a == t b
		both t = t a && t b
		neither t = not (t a) && not (t b)

{- reads the config of a remote, with progress display -}
scan :: Git.Repo -> Annex Git.Repo
scan r = do
	showStart "map" $ Git.repoDescribe r
	v <- tryScan r
	case v of
		Just r' -> do
			showEndOk
			return r'
		Nothing -> do
			showOutput
			showEndFail
			return r

{- tries to read the config of a remote, returning it only if it can
 - be accessed -}
tryScan :: Git.Repo -> Annex (Maybe Git.Repo)
tryScan r
	| Git.repoIsSsh r = sshscan
	| Git.repoIsUrl r = return Nothing
	| otherwise = safely $ Git.Config.read r
	where
		safely a = do
			result <- liftIO (try a :: IO (Either SomeException Git.Repo))
			case result of
				Left _ -> return Nothing
				Right r' -> return $ Just r'
		pipedconfig cmd params = safely $
			pOpen ReadFromPipe cmd (toCommand params) $
				Git.Config.hRead r

		configlist =
			onRemote r (pipedconfig, Nothing) "configlist" []
		manualconfiglist = do
			sshparams <- sshToRepo r [Param sshcmd]
			liftIO $ pipedconfig "ssh" sshparams
			where
				sshcmd = cddir ++ " && " ++
					"git config --null --list"
				dir = Git.workTree r
				cddir
					| "/~" `isPrefixOf` dir =
						let (userhome, reldir) = span (/= '/') (drop 1 dir)
						in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir)
					| otherwise = "cd " ++ shellEscape dir

		-- First, try sshing and running git config manually,
		-- only fall back to git-annex-shell configlist if that
		-- fails.
		-- 
		-- This is done for two reasons, first I'd like this
		-- subcommand to be usable on non-git-annex repos.
		-- Secondly, configlist doesn't include information about
		-- the remote's remotes.
		sshscan = do
			sshnote
			v <- manualconfiglist
			case v of
				Nothing -> do
					sshnote
					configlist
				ok -> return ok

		sshnote = do
			showAction "sshing"
			showOutput