diff options
| -rw-r--r-- | Command/Move.hs | 60 | ||||
| -rw-r--r-- | Remote/GitRemote.hs | 9 | ||||
| -rw-r--r-- | Remotes.hs | 334 |
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 - |