diff options
| -rw-r--r-- | Annex.hs | 4 | ||||
| -rw-r--r-- | Command/Move.hs | 7 | ||||
| -rw-r--r-- | GitRepo.hs | 35 | ||||
| -rw-r--r-- | Remotes.hs | 68 |
4 files changed, 66 insertions, 48 deletions
@@ -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' diff --git a/Command/Move.hs b/Command/Move.hs index e872d86fe..4291d221a 100644 --- a/Command/Move.hs +++ b/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 diff --git a/GitRepo.hs b/GitRepo.hs index 2c2ad7b53..9dfce0d35 100644 --- a/GitRepo.hs +++ b/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 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.) -} |