blob: 4f4e5a26cbe4a04e1cd5cdd24b9d61bc81f2fb76 (
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
104
105
106
107
108
109
110
|
{- 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
if (0 == length remotes')
then err uuids
else return remotes'
err uuids =
error $ "no available git remotes have: " ++
(keyFile key) ++ "\n" ++
"It has been seen before in these repositories:\n" ++
prettyPrintUUIDs uuids
{- 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)
|
