summaryrefslogtreecommitdiff
path: root/Remotes.hs
blob: 2fffcffa7e238c8890ac75eeb468297a3e97eafb (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
{- git-annex remote repositories -}

module Remotes (
	list,
	withKey,
	tryGitConfigRead
) where

import Control.Monad.State (liftIO)
import IO
import qualified Data.Map as Map
import Data.String.Utils
import List
import Maybe
import Types
import qualified GitRepo as Git
import qualified Annex
import LocationLog
import Locations
import UUID

{- Human visible list of remotes. -}
list :: [Git.Repo] -> String
list remotes = join " " $ map Git.repoDescribe remotes 

{- Cost ordered list of remotes that the LocationLog indicate may have a key. -}
withKey :: Key -> Annex [Git.Repo]
withKey key = do
	g <- Annex.gitRepo
	uuids <- liftIO $ keyLocations g key
	allremotes <- remotesByCost
	-- this only uses cached data, so may not find new remotes
	remotes <- reposByUUID allremotes uuids
	if (0 == length remotes)
		then tryharder allremotes uuids
		else return remotes
	where
		tryharder allremotes uuids = do
			-- more expensive; check each remote's config
			mayberemotes <- mapM tryGitConfigRead allremotes
			let allremotes' = catMaybes mayberemotes
			remotes' <- reposByUUID allremotes' uuids
			return remotes'

{- Cost Ordered list of remotes. -}
remotesByCost :: Annex [Git.Repo]
remotesByCost = do
	g <- Annex.gitRepo
	reposByCost $ Git.remotes g

{- Orders a list of git repos by cost. -}
reposByCost :: [Git.Repo] -> Annex [Git.Repo]
reposByCost l = do
	costpairs <- mapM costpair l
	return $ fst $ unzip $ sortBy bycost $ costpairs
	where
		costpair r = do
			cost <- repoCost r
			return (r, cost)
		bycost (_, c1) (_, c2) = compare c1 c2

{- Calculates cost for a repo.
 -
 - The default cost is 100 for local repositories, and 200 for remote
 - repositories; it can also be configured by remote.<name>.annex-cost
 -}
repoCost :: Git.Repo -> Annex Int
repoCost r = do
	g <- Annex.gitRepo
	if ((length $ config g r) > 0)
		then return $ read $ config g r
		else if (Git.repoIsLocal r)
			then return 100
			else return 200
	where
		config g r = Git.configGet g (configkey r) ""
		configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-cost"

{- The git configs for the git repo's remotes is not read on startup
 - because reading it may be expensive. This function tries to read the
 - config for a specified remote, and updates state. If successful, it
 - returns the updated git repo. -}
tryGitConfigRead :: Git.Repo -> Annex (Maybe Git.Repo)
tryGitConfigRead r = do
	if (Map.null $ Git.configMap r)
		then do
			result <- liftIO $ try (Git.configRead r)
			case (result) of
				Left err -> return Nothing
				Right r' -> do
					g <- Annex.gitRepo
					let l = Git.remotes g
					let g' = Git.remotesAdd g $
						exchange l r'
					Annex.gitRepoChange g'
					return $ Just r'
		else return $ Just r
	where 
		exchange [] new = []
		exchange (old:ls) new =
			if ((Git.repoRemoteName old) == (Git.repoRemoteName new))
				then new:(exchange ls new)
				else old:(exchange ls new)