unfinished switch to using git-annex-shell
This commit is contained in:
parent
a5a302b77d
commit
f38aa3e83a
4 changed files with 23 additions and 25 deletions
|
@ -134,8 +134,8 @@ fromPerform move key = do
|
|||
else return Nothing -- fail
|
||||
fromCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
|
||||
fromCleanup True remote key = do
|
||||
ok <- Remotes.runCmd remote "git-annex"
|
||||
["dropkey", "--quiet", "--force",
|
||||
ok <- Remotes.onRemote remote "dropkey"
|
||||
["--quiet", "--force",
|
||||
"--backend=" ++ backendName key,
|
||||
keyName key]
|
||||
remoteHasKey remote key False
|
||||
|
|
40
Remotes.hs
40
Remotes.hs
|
@ -15,7 +15,8 @@ module Remotes (
|
|||
byName,
|
||||
copyFromRemote,
|
||||
copyToRemote,
|
||||
runCmd
|
||||
runCmd,
|
||||
onRemote
|
||||
) where
|
||||
|
||||
import Control.Exception.Extensible
|
||||
|
@ -37,7 +38,6 @@ import Utility
|
|||
import qualified Core
|
||||
import Messages
|
||||
import CopyFile
|
||||
import qualified SysConfig
|
||||
|
||||
{- Human visible list of remotes. -}
|
||||
list :: [Git.Repo] -> String
|
||||
|
@ -118,7 +118,8 @@ inAnnex r key = if Git.repoIsUrl r
|
|||
Annex.eval a (Core.inAnnex key)
|
||||
checkremote = do
|
||||
showNote ("checking " ++ Git.repoDescribe r ++ "...")
|
||||
inannex <- runCmd r "test" ["-e", annexLocation r key]
|
||||
inannex <- onRemote r "inannex"
|
||||
["--backend=" ++ backendName key, keyName key]
|
||||
-- XXX Note that ssh failing and the file not existing
|
||||
-- are not currently differentiated.
|
||||
return $ Right inannex
|
||||
|
@ -231,7 +232,7 @@ copyFromRemote r key file
|
|||
where
|
||||
keyloc = annexLocation r key
|
||||
getlocal = liftIO $ copyFile keyloc file
|
||||
getssh = remoteCopyFile r (sshLocation r 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
|
||||
|
@ -245,35 +246,32 @@ copyToRemote r key file = do
|
|||
else error "copying to non-ssh repo not supported"
|
||||
where
|
||||
putlocal src = liftIO $ copyFile src file
|
||||
putssh src = remoteCopyFile r src (sshLocation r file)
|
||||
putssh src = remoteCopyFile False r src (sshLocation r file)
|
||||
|
||||
sshLocation :: Git.Repo -> FilePath -> FilePath
|
||||
sshLocation r file = Git.urlHost r ++ ":" ++ shellEscape file
|
||||
|
||||
{- Copys a file from or to a remote, using rsync (when available) or scp. -}
|
||||
remoteCopyFile :: Git.Repo -> String -> String -> Annex Bool
|
||||
remoteCopyFile r src dest = do
|
||||
{- Copies a file from or to a remote, using rsync (when available) or scp. -}
|
||||
remoteCopyFile :: Bool -> Git.Repo -> String -> String -> Annex Bool
|
||||
remoteCopyFile recv r src dest = do
|
||||
showProgress -- make way for progress bar
|
||||
o <- repoConfig r configopt ""
|
||||
res <- liftIO $ boolSystem cmd $ options ++ words o ++ [src, dest]
|
||||
if res
|
||||
then return res
|
||||
else do
|
||||
when rsync $
|
||||
showLongNote "rsync failed -- run git annex again to resume file transfer"
|
||||
showLongNote "rsync failed -- run git annex again to resume file transfer"
|
||||
return res
|
||||
where
|
||||
cmd
|
||||
| rsync = "rsync"
|
||||
| otherwise = "scp"
|
||||
configopt
|
||||
| rsync = "rsync-options"
|
||||
| otherwise = "scp-options"
|
||||
options
|
||||
-- inplace makes rsync resume partial files
|
||||
| rsync = ["-p", "--progress", "--inplace"]
|
||||
| otherwise = ["-p"]
|
||||
rsync = SysConfig.rsync
|
||||
cmd = "rsync"
|
||||
configopt= "rsync-options"
|
||||
-- inplace makes rsync resume partial files
|
||||
options = ["-p", "--progress", "--inplace"]
|
||||
|
||||
onRemote :: Git.Repo -> String -> [String] -> Annex Bool
|
||||
onRemote r command params = runCmd r "git-annex-shell" (command:dir:params)
|
||||
where
|
||||
dir = Git.workTree r
|
||||
|
||||
{- Runs a command in a remote, using ssh if necessary.
|
||||
- (Honors annex-ssh-options.) -}
|
||||
|
|
|
@ -22,7 +22,7 @@ tests = [
|
|||
, TestCase "cp --reflink=auto" "cp_reflink_auto" $ testCp "--reflink=auto"
|
||||
, TestCase "uuid" "uuid" $ requireCmd "uuid" "uuid"
|
||||
, TestCase "xargs -0" "xargs_0" $ requireCmd "xargs -0" "xargs -0 </dev/null"
|
||||
, TestCase "rsync" "rsync" $ testCmd "rsync --version >/dev/null"
|
||||
, TestCase "rsync" "rsync" $ requireCmd "rsync" "rsync --version >/dev/null"
|
||||
]
|
||||
|
||||
tmpDir :: String
|
||||
|
|
|
@ -6,7 +6,7 @@ To build and use git-annex, you will need:
|
|||
* pcre-light: <http://hackage.haskell.org/package/pcre-light>
|
||||
* `uuid`: <http://www.ossp.org/pkg/lib/uuid/>
|
||||
* `xargs`: <http://savannah.gnu.org/projects/findutils/>
|
||||
* `rsync`: <http://rsync.samba.org/> (optional but recommended)
|
||||
* `rsync`: <http://rsync.samba.org/>
|
||||
* Then just [[download]] git-annex and run: `make; make install`
|
||||
|
||||
([Ikiwiki](http://ikiwiki.info) is needed to build the documentation,
|
||||
|
|
Loading…
Reference in a new issue