support checking network remotes when dropping

This commit is contained in:
Joey Hess 2010-10-22 15:06:14 -04:00
parent 91e6625eb5
commit aafb63edb1
3 changed files with 39 additions and 18 deletions

View file

@ -44,9 +44,18 @@ mustProvide = error "must provide this field"
dummyStore :: FilePath -> Key -> Annex (Bool) dummyStore :: FilePath -> Key -> Annex (Bool)
dummyStore file key = return True dummyStore file key = return True
{- Just check if the .git/annex/ file for the key exists. -} {- Just check if the .git/annex/ file for the key exists.
-
- But, if running against a remote annex, need to use ssh to do it. -}
checkKeyFile :: Key -> Annex Bool checkKeyFile :: Key -> Annex Bool
checkKeyFile k = inAnnex k checkKeyFile k = do
g <- Annex.gitRepo
if (not $ Git.repoIsUrl g)
then inAnnex k
else do
showNote ("checking " ++ Git.repoDescribe g ++ "...")
liftIO $ boolSystem "ssh" [Git.urlHost g,
"test -e " ++ (shellEscape $ annexLocation g k)]
{- Try to find a copy of the file in one of the remotes, {- Try to find a copy of the file in one of the remotes,
- and copy it over to this one. -} - and copy it over to this one. -}
@ -85,11 +94,13 @@ copyFromRemote r key file = do
then getssh then getssh
else error "copying from non-ssh repo not supported" else error "copying from non-ssh repo not supported"
where where
location = annexLocation r key
getlocal = boolSystem "cp" ["-a", location, file] getlocal = boolSystem "cp" ["-a", location, file]
getssh = do getssh = do
liftIO $ putStrLn "" -- make way for scp progress bar liftIO $ putStrLn "" -- make way for scp progress bar
boolSystem "scp" [location, file] -- TODO double-shell-quote path for scp
boolSystem "scp" [sshlocation, file]
location = annexLocation r key
sshlocation = (Git.urlHost r) ++ ":" ++ location
showLocations :: Key -> Annex () showLocations :: Key -> Annex ()
showLocations key = do showLocations key = do

View file

@ -16,6 +16,8 @@ module GitRepo (
workTree, workTree,
dir, dir,
relative, relative,
urlPath,
urlHost,
configGet, configGet,
configMap, configMap,
configRead, configRead,
@ -110,7 +112,7 @@ repoIsSsh repo = repoIsUrl repo && (uriScheme $ url repo) == "ssh:"
assertLocal repo action = assertLocal repo action =
if (not $ repoIsUrl repo) if (not $ repoIsUrl repo)
then action then action
else error $ "acting on remote git repo " ++ (repoDescribe repo) ++ else error $ "acting on URL git repo " ++ (repoDescribe repo) ++
" not supported" " not supported"
assertUrl repo action = assertUrl repo action =
if (repoIsUrl repo) if (repoIsUrl repo)
@ -137,23 +139,18 @@ attributes repo = assertLocal repo $ do
then (top repo) ++ "/info/.gitattributes" then (top repo) ++ "/info/.gitattributes"
else (top repo) ++ "/.gitattributes" else (top repo) ++ "/.gitattributes"
{- Path to a repository's .git directory, relative to its topdir. -} {- Path to a repository's .git directory, relative to its workTree. -}
dir :: Repo -> String dir :: Repo -> String
dir repo = if (bare repo) then "" else ".git" dir repo = if (bare repo) then "" else ".git"
{- Path to a repository's --work-tree. -} {- Path to a repository's --work-tree, that is, its top.
-
- Note that for URL repositories, this is relative to the urlHost -}
workTree :: Repo -> FilePath workTree :: Repo -> FilePath
workTree repo = workTree repo =
if (not $ repoIsUrl repo) if (not $ repoIsUrl repo)
then top repo then top repo
else assertssh repo $ (remoteHost repo) ++ ":" ++ (uriPath $ url repo) else urlPath repo
{- Hostname for a remote repo. (May include a username and/or port too.) -}
remoteHost :: Repo -> String
remoteHost repo = assertUrl repo $
(uriUserInfo a) ++ (uriRegName a) ++ (uriPort a)
where
a = fromJust $ uriAuthority $ url repo
{- Given a relative or absolute filename in a repository, calculates the {- Given a relative or absolute filename in a repository, calculates the
- name to use to refer to the file relative to a git repository's top. - name to use to refer to the file relative to a git repository's top.
@ -170,6 +167,18 @@ relative repo file = drop (length absrepo) absfile
Just f -> f Just f -> f
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
{- Hostname of an URL repo. (May include a username and/or port too.) -}
urlHost :: Repo -> String
urlHost repo = assertUrl repo $
(uriUserInfo a) ++ (uriRegName a) ++ (uriPort a)
where
a = fromJust $ uriAuthority $ url repo
{- Path of an URL repo. -}
urlPath :: Repo -> String
urlPath repo = assertUrl repo $
uriPath $ url repo
{- Constructs a git command line operating on the specified repo. -} {- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: Repo -> [String] -> [String] gitCommandLine :: Repo -> [String] -> [String]
gitCommandLine repo params = assertLocal repo $ gitCommandLine repo params = assertLocal repo $
@ -215,9 +224,9 @@ configRead repo =
(\_ -> changeWorkingDirectory cwd) $ (\_ -> changeWorkingDirectory cwd) $
pOpen ReadFromPipe "git" ["config", "--list"] proc pOpen ReadFromPipe "git" ["config", "--list"] proc
else assertssh repo $ do else assertssh repo $ do
pOpen ReadFromPipe "ssh" [remoteHost repo, sshcommand] proc pOpen ReadFromPipe "ssh" [urlHost repo, sshcommand] proc
where where
sshcommand = "cd '" ++ (uriPath $ url repo) ++ "' && git config --list" sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++ " && git config --list"
proc h = do proc h = do
val <- hGetContentsStrict h val <- hGetContentsStrict h
let r = repo { config = configParse val } let r = repo { config = configParse val }

3
debian/changelog vendored
View file

@ -1,7 +1,8 @@
git-annex (0.02) UNRELEASED; urgency=low git-annex (0.02) UNRELEASED; urgency=low
* New fromkey subcommand, for registering urls, etc. * New fromkey subcommand, for registering urls, etc.
* Can scp annexed files from remotes. * Can scp annexed files from remote hosts, and check remote hosts for
file content when dropping files.
-- Joey Hess <joeyh@debian.org> Thu, 21 Oct 2010 16:38:00 -0400 -- Joey Hess <joeyh@debian.org> Thu, 21 Oct 2010 16:38:00 -0400