mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

git-annex-shell now exclusively used for all remote access

Browse source
This commit is contained in:
Joey Hess 2010-12-31 19:09:17 -04:00
parent 30e0065ab9
commit 700aed13cf
6 changed files with 102 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
Backend/File.hs
View file

@ -65,12 +65,7 @@ copyKeyFile key file = do
trycopy full (r:rs) = do
probablythere <- probablyPresent r
if probablythere
then do
showNote $ "copying from " ++ Git.repoDescribe r ++ "..."
copied <- Remotes.copyFromRemote r key file
if copied
then return True
else trycopy full rs
then docopy r (trycopy full rs)
else trycopy full rs
-- This check is to avoid an ugly message if a remote is a
-- drive that is not mounted. Avoid checking inAnnex for ssh
@ -82,6 +77,12 @@ copyKeyFile key file = do
if not $ Git.repoIsUrl r
then liftIO $ doesFileExist $ annexLocation r key
else return True
docopy r continue = do
showNote $ "copying from " ++ Git.repoDescribe r ++ "..."
copied <- Remotes.copyFromRemote r key file
if copied
then return True
else continue
{- Checks remotes to verify that enough copies of a key exist to allow
- for a key to be safely removed (with no data loss), and fails with an

33
Command/Move.hs
View file

@ -7,13 +7,11 @@
module Command.Move where
import Control.Monad (when)
import Control.Monad.State (liftIO)
import Command
import qualified Command.Drop
import qualified Annex
import Locations
import LocationLog
import Types
import Core
@ -86,26 +84,17 @@ toPerform move key = do
return Nothing
Right False -> do
showNote $ "to " ++ Git.repoDescribe remote ++ "..."
let tmpfile = annexTmpLocation remote ++ keyFile key
ok <- Remotes.copyToRemote remote key tmpfile
ok <- Remotes.copyToRemote remote key
if ok
then return $ Just $ toCleanup move remote key tmpfile
then return $ Just $ toCleanup move remote key
else return Nothing -- failed
Right True -> return $ Just $ Command.Drop.cleanup key
toCleanup :: Bool -> Git.Repo -> Key -> FilePath -> CommandCleanup
toCleanup move remote key tmpfile = do
-- Tell remote to use the transferred content.
ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
"--backend=" ++ backendName key,
"--key=" ++ keyName key,
tmpfile]
if ok
then do
remoteHasKey remote key True
if move
then Command.Drop.cleanup key
else return True
else return False
toCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
toCleanup move remote key = do
remoteHasKey remote 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.
@ -140,7 +129,9 @@ fromCleanup True remote key = do
["--quiet", "--force",
"--backend=" ++ backendName key,
keyName key]
when ok $
remoteHasKey remote key False
-- better safe than sorry: assume the remote dropped the key
-- even if it seemed to fail; the failure could have occurred
-- after it really dropped it
remoteHasKey remote key False
return ok
fromCleanup False _ _ = return True

6
Command/RecvKey.hs
View file

@ -34,5 +34,9 @@ start keyname = do
ok <- getViaTmp key (liftIO . rsyncServerReceive)
if ok
then return Nothing
then do
-- forcibly quit after receiving one key,
-- and shutdown cleanly so queued git commands run
_ <- shutdown 0
liftIO exitSuccess
else liftIO exitFailure

124
Remotes.hs
View file

@ -15,7 +15,6 @@ module Remotes (
byName,
copyFromRemote,
copyToRemote,
runCmd,
onRemote
) where
@ -23,11 +22,10 @@ import Control.Exception.Extensible
import Control.Monad.State (liftIO)
import qualified Data.Map as Map
import Data.String.Utils
import System.Directory hiding (copyFile)
import System.Posix.Directory
import System.Cmd.Utils
import Data.List (intersect, sortBy)
import Control.Monad (when, unless, filterM)
import Data.Maybe
import Types
import qualified GitRepo as Git
@ -39,6 +37,7 @@ import Utility
import qualified Core
import Messages
import CopyFile
import RsyncFile
{- Human visible list of remotes. -}
list :: [Git.Repo] -> String
@ -227,92 +226,95 @@ tryGitConfigRead r
then new : exchange ls new
else old : exchange ls new
{- Tries to copy a key's content from a remote to a file. -}
{- 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 = getlocal
| Git.repoIsSsh r = getssh
| not $ Git.repoIsUrl r = liftIO $ copyFile (annexLocation r key) file
| Git.repoIsSsh r = rsynchelper r True key file
| otherwise = error "copying from non-ssh repo not supported"
where
keyloc = annexLocation r key
getlocal = liftIO $ copyFile keyloc file
getssh = remoteCopyFile True r (sshLocation r keyloc) file
{- Tries to copy a key's content to a file on a remote. -}
copyToRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
copyToRemote r key file = do
g <- Annex.gitRepo
let keyloc = annexLocation g key
if not $ Git.repoIsUrl r
then putlocal keyloc
else if Git.repoIsSsh r
then putssh keyloc
else error "copying to non-ssh repo not supported"
where
putlocal src = liftIO $ copyFile src file
putssh src = remoteCopyFile False r src (sshLocation r file)
{- 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 = annexLocation g key
let keydest = annexLocation r key
liftIO $ copyFile keysrc keydest
| Git.repoIsSsh r = do
g <- Annex.gitRepo
let keysrc = annexLocation g key
rsynchelper r False key keysrc
| otherwise = error "copying to non-ssh repo not supported"
sshLocation :: Git.Repo -> FilePath -> FilePath
sshLocation r file = Git.urlHost r ++ ":" ++ shellEscape file
{- Copies a file from or to a remote, using rsync. -}
remoteCopyFile :: Bool -> Git.Repo -> String -> String -> Annex Bool
remoteCopyFile recv r src dest = do
rsynchelper :: Git.Repo -> Bool -> Key -> FilePath -> Annex (Bool)
rsynchelper r sending key file = do
showProgress -- make way for progress bar
o <- repoConfig r configopt ""
res <- liftIO $ boolSystem cmd $ options ++ words o ++ [src, dest]
p <- rsyncParams r sending key file
liftIO $ putStrLn $ unwords p
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 [String]
rsyncParams r sending key file = do
-- Note that the command is terminated with "--", because
-- rsync will tack on its own options to this command,
-- and they need to be ignored.
shellcmd <- git_annex_shell r
(if sending then "sendkey" else "recvkey")
["--backend=" ++ backendName key, keyName key, "--"]
-- Convert the ssh command into rsync command line.
let eparam = rsyncShell $ fromJust shellcmd
o <- repoConfig r "rsync-options" ""
let base = options ++ words o ++ eparam
if sending
then return $ base ++ [dummy, file]
else return $ base ++ [file, dummy]
where
cmd = "rsync"
configopt= "rsync-options"
-- inplace makes rsync resume partial files
options = ["-p", "--progress", "--inplace"]
-- the rsync shell parameter controls where rsync
-- does, so the source/dest parameter can be a dummy value,
-- that just enables remote rsync mode.
dummy = ":"
{- Uses a supplied function to run a git-annex-shell command on a remote. -}
{- 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
-> ((String -> [String] -> IO a), a)
-> (String -> [String] -> IO a, a)
-> String
-> [String]
-> Annex a
onRemote r (with, errorval) command params
| not $ Git.repoIsUrl r = liftIO $ with shellcmd shellopts
onRemote r (with, errorval) command params = do
s <- git_annex_shell r command params
case s of
Just shellcmd -> liftIO $ with (shellcmd !! 0) (tail shellcmd)
Nothing -> return errorval
{- Generates parameters to run a git-annex-shell command on a remote. -}
git_annex_shell :: Git.Repo -> String -> [String] -> Annex (Maybe [String])
git_annex_shell r command params
| not $ Git.repoIsUrl r = return $ Just (shellcmd:shellopts)
| Git.repoIsSsh r = do
sshoptions <- repoConfig r "ssh-options" ""
liftIO $ with "ssh" $
words sshoptions ++ [Git.urlHost r, sshcmd]
| otherwise = return errorval
return $ Just $ ["ssh"] ++ words sshoptions ++
[Git.urlHost r, sshcmd]
| otherwise = return Nothing
where
dir = Git.workTree r
shellcmd = "git-annex-shell"
shellopts = command:dir:params
sshcmd = shellcmd ++ " " ++ unwords (map shellEscape shellopts)
{- Runs a command in a remote, using ssh if necessary.
- (Honors annex-ssh-options.) -}
runCmd :: Git.Repo -> String -> [String] -> Annex Bool
runCmd r command params = do
sshoptions <- repoConfig r "ssh-options" ""
if not $ Git.repoIsUrl r
then do
cwd <- liftIO getCurrentDirectory
liftIO $ bracket_
(changeWorkingDirectory (Git.workTree r))
(changeWorkingDirectory cwd)
(boolSystem command params)
else if Git.repoIsSsh r
then liftIO $ boolSystem "ssh" $
words sshoptions ++ [Git.urlHost r, sshcmd]
else error "running command in non-ssh repo not supported"
where
sshcmd = "cd " ++ shellEscape (Git.workTree r) ++
" && " ++ shellEscape command ++ " " ++
unwords (map shellEscape params)
{- Looks up a per-remote config option in git config.
- Failing that, tries looking for a global config option. -}
repoConfig :: Git.Repo -> String -> String -> Annex String

14
RsyncFile.hs
View file

@ -7,8 +7,20 @@
module RsyncFile where
import Utility
import System.Posix.Process
import Data.String.Utils
import Utility
{- Generates parameters to make rsync use a specified command as its remote
- shell. -}
rsyncShell :: [String] -> [String]
rsyncShell command = ["-e", unwords $ map escape command]
where
{- rsync requires some weird, non-shell like quoting in
- here. A doubled single quote inside the single quoted
- string is a single quote. -}
escape s = "'" ++ (join "''" $ split "'" s) ++ "'"
{- Runs rsync in server mode to send a file, and exits. -}
rsyncServerSend :: FilePath -> IO ()

37
doc/todo/git-annex-shell.mdwn
View file

@ -1,3 +1,5 @@
[[done]]
I've been considering adding a `git-annex-shell` command. This would
be similar to `git-shell` (and in fact would pass unknown commands off to
`git-shell`).
@ -11,38 +13,3 @@ be similar to `git-shell` (and in fact would pass unknown commands off to
* Could possibly allow multiple things to be done with one ssh connection
in future.
* Allows expanding `~` and `~user` in repopath on the remote system.
## Design
`git-annex-shell -c <command> <repopath> <arguments>`
### options
Need at least `--quiet`, `--backend`, `--key`, `--force`
### commands
* `configlist repopath`
Returns `git config --list`, for use by `tryGitConfigRead`.
May filter the listed config to only the options git-annex really needs,
to prevent info disclosure.
* `inannex repopath key ...`
Checks if the keys are in the annex; shell exits zero if so.
* `dropkey repopath key ... `
Same as `git annex dropkey`, and taking the same dashed options.
* `setkey repopath tmpfile`
Same as `git annex setkey`, and taking the same dashed options.
### TODO
* To be usable as a locked down shell, needs a way to launch the
rsync server, for file receiving. Safely?
* Also needs a way to support receiving files by scp.