summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Command/Move.hs60
-rw-r--r--Remote/GitRemote.hs9
-rw-r--r--Remotes.hs334
3 files changed, 36 insertions, 367 deletions
diff --git a/Command/Move.hs b/Command/Move.hs
index 8056e95db..907bbf00e 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -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
diff --git a/Remote/GitRemote.hs b/Remote/GitRemote.hs
index 8671ef7fa..43e75b97b 100644
--- a/Remote/GitRemote.hs
+++ b/Remote/GitRemote.hs
@@ -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)
}
@@ -159,6 +159,13 @@ inAnnex r key = if Git.repoIsUrl r
inannex <- onRemote r (boolSystem, False) "inannex"
[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
diff --git a/Remotes.hs b/Remotes.hs
deleted file mode 100644
index 7f6a6718b..000000000
--- a/Remotes.hs
+++ /dev/null
@@ -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
-