summaryrefslogtreecommitdiff
path: root/Remotes.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2010-12-31 15:46:33 -0400
committerGravatar Joey Hess <joey@kitenet.net>2010-12-31 15:46:33 -0400
commiteac433a84ad397e371300343b7cd30b7741ee023 (patch)
treeb3e02fa4f6942657f622c4790d9fb4d2d2a17e95 /Remotes.hs
parent60df4e5728b8af804f06c39ef3b897af12247ceb (diff)
use git-annex-shell configlist
Diffstat (limited to 'Remotes.hs')
-rw-r--r--Remotes.hs68
1 files changed, 44 insertions, 24 deletions
diff --git a/Remotes.hs b/Remotes.hs
index ca65c99ff..841fe947f 100644
--- a/Remotes.hs
+++ b/Remotes.hs
@@ -25,6 +25,7 @@ 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)
@@ -112,16 +113,14 @@ inAnnex r key = if Git.repoIsUrl r
else liftIO (try checklocal ::IO (Either IOException Bool))
where
checklocal = do
- -- run a local check by making an Annex monad
- -- using the remote
+ -- run a local check inexpensively,
+ -- by making an Annex monad using the remote
a <- Annex.new r []
Annex.eval a (Core.inAnnex key)
checkremote = do
showNote ("checking " ++ Git.repoDescribe r ++ "...")
- inannex <- onRemote r "inannex"
+ inannex <- onRemote r boolSystem False "inannex"
["--backend=" ++ backendName key, keyName key]
- -- XXX Note that ssh failing and the file not existing
- -- are not currently differentiated.
return $ Right inannex
{- Cost Ordered list of remotes. -}
@@ -199,24 +198,29 @@ byName name = do
- 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 = do
- sshoptions <- repoConfig r "ssh-options" ""
- if Map.null $ Git.configMap r
- then do
- -- configRead can fail due to IO error or
- -- for other reasons; catch all possible exceptions
- result <- liftIO (try (Git.configRead r $ Just $ words sshoptions)::IO (Either SomeException 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 $ Left r
- Right r' -> do
- g <- Annex.gitRepo
- let l = Git.remotes g
- let g' = Git.remotesAdd g $
- exchange l r'
- Annex.gitRepoChange g'
- return $ Right r'
- else return $ Right r -- config already read
- where
+ Left _ -> return r
+ Right r' -> return r'
+ pipedconfig cmd params = safely $
+ pOpen ReadFromPipe cmd 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.gitRepoChange g'
+ return $ Right r'
exchange [] _ = []
exchange (old:ls) new =
if Git.repoRemoteName old == Git.repoRemoteName new
@@ -268,10 +272,26 @@ remoteCopyFile recv r src dest = do
-- 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)
+{- Uses a supplied function to run a git-annex-shell command on a remote. -}
+onRemote
+ :: Git.Repo
+ -> (String -> [String] -> IO a)
+ -> a
+ -> String
+ -> [String]
+ -> Annex a
+onRemote r with errorval command params
+ | not $ Git.repoIsUrl r = liftIO $ with shellcmd shellopts
+ | Git.repoIsSsh r = do
+ sshoptions <- repoConfig r "ssh-options" ""
+ liftIO $ with "ssh" $
+ words sshoptions ++ [Git.urlHost r, sshcmd]
+ | otherwise = return errorval
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.) -}