blob: 07aafe51b7f2e6042a619df0cf6000bd1287c7d0 (
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
111
112
|
{- git-annex remote repositories -}
module Remotes (
list,
withKey,
tryGitConfigRead
) where
import Control.Exception
import Control.Monad.State (liftIO)
import qualified Data.Map as Map
import Data.String.Utils
import Data.Either.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 include new remotes
-- or remotes whose uuid has changed (eg by a different drive being
-- mounted at their location). So unless it happens to find all
-- remotes, try harder, loading the remotes' configs.
remotes <- reposByUUID allremotes uuids
remotesread <- Annex.flagIsSet "remotesread"
if ((length allremotes /= length remotes) && not remotesread)
then tryharder allremotes uuids
else return remotes
where
tryharder allremotes uuids = do
-- more expensive; read each remote's config
eitherremotes <- mapM tryGitConfigRead allremotes
let allremotes' = map fromEither eitherremotes
remotes' <- reposByUUID allremotes' uuids
Annex.flagChange "remotesread" $ FlagBool True
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 (Either Git.Repo Git.Repo)
tryGitConfigRead r = do
if (Map.null $ Git.configMap r)
then do
-- configRead can fail due to IO error or
-- for other reasons; catch all possible exceptions
result <- liftIO $ (try (Git.configRead r)::IO (Either SomeException (Git.Repo)))
case (result) of
Left err -> return $ Left r
Right r' -> do
g <- Annex.gitRepo
let l = Git.remotes g
let g' = Git.remotesAdd g $
exchange l r'
Annex.gitRepoChange g'
return $ Right r'
else return $ Right r -- config already read
where
exchange [] new = []
exchange (old:ls) new =
if ((Git.repoRemoteName old) == (Git.repoRemoteName new))
then new:(exchange ls new)
else old:(exchange ls new)
|
