converted move to use Remote
Drop old Remotes.hs, now unused!
This commit is contained in:
Joey Hess
parent
48418cb92b
commit
a70035e981
3 changed files with 36 additions and 367 deletions
|
|
@ -15,8 +15,7 @@ import qualified Annex
|
|||
import LocationLog
|
||||
import Types
|
||||
import Content
|
||||
import qualified GitRepo as Git
|
||||
import qualified Remotes
|
||||
import qualified Remote
|
||||
import UUID
|
||||
import Messages
|
||||
import Utility
|
||||
|
|
@ -34,16 +33,15 @@ seek = [withFilesInGit $ start True]
|
|||
- moving data in the key-value backend. -}
|
||||
start :: Bool -> CommandStartString
|
||||
start move file = do
|
||||
Remotes.readConfigs
|
||||
to <- Annex.getState Annex.toremote
|
||||
from <- Annex.getState Annex.fromremote
|
||||
case (from, to) of
|
||||
(Nothing, Nothing) -> error "specify either --from or --to"
|
||||
(Nothing, Just name) -> do
|
||||
dest <- Remotes.byName name
|
||||
dest <- Remote.byName name
|
||||
toStart dest move file
|
||||
(Just name, Nothing) -> do
|
||||
src <- Remotes.byName name
|
||||
src <- Remote.byName name
|
||||
fromStart src move file
|
||||
(_ , _) -> error "only one of --from or --to can be specified"
|
||||
|
||||
|
|
@ -56,88 +54,86 @@ showAction False file = showStart "copy" file
|
|||
- key to the remote, or removing the key from it *may* log the change
|
||||
- on the remote, but this cannot be relied on. For example, it's not done
|
||||
- for bare repos. -}
|
||||
remoteHasKey :: Git.Repo -> Key -> Bool -> Annex ()
|
||||
remoteHasKey :: Remote.Remote Annex -> Key -> Bool -> Annex ()
|
||||
remoteHasKey remote key present = do
|
||||
g <- Annex.gitRepo
|
||||
remoteuuid <- getUUID remote
|
||||
let remoteuuid = Remote.uuid remote
|
||||
logfile <- liftIO $ logChange g key remoteuuid status
|
||||
Annex.queue "add" [Param "--"] logfile
|
||||
where
|
||||
status = if present then ValuePresent else ValueMissing
|
||||
|
||||
{- Moves (or copies) the content of an annexed file to another repository,
|
||||
- and updates locationlog information on both.
|
||||
{- Moves (or copies) the content of an annexed file to a remote.
|
||||
-
|
||||
- When moving, if the destination already has the content, it is
|
||||
- still removed from the current repository.
|
||||
- If the remote already has the content, it is still removed from
|
||||
- the current repository.
|
||||
-
|
||||
- Note that unlike drop, this does not honor annex.numcopies.
|
||||
- A file's content can be moved even if there are insufficient copies to
|
||||
- allow it to be dropped.
|
||||
-}
|
||||
toStart :: Git.Repo -> Bool -> CommandStartString
|
||||
toStart :: Remote.Remote Annex -> Bool -> CommandStartString
|
||||
toStart dest move file = isAnnexed file $ \(key, _) -> do
|
||||
g <- Annex.gitRepo
|
||||
u <- getUUID g
|
||||
ishere <- inAnnex key
|
||||
if not ishere || g == dest
|
||||
if not ishere || u == Remote.uuid dest
|
||||
then return Nothing -- not here, so nothing to do
|
||||
else do
|
||||
showAction move file
|
||||
return $ Just $ toPerform dest move key
|
||||
toPerform :: Git.Repo -> Bool -> Key -> CommandPerform
|
||||
toPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform
|
||||
toPerform dest move key = do
|
||||
-- checking the remote is expensive, so not done in the start step
|
||||
isthere <- Remotes.inAnnex dest key
|
||||
isthere <- Remote.hasKey dest key
|
||||
case isthere of
|
||||
Left err -> do
|
||||
showNote $ show err
|
||||
return Nothing
|
||||
Right False -> do
|
||||
showNote $ "to " ++ Git.repoDescribe dest ++ "..."
|
||||
ok <- Remotes.copyToRemote dest key
|
||||
showNote $ "to " ++ Remote.name dest ++ "..."
|
||||
ok <- Remote.storeKey dest key
|
||||
if ok
|
||||
then return $ Just $ toCleanup dest move key
|
||||
else return Nothing -- failed
|
||||
Right True -> return $ Just $ toCleanup dest move key
|
||||
toCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup
|
||||
toCleanup :: Remote.Remote Annex -> Bool -> Key -> CommandCleanup
|
||||
toCleanup dest move key = do
|
||||
remoteHasKey dest key True
|
||||
if move
|
||||
then Command.Drop.cleanup key
|
||||
else return True
|
||||
|
||||
{- Moves (or copies) the content of an annexed file from another repository
|
||||
- to the current repository and updates locationlog information on both.
|
||||
{- Moves (or copies) the content of an annexed file from a remote
|
||||
- to the current repository.
|
||||
-
|
||||
- If the current repository already has the content, it is still removed
|
||||
- from the other repository when moving.
|
||||
- from the remote.
|
||||
-}
|
||||
fromStart :: Git.Repo -> Bool -> CommandStartString
|
||||
fromStart :: Remote.Remote Annex -> Bool -> CommandStartString
|
||||
fromStart src move file = isAnnexed file $ \(key, _) -> do
|
||||
g <- Annex.gitRepo
|
||||
(remotes, _) <- Remotes.keyPossibilities key
|
||||
if (g == src) || (null $ filter (\r -> Remotes.same r src) remotes)
|
||||
u <- getUUID g
|
||||
(remotes, _) <- Remote.keyPossibilities key
|
||||
if (u == Remote.uuid src) || (null $ filter (== src) remotes)
|
||||
then return Nothing
|
||||
else do
|
||||
showAction move file
|
||||
return $ Just $ fromPerform src move key
|
||||
fromPerform :: Git.Repo -> Bool -> Key -> CommandPerform
|
||||
fromPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform
|
||||
fromPerform src move key = do
|
||||
ishere <- inAnnex key
|
||||
if ishere
|
||||
then return $ Just $ fromCleanup src move key
|
||||
else do
|
||||
showNote $ "from " ++ Git.repoDescribe src ++ "..."
|
||||
ok <- getViaTmp key $ Remotes.copyFromRemote src key
|
||||
showNote $ "from " ++ Remote.name src ++ "..."
|
||||
ok <- getViaTmp key $ Remote.retrieveKeyFile src key
|
||||
if ok
|
||||
then return $ Just $ fromCleanup src move key
|
||||
else return Nothing -- fail
|
||||
fromCleanup :: Git.Repo -> Bool -> Key -> CommandCleanup
|
||||
fromCleanup :: Remote.Remote Annex -> Bool -> Key -> CommandCleanup
|
||||
fromCleanup src True key = do
|
||||
ok <- Remotes.onRemote src (boolSystem, False) "dropkey"
|
||||
[ Params "--quiet --force"
|
||||
, Param $ show key
|
||||
]
|
||||
ok <- Remote.removeKey src key
|
||||
-- better safe than sorry: assume the src dropped the key
|
||||
-- even if it seemed to fail; the failure could have occurred
|
||||
-- after it really dropped it
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ genRemote r = do
|
|||
name = Git.repoDescribe r,
|
||||
storeKey = copyToRemote r,
|
||||
retrieveKeyFile = copyFromRemote r,
|
||||
removeKey = error "TODO Remote.GitRemote.removeKey",
|
||||
removeKey = dropKey r,
|
||||
hasKey = inAnnex r,
|
||||
hasKeyCheap = not (Git.repoIsUrl r)
|
||||
}
|
||||
|
|
@ -160,6 +160,13 @@ inAnnex r key = if Git.repoIsUrl r
|
|||
[Param (show key)]
|
||||
return $ Right inannex
|
||||
|
||||
dropKey :: Git.Repo -> Key -> Annex Bool
|
||||
dropKey r key =
|
||||
onRemote r (boolSystem, False) "dropkey"
|
||||
[ Params "--quiet --force"
|
||||
, Param $ show key
|
||||
]
|
||||
|
||||
{- Tries to copy a key's content from a remote's annex to a file. -}
|
||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemote r key file
|
||||
|
|
|
|||
334
Remotes.hs
334
Remotes.hs
|
|
@ -1,334 +0,0 @@
|
|||
{- git-annex remote repositories
|
||||
-
|
||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Remotes (
|
||||
list,
|
||||
readConfigs,
|
||||
keyPossibilities,
|
||||
inAnnex,
|
||||
same,
|
||||
byName,
|
||||
copyFromRemote,
|
||||
copyToRemote,
|
||||
onRemote
|
||||
) where
|
||||
|
||||
import Control.Exception.Extensible
|
||||
import Control.Monad.State (liftIO)
|
||||
import qualified Data.Map as Map
|
||||
import Data.String.Utils
|
||||
import System.Cmd.Utils
|
||||
import Data.List (intersect, sortBy)
|
||||
import Control.Monad (when, unless, filterM)
|
||||
|
||||
import Types
|
||||
import qualified GitRepo as Git
|
||||
import qualified Annex
|
||||
import LocationLog
|
||||
import Locations
|
||||
import UUID
|
||||
import Trust
|
||||
import Utility
|
||||
import qualified Content
|
||||
import Messages
|
||||
import CopyFile
|
||||
import RsyncFile
|
||||
import Ssh
|
||||
|
||||
{- Human visible list of remotes. -}
|
||||
list :: [Git.Repo] -> String
|
||||
list remotes = join ", " $ map Git.repoDescribe remotes
|
||||
|
||||
{- 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
|
||||
| not $ Map.null $ Git.configMap r = return $ Right r -- already read
|
||||
| Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" []
|
||||
| Git.repoIsUrl r = return $ Left r
|
||||
| otherwise = store $ safely $ Git.configRead r
|
||||
where
|
||||
-- Reading config can fail due to IO error or
|
||||
-- for other reasons; catch all possible exceptions.
|
||||
safely a = do
|
||||
result <- liftIO (try (a)::IO (Either SomeException Git.Repo))
|
||||
case result of
|
||||
Left _ -> return r
|
||||
Right r' -> return r'
|
||||
pipedconfig cmd params = safely $
|
||||
pOpen ReadFromPipe cmd (toCommand params) $
|
||||
Git.hConfigRead r
|
||||
store a = do
|
||||
r' <- a
|
||||
g <- Annex.gitRepo
|
||||
let l = Git.remotes g
|
||||
let g' = Git.remotesAdd g $ exchange l r'
|
||||
Annex.changeState $ \s -> s { Annex.repo = g' }
|
||||
return $ Right r'
|
||||
exchange [] _ = []
|
||||
exchange (old:ls) new =
|
||||
if Git.repoRemoteName old == Git.repoRemoteName new
|
||||
then new : exchange ls new
|
||||
else old : exchange ls new
|
||||
|
||||
{- Reads the configs of all remotes.
|
||||
-
|
||||
- This has to be called before things that rely on eg, the UUID of
|
||||
- remotes. Most such things will take care of running this themselves.
|
||||
-
|
||||
- As reading the config of remotes can be expensive, this
|
||||
- function will only read configs once per git-annex run. It's
|
||||
- assumed to be cheap to read the config of non-URL remotes,
|
||||
- so this is done each time git-annex is run. Conversely,
|
||||
- the config of an URL remote is only read when there is no
|
||||
- cached UUID value.
|
||||
- -}
|
||||
readConfigs :: Annex ()
|
||||
readConfigs = do
|
||||
-- remotesread <- Annex.getState Annex.remotesread
|
||||
let remotesread = False
|
||||
unless remotesread $ do
|
||||
g <- Annex.gitRepo
|
||||
allremotes <- filterM repoNotIgnored $ Git.remotes g
|
||||
let cheap = filter (not . Git.repoIsUrl) allremotes
|
||||
let expensive = filter Git.repoIsUrl allremotes
|
||||
doexpensive <- filterM cachedUUID expensive
|
||||
unless (null doexpensive) $
|
||||
showNote $ "getting UUID for " ++
|
||||
list doexpensive ++ "..."
|
||||
let todo = cheap ++ doexpensive
|
||||
unless (null todo) $ do
|
||||
mapM_ tryGitConfigRead todo
|
||||
-- Annex.changeState $ \s -> s { Annex.remotesread = True }
|
||||
where
|
||||
cachedUUID r = do
|
||||
u <- getUUID r
|
||||
return $ null u
|
||||
|
||||
{- Cost ordered lists of remotes that the LocationLog indicate may have a key.
|
||||
-
|
||||
- Also returns a list of UUIDs that are trusted to have the key
|
||||
- (some may not have configured remotes).
|
||||
-}
|
||||
keyPossibilities :: Key -> Annex ([Git.Repo], [UUID])
|
||||
keyPossibilities key = do
|
||||
readConfigs
|
||||
|
||||
allremotes <- remotesByCost
|
||||
g <- Annex.gitRepo
|
||||
u <- getUUID g
|
||||
trusted <- trustGet Trusted
|
||||
|
||||
-- get uuids of all repositories that are recorded to have the key
|
||||
uuids <- liftIO $ keyLocations g key
|
||||
let validuuids = filter (/= u) uuids
|
||||
|
||||
-- note that validuuids is assumed to not have dups
|
||||
let validtrusteduuids = intersect validuuids trusted
|
||||
|
||||
-- remotes that match uuids that have the key
|
||||
validremotes <- reposByUUID allremotes validuuids
|
||||
|
||||
return (validremotes, validtrusteduuids)
|
||||
|
||||
{- Checks if a given remote has the content for a key inAnnex.
|
||||
- If the remote cannot be accessed, returns a Left error.
|
||||
-}
|
||||
inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool)
|
||||
inAnnex r key = if Git.repoIsUrl r
|
||||
then checkremote
|
||||
else liftIO (try checklocal ::IO (Either IOException Bool))
|
||||
where
|
||||
checklocal = do
|
||||
-- run a local check inexpensively,
|
||||
-- by making an Annex monad using the remote
|
||||
a <- Annex.new r []
|
||||
Annex.eval a (Content.inAnnex key)
|
||||
checkremote = do
|
||||
showNote ("checking " ++ Git.repoDescribe r ++ "...")
|
||||
inannex <- onRemote r (boolSystem, False) "inannex"
|
||||
[Param (show key)]
|
||||
return $ Right inannex
|
||||
|
||||
{- 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. Throws out ignored ones. -}
|
||||
reposByCost :: [Git.Repo] -> Annex [Git.Repo]
|
||||
reposByCost l = do
|
||||
notignored <- filterM repoNotIgnored l
|
||||
costpairs <- mapM costpair notignored
|
||||
return $ fst $ unzip $ sortBy cmpcost costpairs
|
||||
where
|
||||
costpair r = do
|
||||
cost <- repoCost r
|
||||
return (r, cost)
|
||||
cmpcost (_, 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
|
||||
cost <- Annex.repoConfig r "cost" ""
|
||||
if not $ null cost
|
||||
then return $ read cost
|
||||
else if Git.repoIsUrl r
|
||||
then return 200
|
||||
else return 100
|
||||
|
||||
{- Checks if a repo should be ignored, based either on annex-ignore
|
||||
- setting, or on command-line options. Allows command-line to override
|
||||
- annex-ignore. -}
|
||||
repoNotIgnored :: Git.Repo -> Annex Bool
|
||||
repoNotIgnored r = do
|
||||
ignored <- Annex.repoConfig r "ignore" "false"
|
||||
to <- match Annex.toremote
|
||||
from <- match Annex.fromremote
|
||||
if to || from
|
||||
then return True
|
||||
else return $ not $ Git.configTrue ignored
|
||||
where
|
||||
match a = do
|
||||
name <- Annex.getState a
|
||||
case name of
|
||||
Nothing -> return False
|
||||
n -> return $ n == Git.repoRemoteName r
|
||||
|
||||
{- Checks if two repos are the same, by comparing their remote names. -}
|
||||
same :: Git.Repo -> Git.Repo -> Bool
|
||||
same a b = Git.repoRemoteName a == Git.repoRemoteName b
|
||||
|
||||
{- Looks up a remote by name. (Or by UUID.) -}
|
||||
byName :: String -> Annex Git.Repo
|
||||
byName "." = Annex.gitRepo -- special case to refer to current repository
|
||||
byName name = do
|
||||
when (null name) $ error "no remote specified"
|
||||
g <- Annex.gitRepo
|
||||
match <- filterM matching $ Git.remotes g
|
||||
when (null match) $ error $
|
||||
"there is no git remote named \"" ++ name ++ "\""
|
||||
return $ head match
|
||||
where
|
||||
matching r = do
|
||||
if Just name == Git.repoRemoteName r
|
||||
then return True
|
||||
else do
|
||||
u <- getUUID r
|
||||
return $ (name == u)
|
||||
|
||||
{- Tries to copy a key's content from a remote's annex to a file. -}
|
||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemote r key file
|
||||
| not $ Git.repoIsUrl r = liftIO $ copyFile (gitAnnexLocation r key) file
|
||||
| Git.repoIsSsh r = rsynchelper r True key file
|
||||
| otherwise = error "copying from non-ssh repo not supported"
|
||||
|
||||
{- Tries to copy a key's content to a remote's annex. -}
|
||||
copyToRemote :: Git.Repo -> Key -> Annex Bool
|
||||
copyToRemote r key
|
||||
| not $ Git.repoIsUrl r = do
|
||||
g <- Annex.gitRepo
|
||||
let keysrc = gitAnnexLocation g key
|
||||
-- run copy from perspective of remote
|
||||
liftIO $ do
|
||||
a <- Annex.new r []
|
||||
Annex.eval a $ do
|
||||
ok <- Content.getViaTmp key $
|
||||
\f -> liftIO $ copyFile keysrc f
|
||||
Annex.queueRun
|
||||
return ok
|
||||
| Git.repoIsSsh r = do
|
||||
g <- Annex.gitRepo
|
||||
let keysrc = gitAnnexLocation g key
|
||||
rsynchelper r False key keysrc
|
||||
| otherwise = error "copying to non-ssh repo not supported"
|
||||
|
||||
rsynchelper :: Git.Repo -> Bool -> Key -> FilePath -> Annex (Bool)
|
||||
rsynchelper r sending key file = do
|
||||
showProgress -- make way for progress bar
|
||||
p <- rsyncParams r sending key file
|
||||
res <- liftIO $ boolSystem "rsync" p
|
||||
if res
|
||||
then return res
|
||||
else do
|
||||
showLongNote "rsync failed -- run git annex again to resume file transfer"
|
||||
return res
|
||||
|
||||
{- Generates rsync parameters that ssh to the remote and asks it
|
||||
- to either receive or send the key's content. -}
|
||||
rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [CommandParam]
|
||||
rsyncParams r sending key file = do
|
||||
Just (shellcmd, shellparams) <- git_annex_shell r
|
||||
(if sending then "sendkey" else "recvkey")
|
||||
[ Param $ show key
|
||||
-- Command is terminated with "--", because
|
||||
-- rsync will tack on its own options afterwards,
|
||||
-- and they need to be ignored.
|
||||
, Param "--"
|
||||
]
|
||||
-- Convert the ssh command into rsync command line.
|
||||
let eparam = rsyncShell (Param shellcmd:shellparams)
|
||||
o <- Annex.repoConfig r "rsync-options" ""
|
||||
let base = options ++ map Param (words o) ++ eparam
|
||||
if sending
|
||||
then return $ base ++ [dummy, File file]
|
||||
else return $ base ++ [File file, dummy]
|
||||
where
|
||||
-- inplace makes rsync resume partial files
|
||||
options = [Params "-p --progress --inplace"]
|
||||
-- the rsync shell parameter controls where rsync
|
||||
-- goes, so the source/dest parameter can be a dummy value,
|
||||
-- that just enables remote rsync mode.
|
||||
dummy = Param ":"
|
||||
|
||||
{- Uses a supplied function to run a git-annex-shell command on a remote.
|
||||
-
|
||||
- Or, if the remote does not support running remote commands, returns
|
||||
- a specified error value. -}
|
||||
onRemote
|
||||
:: Git.Repo
|
||||
-> (FilePath -> [CommandParam] -> IO a, a)
|
||||
-> String
|
||||
-> [CommandParam]
|
||||
-> Annex a
|
||||
onRemote r (with, errorval) command params = do
|
||||
s <- git_annex_shell r command params
|
||||
case s of
|
||||
Just (c, ps) -> liftIO $ with c ps
|
||||
Nothing -> return errorval
|
||||
|
||||
{- Generates parameters to run a git-annex-shell command on a remote. -}
|
||||
git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
|
||||
git_annex_shell r command params
|
||||
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
|
||||
| Git.repoIsSsh r = do
|
||||
sshparams <- sshToRepo r [Param sshcmd]
|
||||
return $ Just ("ssh", sshparams)
|
||||
| otherwise = return Nothing
|
||||
where
|
||||
dir = Git.workTree r
|
||||
shellcmd = "git-annex-shell"
|
||||
shellopts = (Param command):(File dir):params
|
||||
sshcmd = shellcmd ++ " " ++
|
||||
unwords (map shellEscape $ toCommand shellopts)
|
||||
|
||||
{- Filters a list of repos to ones that have listed UUIDs. -}
|
||||
reposByUUID :: [Git.Repo] -> [UUID] -> Annex [Git.Repo]
|
||||
reposByUUID repos uuids = filterM match repos
|
||||
where
|
||||
match r = do
|
||||
u <- getUUID r
|
||||
return $ u `elem` uuids
|
||||
|
||||
Loading…
Reference in a new issue