diff options
-rw-r--r-- | Annex/Branch.hs | 4 | ||||
-rw-r--r-- | Assistant/MakeRemote.hs | 5 | ||||
-rw-r--r-- | Assistant/Sync.hs | 14 | ||||
-rw-r--r-- | Assistant/Threads/Committer.hs | 9 | ||||
-rw-r--r-- | Assistant/Threads/SanityChecker.hs | 7 | ||||
-rw-r--r-- | Command/Direct.hs | 8 | ||||
-rw-r--r-- | Command/Indirect.hs | 7 | ||||
-rw-r--r-- | Command/Sync.hs | 23 | ||||
-rw-r--r-- | Command/Unannex.hs | 12 | ||||
-rw-r--r-- | Command/Uninit.hs | 4 | ||||
-rw-r--r-- | Config.hs | 6 | ||||
-rw-r--r-- | Git/Branch.hs | 5 | ||||
-rw-r--r-- | Git/Command.hs | 28 | ||||
-rw-r--r-- | Git/Merge.hs | 6 | ||||
-rw-r--r-- | Git/Ref.hs | 4 | ||||
-rw-r--r-- | Remote/Bup.hs | 7 | ||||
-rw-r--r-- | Remote/Git.hs | 4 | ||||
-rw-r--r-- | Remote/Helper/Special.hs | 4 | ||||
-rw-r--r-- | Upgrade/V2.hs | 8 | ||||
-rw-r--r-- | debian/changelog | 3 |
20 files changed, 98 insertions, 70 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 652ba6ff9..4a36de66a 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -76,8 +76,8 @@ getBranch :: Annex Git.Ref getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha where go True = do - inRepo $ Git.Command.run "branch" - [Param $ show name, Param $ show originname] + inRepo $ Git.Command.run + [Param "branch", Param $ show name, Param $ show originname] fromMaybe (error $ "failed to create " ++ show name) <$> branchsha go False = withIndex' True $ diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 479ebd3ff..b01b051f6 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -77,9 +77,8 @@ makeSpecialRemote name remotetype config = do - remote at the location, returns its name. -} makeGitRemote :: String -> String -> Annex String makeGitRemote basename location = makeRemote basename location $ \name -> - void $ inRepo $ - Git.Command.runBool "remote" - [Param "add", Param name, Param location] + void $ inRepo $ Git.Command.runBool + [Param "remote", Param "add", Param name, Param location] {- If there's not already a remote at the location, adds it using the - action, which is passed the name of the remote to make. diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 613d03980..8546aa318 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -141,13 +141,13 @@ pushToRemotes now notifypushes remotes = do - uuid in them. While ugly, those branches are reserved for pushing by us, - and so our pushes will never conflict with other pushes. -} pushFallback :: UUID -> Git.Ref -> Remote -> Git.Repo -> IO Bool -pushFallback u branch remote = Git.Command.runBool "push" params +pushFallback u branch remote = Git.Command.runBool + [ Param "push" + , Param $ Remote.name remote + , Param $ refspec Annex.Branch.name + , Param $ refspec branch + ] where - params = - [ Param $ Remote.name remote - , Param $ refspec Annex.Branch.name - , Param $ refspec branch - ] {- Push to refs/synced/uuid/branch; this - avoids cluttering up the branch display. -} refspec b = concat @@ -162,7 +162,7 @@ manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool) manualPull currentbranch remotes = do g <- liftAnnex gitRepo results <- liftIO $ forM remotes $ \r -> - Git.Command.runBool "fetch" [Param $ Remote.name r] g + Git.Command.runBool [Param "fetch", Param $ Remote.name r] g haddiverged <- liftAnnex Annex.Branch.forceUpdate forM_ remotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r currentbranch diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index bd858ed38..75976ee3c 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -81,9 +81,10 @@ commitStaged = do Left _ -> return False Right _ -> do direct <- isDirect - let params = nomessage $ - catMaybes - [ Just $ Param "--quiet" + let params = nomessage $ catMaybes + [ Just $ Param "-c", Just $ Param "gc.auto=0" + , Just $ Param "commit" + , Just $ Param "--quiet" {- In indirect mode, avoid running the - usual git-annex pre-commit hook; - watch does the same symlink fixing, @@ -95,7 +96,7 @@ commitStaged = do - each other out, etc. Git returns nonzero on those, - so don't propigate out commit failures. -} void $ inRepo $ catchMaybeIO . - Git.Command.runQuiet "commit" params + Git.Command.runQuiet params return True where nomessage ps diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 0a1b15699..806441058 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -14,6 +14,7 @@ import Assistant.Common import Assistant.DaemonStatus import Assistant.Alert import qualified Git.LsFiles +import qualified Git.Command import Utility.ThreadScheduler import qualified Assistant.Threads.Watcher as Watcher import Utility.LogFile @@ -71,6 +72,7 @@ waitForNextCheck = do dailyCheck :: Assistant Bool dailyCheck = do g <- liftAnnex gitRepo + -- Find old unstaged symlinks, and add them to git. (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g now <- liftIO $ getPOSIXTime @@ -81,6 +83,11 @@ dailyCheck = do | isSymbolicLink s -> addsymlink file ms _ -> noop liftIO $ void cleanup + + {- Allow git-gc to run once per day. More frequent gc is avoided + - to avoid slowing things down. -} + void $ liftIO $ Git.Command.runBool [Param "gc", Param "--auto"] g + return True where toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) diff --git a/Command/Direct.hs b/Command/Direct.hs index d847a3270..1617bd9c2 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -30,8 +30,12 @@ perform :: CommandPerform perform = do showStart "commit" "" showOutput - _ <- inRepo $ Git.Command.runBool "commit" - [Param "-a", Param "-m", Param "commit before switching to direct mode"] + _ <- inRepo $ Git.Command.runBool + [ Param "commit" + , Param "-a" + , Param "-m" + , Param "commit before switching to direct mode" + ] showEndOk top <- fromRepo Git.repoPath diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 8bf228a80..6290e6756 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -43,8 +43,11 @@ perform = do showStart "commit" "" whenM (stageDirect) $ do showOutput - void $ inRepo $ Git.Command.runBool "commit" - [Param "-m", Param "commit before switching to indirect mode"] + void $ inRepo $ Git.Command.runBool + [ Param "commit" + , Param "-m" + , Param "commit before switching to indirect mode" + ] showEndOk -- Note that we set indirect mode early, so that we can use diff --git a/Command/Sync.hs b/Command/Sync.hs index cd0398ffa..39eda90f7 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -91,7 +91,7 @@ commit = next $ next $ do showOutput Annex.Branch.commit "update" -- Commit will fail when the tree is clean, so ignore failure. - _ <- inRepo $ Git.Command.runBool "commit" $ ps ++ + _ <- inRepo $ Git.Command.runBool $ (Param "commit") : ps ++ [Param "-m", Param "git-annex automatic sync"] return True @@ -117,8 +117,9 @@ updateBranch :: Git.Ref -> Git.Repo -> IO () updateBranch syncbranch g = unlessM go $ error $ "failed to update " ++ show syncbranch where - go = Git.Command.runBool "branch" - [ Param "-f" + go = Git.Command.runBool + [ Param "branch" + , Param "-f" , Param $ show $ Git.Ref.base syncbranch ] g @@ -130,8 +131,8 @@ pullRemote remote branch = do stopUnless fetch $ next $ mergeRemote remote (Just branch) where - fetch = inRepo $ Git.Command.runBool "fetch" - [Param $ Remote.name remote] + fetch = inRepo $ Git.Command.runBool + [Param "fetch", Param $ Remote.name remote] {- The remote probably has both a master and a synced/master branch. - Which to merge from? Well, the master has whatever latest changes @@ -162,8 +163,9 @@ pushRemote remote branch = go =<< needpush pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool pushBranch remote branch g = - Git.Command.runBool "push" - [ Param $ Remote.name remote + Git.Command.runBool + [ Param "push" + , Param $ Remote.name remote , Param $ refspec Annex.Branch.name , Param $ refspec branch ] g @@ -233,8 +235,11 @@ resolveMerge = do when merged $ do Annex.Queue.flush - void $ inRepo $ Git.Command.runBool "commit" - [Param "-m", Param "git-annex automatic merge conflict fix"] + void $ inRepo $ Git.Command.runBool + [ Param "commit" + , Param "-m" + , Param "git-annex automatic merge conflict fix" + ] return merged resolveMerge' :: LsFiles.Unmerged -> Annex Bool diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 0e691710a..d1f27e86a 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -34,7 +34,7 @@ cleanup :: FilePath -> Key -> CommandCleanup cleanup file key = do liftIO $ removeFile file -- git rm deletes empty directory without --cached - inRepo $ Git.Command.run "rm" [Params "--cached --quiet --", File file] + inRepo $ Git.Command.run [Params "rm --cached --quiet --", File file] -- If the file was already committed, it is now staged for removal. -- Commit that removal now, to avoid later confusing the @@ -42,10 +42,12 @@ cleanup file key = do -- git as a normal, non-annexed file. (s, clean) <- inRepo $ LsFiles.staged [file] when (not $ null s) $ do - inRepo $ Git.Command.run "commit" [ - Param "-q", - Params "-m", Param "content removed from git annex", - Param "--", File file] + inRepo $ Git.Command.run + [ Param "commit" + , Param "-q" + , Param "-m", Param "content removed from git annex" + , Param "--", File file + ] void $ liftIO clean ifM (Annex.getState Annex.fast) diff --git a/Command/Uninit.hs b/Command/Uninit.hs index beb17394d..2ba32a2a6 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -67,6 +67,6 @@ start = next $ next $ do liftIO $ removeDirectoryRecursive annexdir -- avoid normal shutdown saveState False - inRepo $ Git.Command.run "branch" - [Param "-D", Param $ show Annex.Branch.name] + inRepo $ Git.Command.run + [Param "branch", Param "-D", Param $ show Annex.Branch.name] liftIO exitSuccess @@ -23,13 +23,13 @@ getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def {- Changes a git config setting in both internal state and .git/config -} setConfig :: ConfigKey -> String -> Annex () setConfig (ConfigKey key) value = do - inRepo $ Git.Command.run "config" [Param key, Param value] + inRepo $ Git.Command.run [Param "config", Param key, Param value] Annex.changeGitRepo =<< inRepo Git.Config.reRead {- Unsets a git config setting. (Leaves it in state currently.) -} unsetConfig :: ConfigKey -> Annex () -unsetConfig (ConfigKey key) = inRepo $ Git.Command.run "config" - [Param "--unset", Param key] +unsetConfig (ConfigKey key) = inRepo $ Git.Command.run + [Param "config", Param "--unset", Param key] {- A per-remote config setting in git config. -} remoteConfig :: Git.Repo -> UnqualifiedConfigKey -> ConfigKey diff --git a/Git/Branch.hs b/Git/Branch.hs index 736c4c6e8..41ae2559e 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -73,8 +73,7 @@ fastForward branch (first:rest) repo = where no_ff = return False do_ff to = do - run "update-ref" - [Param $ show branch, Param $ show to] repo + run [Param "update-ref", Param $ show branch, Param $ show to] repo return True findbest c [] = return $ Just c findbest c (r:rs) @@ -97,7 +96,7 @@ commit message branch parentrefs repo = do sha <- getSha "commit-tree" $ pipeWriteRead (map Param $ ["commit-tree", show tree] ++ ps) message repo - run "update-ref" [Param $ show branch, Param $ show sha] repo + run [Param "update-ref", Param $ show branch, Param $ show sha] repo return sha where ps = concatMap (\r -> ["-p", show r]) parentrefs diff --git a/Git/Command.hs b/Git/Command.hs index af3ca1c4a..f3841c7fa 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -25,25 +25,25 @@ gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ p gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} -runBool :: String -> [CommandParam] -> Repo -> IO Bool -runBool subcommand params repo = assertLocal repo $ +runBool :: [CommandParam] -> Repo -> IO Bool +runBool params repo = assertLocal repo $ boolSystemEnv "git" - (gitCommandLine (Param subcommand : params) repo) + (gitCommandLine params repo) (gitEnv repo) {- Runs git in the specified repo, throwing an error if it fails. -} -run :: String -> [CommandParam] -> Repo -> IO () -run subcommand params repo = assertLocal repo $ - unlessM (runBool subcommand params repo) $ - error $ "git " ++ subcommand ++ " " ++ show params ++ " failed" +run :: [CommandParam] -> Repo -> IO () +run params repo = assertLocal repo $ + unlessM (runBool params repo) $ + error $ "git " ++ show params ++ " failed" {- Runs git and forces it to be quiet, throwing an error if it fails. -} -runQuiet :: String -> [CommandParam] -> Repo -> IO () -runQuiet subcommand params repo = withQuietOutput createProcessSuccess $ - (proc "git" $ toCommand $ gitCommandLine (Param subcommand : params) repo) +runQuiet :: [CommandParam] -> Repo -> IO () +runQuiet params repo = withQuietOutput createProcessSuccess $ + (proc "git" $ toCommand $ gitCommandLine (params) repo) { env = gitEnv repo } -{- Runs a git subcommand and returns its output, lazily. +{- Runs a git command and returns its output, lazily. - - Also returns an action that should be used when the output is all - read (or no more is needed), that will wait on the command, and @@ -58,7 +58,7 @@ pipeReadLazy params repo = assertLocal repo $ do where p = gitCreateProcess params repo -{- Runs a git subcommand, and returns its output, strictly. +{- Runs a git command, and returns its output, strictly. - - Nonzero exit status is ignored. -} @@ -72,7 +72,7 @@ pipeReadStrict params repo = assertLocal repo $ where p = gitCreateProcess params repo -{- Runs a git subcommand, feeding it input, and returning its output, +{- Runs a git command, feeding it input, and returning its output, - which is expected to be fairly small, since it's all read into memory - strictly. -} pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String @@ -80,7 +80,7 @@ pipeWriteRead params s repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) s (Just fileEncoding) -{- Runs a git subcommand, feeding it input on a handle with an action. -} +{- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO () pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ gitCreateProcess params repo diff --git a/Git/Merge.hs b/Git/Merge.hs index bad9f8258..e70a71d64 100644 --- a/Git/Merge.hs +++ b/Git/Merge.hs @@ -15,5 +15,7 @@ import Git.Version {- Avoids recent git's interactive merge. -} mergeNonInteractive :: Ref -> Repo -> IO Bool mergeNonInteractive branch - | older "1.7.7.6" = runBool "merge" [Param $ show branch] - | otherwise = runBool "merge" [Param "--no-edit", Param $ show branch] + | older "1.7.7.6" = merge [Param $ show branch] + | otherwise = merge [Param "--no-edit", Param $ show branch] + where + merge ps = runBool $ Param "merge" : ps diff --git a/Git/Ref.hs b/Git/Ref.hs index 3f7613726..26a1fc8bf 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -34,8 +34,8 @@ under dir r = Ref $ dir </> show (base r) {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool -exists ref = runBool "show-ref" - [Param "--verify", Param "-q", Param $ show ref] +exists ref = runBool + [Param "show-ref", Param "show-ref", Param "--verify", Param "-q", Param $ show ref] {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 2976ff086..f81751f82 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -204,8 +204,11 @@ storeBupUUID u buprepo = do r' <- Git.Config.read r let olduuid = Git.Config.get "annex.uuid" "" r' when (olduuid == "") $ - Git.Command.run "config" - [Param "annex.uuid", Param v] r' + Git.Command.run + [ Param "config" + , Param "annex.uuid" + , Param v + ] r' where v = fromUUID u diff --git a/Remote/Git.hs b/Remote/Git.hs index b1b6a2938..7f9f95e2a 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -141,10 +141,10 @@ tryGitConfigRead r {- Is this remote just not available, or does - it not have git-annex-shell? - Find out by trying to fetch from the remote. -} - whenM (inRepo $ Git.Command.runBool "fetch" [Param "--quiet", Param n]) $ do + whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do let k = "remote." ++ n ++ ".annex-ignore" warning $ "Remote " ++ n ++ " does not have git-annex installed; setting " ++ k - inRepo $ Git.Command.run "config" [Param k, Param "true"] + inRepo $ Git.Command.run [Param "config", Param k, Param "true"] return r _ -> return r | Git.repoIsHttp r = do diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index f25ee8ee0..7fc421f46 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -34,7 +34,7 @@ gitConfigSpecialRemote u c k v = do set ("annex-"++k) v set ("annex-uuid") (fromUUID u) where - set a b = inRepo $ Git.Command.run "config" - [Param (configsetting a), Param b] + set a b = inRepo $ Git.Command.run + [Param "config", Param (configsetting a), Param b] remotename = fromJust (M.lookup "name" c) configsetting s = "remote." ++ remotename ++ "." ++ s diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index beddc5b8b..935fc4825 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -54,7 +54,7 @@ upgrade = do showProgress when e $ do - inRepo $ Git.Command.run "rm" [Param "-r", Param "-f", Param "-q", File old] + inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File old] unless bare $ inRepo gitAttributesUnWrite showProgress @@ -105,8 +105,8 @@ push = do Annex.Branch.update -- just in case showAction "pushing new git-annex branch to origin" showOutput - inRepo $ Git.Command.run "push" - [Param "origin", Param $ show Annex.Branch.name] + inRepo $ Git.Command.run + [Param "push", Param "origin", Param $ show Annex.Branch.name] _ -> do -- no origin exists, so just let the user -- know about the new branch @@ -129,7 +129,7 @@ gitAttributesUnWrite repo = do c <- readFileStrict attributes liftIO $ viaTmp writeFile attributes $ unlines $ filter (`notElem` attrLines) $ lines c - Git.Command.run "add" [File attributes] repo + Git.Command.run [Param "add", File attributes] repo stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" diff --git a/debian/changelog b/debian/changelog index a437c6ebc..a9a0fc10a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -9,6 +9,9 @@ git-annex (4.20130228) UNRELEASED; urgency=low files in direct mode repositories. * assistant: Fix dropping content when a file is moved to an archive directory. + * assistant: Prevent automatic commits from causing git-gc runs, + as that can make things quite slow. Instead, git-gc --auto is run + once a day. (This can be disabled by the usual gc.auto=0 setting.) -- Joey Hess <joeyh@debian.org> Wed, 27 Feb 2013 23:20:40 -0400 |