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