blob: 1802ff28ebf27ff83ddfe9bdf388e5ded055350f (
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
|
{- git-annex remote repositories -}
module Remotes (
list,
withKey,
ensureGitConfigRead
) where
import Control.Monad.State (liftIO)
import qualified Data.Map as Map
import Data.String.Utils
import Types
import qualified GitRepo as Git
import qualified Annex
import LocationLog
import Locations
import UUID
import List
{- 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
remotes <- reposByUUID allremotes uuids
if (0 == length remotes)
then error $ "no configured git remotes have: " ++ (keyFile key) ++ "\n" ++
"It has been seen before in these repositories:\n" ++
prettyPrintUUIDs uuids
else 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 ensures that it is
- read for a specified remote, and updates state. It returns the
- updated git repo also. -}
ensureGitConfigRead :: Git.Repo -> Annex Git.Repo
ensureGitConfigRead r = do
if (Map.null $ Git.configMap r)
then do
r' <- liftIO $ Git.configRead r
g <- Annex.gitRepo
let l = Git.remotes g
let g' = Git.remotesAdd g $ exchange l r'
Annex.gitRepoChange g'
return r'
else return 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)
|
