use git-annex-shell configlist

Annex.hs

@@ -47,7 +47,7 @@ new gitrepo allbackends = do
 	where
 		prep = do
 			-- read git config and update state
-			gitrepo' <- liftIO $ Git.configRead gitrepo Nothing
+			gitrepo' <- liftIO $ Git.configRead gitrepo
 			Annex.gitRepoChange gitrepo'
 
 {- performs an action in the Annex monad -}
@@ -136,5 +136,5 @@ setConfig key value = do
 	g <- Annex.gitRepo
 	liftIO $ Git.run g ["config", key, value]
 	-- re-read git config and update the repo's state
-	g' <- liftIO $ Git.configRead g Nothing
+	g' <- liftIO $ Git.configRead g
 	Annex.gitRepoChange g'

Command/Move.hs

@@ -7,6 +7,7 @@
 
 module Command.Move where
 
+import Control.Monad (when)
 import Control.Monad.State (liftIO)
 
 import Command
@@ -20,6 +21,7 @@ import qualified GitRepo as Git
 import qualified Remotes
 import UUID
 import Messages
+import Utility
 	
 command :: [Command]
 command = [Command "move" paramPath seek
@@ -134,10 +136,11 @@ fromPerform move key = do
 				else return Nothing -- fail
 fromCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup
 fromCleanup True remote key = do
-	ok <- Remotes.onRemote remote "dropkey" 
+	ok <- Remotes.onRemote remote boolSystem False "dropkey" 
 		["--quiet", "--force",
 		"--backend=" ++ backendName key,
 		keyName key]
-	remoteHasKey remote key False
+	when ok $
+		remoteHasKey remote key False
 	return ok
 fromCleanup False _ _ = return True

GitRepo.hs

@@ -24,6 +24,8 @@ module GitRepo (
 	configGet,
 	configMap,
 	configRead,
+	hConfigRead,
+	configStore,
 	configTrue,
 	gitCommandLine,
 	run,
@@ -141,11 +143,7 @@ assertUrl repo action =
 		then action
 		else error $ "acting on local git repo " ++  repoDescribe repo ++ 
 				" not supported"
-assertSsh :: Repo -> a -> a
-assertSsh repo action =
-	if repoIsSsh repo
-		then action
-		else error $ "unsupported url in repo " ++ repoDescribe repo
+
 bare :: Repo -> Bool
 bare repo = case Map.lookup "core.bare" $ config repo of
 	Just v -> configTrue v
@@ -276,11 +274,9 @@ pipeNullSplit repo params = do
 	where
 		split0 s = filter (not . null) $ split "\0" s
 
-{- Runs git config and populates a repo with its config. 
- -
- - For a ssh repository, a list of ssh options may optionally be specified. -}
-configRead :: Repo -> Maybe [String] -> IO Repo
-configRead repo@(Repo { location = Dir d }) _ = do
+{- Runs git config and populates a repo with its config. -}
+configRead :: Repo -> IO Repo
+configRead repo@(Repo { location = Dir d }) = do
 	{- Cannot use pipeRead because it relies on the config having
 	   been already read. Instead, chdir to the repo. -}
 	cwd <- getCurrentDirectory
@@ -288,19 +284,18 @@ configRead repo@(Repo { location = Dir d }) _ = do
 		(\_ -> changeWorkingDirectory cwd) $
 			pOpen ReadFromPipe "git" ["config", "--list"] $
 				hConfigRead repo
-configRead repo sshopts = assertSsh repo $ do
-	pOpen ReadFromPipe "ssh" params $ hConfigRead repo
-	where
-		params = case sshopts of
-				Nothing -> [urlHost repo, command]
-				Just l -> l ++ [urlHost repo, command]
-		command = "cd " ++ shellEscape (urlPath repo) ++
-				" && git config --list"
+configRead r = assertLocal r $ error "internal"
+
+{- Reads git config from a handle and populates a repo with it. -}
 hConfigRead :: Repo -> Handle -> IO Repo
 hConfigRead repo h = do
 	val <- hGetContentsStrict h
-	let r = repo { config = configParse val }
-	return r { remotes = configRemotes r }	
+	return $ configStore repo val
+
+{- Parses a git config and returns a version of the repo using it. -}
+configStore :: Repo -> String -> Repo
+configStore repo s = r { remotes = configRemotes r }
+	where r = repo { config = configParse s }
 
 {- Checks if a string fron git config is a true value. -}
 configTrue :: String -> Bool

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.) -}