avoid reading configs for URL remotes every time
This commit is contained in:
parent
46ac66a438
commit
9ec5d90b6a
4 changed files with 50 additions and 22 deletions
|
@ -79,7 +79,7 @@ copyKeyFile key file = do
|
||||||
{- Tries to copy a file from a remote. -}
|
{- Tries to copy a file from a remote. -}
|
||||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> IO Bool
|
copyFromRemote :: Git.Repo -> Key -> FilePath -> IO Bool
|
||||||
copyFromRemote r key file = do
|
copyFromRemote r key file = do
|
||||||
if (Git.repoIsLocal r)
|
if (not $ Git.repoIsUrl r)
|
||||||
then getlocal
|
then getlocal
|
||||||
else if (Git.repoIsSsh r)
|
else if (Git.repoIsSsh r)
|
||||||
then getssh
|
then getssh
|
||||||
|
|
67
Remotes.hs
67
Remotes.hs
|
@ -8,6 +8,7 @@ module Remotes (
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
|
import Control.Monad (filterM)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
import Data.Either.Utils
|
import Data.Either.Utils
|
||||||
|
@ -20,6 +21,7 @@ import qualified Annex
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Locations
|
import Locations
|
||||||
import UUID
|
import UUID
|
||||||
|
import Core
|
||||||
|
|
||||||
{- Human visible list of remotes. -}
|
{- Human visible list of remotes. -}
|
||||||
list :: [Git.Repo] -> String
|
list :: [Git.Repo] -> String
|
||||||
|
@ -31,23 +33,36 @@ withKey key = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
uuids <- liftIO $ keyLocations g key
|
uuids <- liftIO $ keyLocations g key
|
||||||
allremotes <- remotesByCost
|
allremotes <- remotesByCost
|
||||||
-- This only uses cached data, so may not include new remotes
|
-- To determine if a remote has a key, its UUID needs to be known.
|
||||||
-- or remotes whose uuid has changed (eg by a different drive being
|
-- The locally cached UIIDs of remotes can fall out of date if
|
||||||
-- mounted at their location). So unless it happens to find all
|
-- eg, a different drive is mounted at the same location.
|
||||||
-- remotes, try harder, loading the remotes' configs.
|
-- But, reading the config of remotes can be expensive, so make
|
||||||
remotes <- reposByUUID allremotes uuids
|
-- sure we only do it once per git-annex run.
|
||||||
remotesread <- Annex.flagIsSet "remotesread"
|
remotesread <- Annex.flagIsSet "remotesread"
|
||||||
if ((length allremotes /= length remotes) && not remotesread)
|
if (remotesread)
|
||||||
then tryharder allremotes uuids
|
then reposByUUID allremotes uuids
|
||||||
else return remotes
|
else do
|
||||||
|
-- We assume that it's cheap to read the config
|
||||||
|
-- of non-URL remotes, so that is done each time.
|
||||||
|
-- But reading the config of an URL remote is
|
||||||
|
-- only done when there is no cached UUID value.
|
||||||
|
let cheap = filter (not . Git.repoIsUrl) allremotes
|
||||||
|
let expensive = filter Git.repoIsUrl allremotes
|
||||||
|
doexpensive <- filterM cachedUUID expensive
|
||||||
|
if (0 < length doexpensive)
|
||||||
|
then showNote $ "getting UUIDs for " ++ (list doexpensive) ++ "..."
|
||||||
|
else return ()
|
||||||
|
let todo = cheap ++ doexpensive
|
||||||
|
if (0 < length todo)
|
||||||
|
then do
|
||||||
|
e <- mapM tryGitConfigRead todo
|
||||||
|
Annex.flagChange "remotesread" $ FlagBool True
|
||||||
|
withKey key
|
||||||
|
else reposByUUID allremotes uuids
|
||||||
where
|
where
|
||||||
tryharder allremotes uuids = do
|
cachedUUID r = do
|
||||||
-- more expensive; read each remote's config
|
u <- getUUID r
|
||||||
eitherremotes <- mapM tryGitConfigRead allremotes
|
return $ 0 == length u
|
||||||
let allremotes' = map fromEither eitherremotes
|
|
||||||
remotes' <- reposByUUID allremotes' uuids
|
|
||||||
Annex.flagChange "remotesread" $ FlagBool True
|
|
||||||
return remotes'
|
|
||||||
|
|
||||||
{- Cost Ordered list of remotes. -}
|
{- Cost Ordered list of remotes. -}
|
||||||
remotesByCost :: Annex [Git.Repo]
|
remotesByCost :: Annex [Git.Repo]
|
||||||
|
@ -55,10 +70,11 @@ remotesByCost = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
reposByCost $ Git.remotes g
|
reposByCost $ Git.remotes g
|
||||||
|
|
||||||
{- Orders a list of git repos by cost. -}
|
{- Orders a list of git repos by cost, and throws out ignored ones. -}
|
||||||
reposByCost :: [Git.Repo] -> Annex [Git.Repo]
|
reposByCost :: [Git.Repo] -> Annex [Git.Repo]
|
||||||
reposByCost l = do
|
reposByCost l = do
|
||||||
costpairs <- mapM costpair l
|
notignored <- filterM repoNotIgnored l
|
||||||
|
costpairs <- mapM costpair notignored
|
||||||
return $ fst $ unzip $ sortBy bycost $ costpairs
|
return $ fst $ unzip $ sortBy bycost $ costpairs
|
||||||
where
|
where
|
||||||
costpair r = do
|
costpair r = do
|
||||||
|
@ -76,13 +92,22 @@ repoCost r = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
if ((length $ config g r) > 0)
|
if ((length $ config g r) > 0)
|
||||||
then return $ read $ config g r
|
then return $ read $ config g r
|
||||||
else if (Git.repoIsLocal r)
|
else if (Git.repoIsUrl r)
|
||||||
then return 100
|
then return 200
|
||||||
else return 200
|
else return 100
|
||||||
where
|
where
|
||||||
config g r = Git.configGet g (configkey r) ""
|
config g r = Git.configGet g (configkey r) ""
|
||||||
configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-cost"
|
configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-cost"
|
||||||
|
|
||||||
|
{- Checks if a repo should be ignored. -}
|
||||||
|
repoNotIgnored :: Git.Repo -> Annex Bool
|
||||||
|
repoNotIgnored r = do
|
||||||
|
g <- Annex.gitRepo
|
||||||
|
return ("true" /= config g r)
|
||||||
|
where
|
||||||
|
config g r = Git.configGet g (configkey r) ""
|
||||||
|
configkey r = "remote." ++ (Git.repoRemoteName r) ++ ".annex-ignore"
|
||||||
|
|
||||||
{- The git configs for the git repo's remotes is not read on startup
|
{- 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
|
- because reading it may be expensive. This function tries to read the
|
||||||
- config for a specified remote, and updates state. If successful, it
|
- config for a specified remote, and updates state. If successful, it
|
||||||
|
@ -95,7 +120,7 @@ tryGitConfigRead r = do
|
||||||
-- for other reasons; catch all possible exceptions
|
-- for other reasons; catch all possible exceptions
|
||||||
result <- liftIO $ (try (Git.configRead r)::IO (Either SomeException (Git.Repo)))
|
result <- liftIO $ (try (Git.configRead r)::IO (Either SomeException (Git.Repo)))
|
||||||
case (result) of
|
case (result) of
|
||||||
Left err -> return $ Left r
|
Left e -> return $ Left r
|
||||||
Right r' -> do
|
Right r' -> do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
let l = Git.remotes g
|
let l = Git.remotes g
|
||||||
|
|
1
debian/changelog
vendored
1
debian/changelog
vendored
|
@ -1,6 +1,7 @@
|
||||||
git-annex (0.02) UNRELEASED; urgency=low
|
git-annex (0.02) UNRELEASED; urgency=low
|
||||||
|
|
||||||
* New fromkey subcommand, for registering urls, etc.
|
* New fromkey subcommand, for registering urls, etc.
|
||||||
|
* Can scp annexed files from remotes.
|
||||||
|
|
||||||
-- Joey Hess <joeyh@debian.org> Thu, 21 Oct 2010 16:38:00 -0400
|
-- Joey Hess <joeyh@debian.org> Thu, 21 Oct 2010 16:38:00 -0400
|
||||||
|
|
||||||
|
|
|
@ -154,6 +154,8 @@ Like other git commands, git-annex is configured via `.git/config`.
|
||||||
repositories. Note that other factors may be configured when pushing
|
repositories. Note that other factors may be configured when pushing
|
||||||
files to repositories, in particular, whether the repository is on
|
files to repositories, in particular, whether the repository is on
|
||||||
a filesystem with sufficient free space.
|
a filesystem with sufficient free space.
|
||||||
|
* `remote.<name>.annex-ignore` -- If set to "true", prevents git-annex
|
||||||
|
from ever using this remote.
|
||||||
* `remote.<name>.annex-uuid` -- git-annex caches UUIDs of repositories
|
* `remote.<name>.annex-uuid` -- git-annex caches UUIDs of repositories
|
||||||
here.
|
here.
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue