cost ordering
This commit is contained in:
parent
794d44cf1d
commit
771a6b36e1
2 changed files with 41 additions and 5 deletions
25
Annex.hs
25
Annex.hs
|
@ -9,12 +9,14 @@ module Annex (
|
||||||
annexWantFile,
|
annexWantFile,
|
||||||
annexDropFile,
|
annexDropFile,
|
||||||
annexPushRepo,
|
annexPushRepo,
|
||||||
|
repoCost,
|
||||||
annexPullRepo
|
annexPullRepo
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
|
import List
|
||||||
import GitRepo
|
import GitRepo
|
||||||
import Utility
|
import Utility
|
||||||
import Locations
|
import Locations
|
||||||
|
@ -165,3 +167,26 @@ logStatus state key status = do
|
||||||
{- Checks if a given key is currently present in the annexLocation -}
|
{- Checks if a given key is currently present in the annexLocation -}
|
||||||
inAnnex :: State -> Backend -> Key -> IO Bool
|
inAnnex :: State -> Backend -> Key -> IO Bool
|
||||||
inAnnex state backend key = doesFileExist $ annexLocation state backend key
|
inAnnex state backend key = doesFileExist $ annexLocation state backend key
|
||||||
|
|
||||||
|
{- Orders a list of git repos by cost. -}
|
||||||
|
reposByCost :: State -> [GitRepo] -> [GitRepo]
|
||||||
|
reposByCost state l =
|
||||||
|
fst $ unzip $ sortBy (\(r1, c1) (r2, c2) -> compare c1 c2) $ costpairs l
|
||||||
|
where
|
||||||
|
costpairs l = map (\r -> (r, repoCost state r)) l
|
||||||
|
|
||||||
|
{- 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 :: State -> GitRepo -> Int
|
||||||
|
repoCost state r =
|
||||||
|
if ((length $ config state r) > 0)
|
||||||
|
then read $ config state r
|
||||||
|
else if (gitRepoIsLocal r)
|
||||||
|
then 100
|
||||||
|
else 200
|
||||||
|
where
|
||||||
|
config state r = gitConfig (repo state) (configkey r) ""
|
||||||
|
configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost"
|
||||||
|
|
21
GitRepo.hs
21
GitRepo.hs
|
@ -10,13 +10,17 @@ module GitRepo (
|
||||||
gitRepoFromCwd,
|
gitRepoFromCwd,
|
||||||
gitRepoFromPath,
|
gitRepoFromPath,
|
||||||
gitRepoFromUrl,
|
gitRepoFromUrl,
|
||||||
|
gitRepoIsLocal,
|
||||||
|
gitRepoIsRemote,
|
||||||
|
gitConfigRemotes,
|
||||||
gitWorkTree,
|
gitWorkTree,
|
||||||
gitDir,
|
gitDir,
|
||||||
gitRelative,
|
gitRelative,
|
||||||
gitConfig,
|
gitConfig,
|
||||||
gitConfigRead,
|
gitConfigRead,
|
||||||
gitRun,
|
gitRun,
|
||||||
gitAttributes
|
gitAttributes,
|
||||||
|
gitRepoRemoteName
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Directory
|
import Directory
|
||||||
|
@ -74,16 +78,23 @@ gitRepoFromUrl url query = do
|
||||||
where path url = uriPath $ fromJust $ parseURI url
|
where path url = uriPath $ fromJust $ parseURI url
|
||||||
|
|
||||||
{- User-visible description of a git repo by path or url -}
|
{- User-visible description of a git repo by path or url -}
|
||||||
describe repo = if (local repo) then top repo else url repo
|
describe repo = if (gitRepoIsLocal repo) then top repo else url repo
|
||||||
|
|
||||||
|
{- Returns the name of the remote that corresponds to the repo, if
|
||||||
|
- it is a remote. Otherwise, "" -}
|
||||||
|
gitRepoRemoteName r =
|
||||||
|
if (isJust $ remoteName r)
|
||||||
|
then fromJust $ remoteName r
|
||||||
|
else ""
|
||||||
|
|
||||||
{- Some code needs to vary between remote and local repos, or bare and
|
{- Some code needs to vary between remote and local repos, or bare and
|
||||||
- non-bare, these functions help with that. -}
|
- non-bare, these functions help with that. -}
|
||||||
local repo = case (repo) of
|
gitRepoIsLocal repo = case (repo) of
|
||||||
LocalGitRepo {} -> True
|
LocalGitRepo {} -> True
|
||||||
RemoteGitRepo {} -> False
|
RemoteGitRepo {} -> False
|
||||||
remote repo = not $ local repo
|
gitRepoIsRemote repo = not $ gitRepoIsLocal repo
|
||||||
assertlocal repo action =
|
assertlocal repo action =
|
||||||
if (local repo)
|
if (gitRepoIsLocal repo)
|
||||||
then action
|
then action
|
||||||
else error $ "acting on remote git repo " ++ (describe repo) ++
|
else error $ "acting on remote git repo " ++ (describe repo) ++
|
||||||
" not supported"
|
" not supported"
|
||||||
|
|
Loading…
Reference in a new issue