do a cleanup commit after moving data from or to a git remote

Added Annex.cleanup, which is a general purpose interface for adding
actions to run at the end.

Remotes with the old git-annex-shell will commit every time, and have no
commit command, so hide stderr when running the commit command.

Annex.hs

@@ -21,6 +21,7 @@ module Annex (
 	setField,
 	getFlag,
 	getField,
+	addCleanup,
 	gitRepo,
 	inRepo,
 	fromRepo,
@@ -93,6 +94,7 @@ data AnnexState = AnnexState
 	, lockpool :: M.Map FilePath Fd
 	, flags :: M.Map String Bool
 	, fields :: M.Map String String
+	, cleanup :: M.Map String (Annex ())
 	}
 
 newState :: Git.Repo -> AnnexState
@@ -117,6 +119,7 @@ newState gitrepo = AnnexState
 	, lockpool = M.empty
 	, flags = M.empty
 	, fields = M.empty
+	, cleanup = M.empty
 	}
 
 {- Create and returns an Annex state object for the specified git repo. -}
@@ -132,12 +135,17 @@ eval s a = evalStateT (runAnnex a) s
 {- Sets a flag to True -}
 setFlag :: String -> Annex ()
 setFlag flag = changeState $ \s ->
-	s { flags = M.insert flag True $ flags s }
+	s { flags = M.insertWith' const flag True $ flags s }
 
 {- Sets a field to a value -}
 setField :: String -> String -> Annex ()
 setField field value = changeState $ \s ->
-	s { fields = M.insert field value $ fields s }
+	s { fields = M.insertWith' const field value $ fields s }
+
+{- Adds a cleanup action to perform. -}
+addCleanup :: String -> Annex () -> Annex ()
+addCleanup uid a = changeState $ \s ->
+	s { cleanup = M.insertWith' const uid a $ cleanup s }
 
 {- Checks if a flag was set. -}
 getFlag :: String -> Annex Bool

CmdLine.hs

@@ -12,6 +12,7 @@ module CmdLine (
 ) where
 
 import qualified Control.Exception as E
+import qualified Data.Map as M
 import Control.Exception (throw)
 import System.Console.GetOpt
 
@@ -95,6 +96,7 @@ startup = return True
 shutdown :: Bool -> Annex Bool
 shutdown oneshot = do
 	saveState oneshot
+	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
 	liftIO Git.Command.reap -- zombies from long-running git processes
 	sshCleanup -- ssh connection caching
 	return True

Remote/Git.hs

@@ -1,6 +1,6 @@
 {- Standard git remotes.
  -
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -24,6 +24,7 @@ import Logs.Presence
 import Annex.UUID
 import qualified Annex.Content
 import qualified Annex.BranchState
+import qualified Annex.Branch
 import qualified Utility.Url as Url
 import Utility.TempFile
 import Config
@@ -196,7 +197,7 @@ keyUrls r key = map tourl (annexLocations key)
 
 dropKey :: Git.Repo -> Key -> Annex Bool
 dropKey r key
-	| not $ Git.repoIsUrl r = liftIO $ onLocal r $ do
+	| not $ Git.repoIsUrl r = commitOnCleanup r $ liftIO $ onLocal r $ do
 		ensureInitialized
 		whenM (Annex.Content.inAnnex key) $ do
 			Annex.Content.lockContent key $
@@ -205,7 +206,7 @@ dropKey r key
 			Annex.Content.saveState True
 		return True
 	| Git.repoIsHttp r = error "dropping from http repo not supported"
-	| otherwise = onRemote r (boolSystem, False) "dropkey"
+	| otherwise = commitOnCleanup r $ onRemote r (boolSystem, False) "dropkey"
 		[ Params "--quiet --force"
 		, Param $ show key
 		]
@@ -236,7 +237,7 @@ copyFromRemoteCheap r key file
 {- Tries to copy a key's content to a remote's annex. -}
 copyToRemote :: Git.Repo -> Key -> Annex Bool
 copyToRemote r key
-	| not $ Git.repoIsUrl r = do
+	| not $ Git.repoIsUrl r = commitOnCleanup r $ do
 		keysrc <- inRepo $ gitAnnexLocation key
 		params <- rsyncParams r
 		-- run copy from perspective of remote
@@ -245,7 +246,7 @@ copyToRemote r key
 			Annex.Content.saveState True `after`
 				Annex.Content.getViaTmp key
 					(rsyncOrCopyFile params keysrc)
-	| Git.repoIsSsh r = do
+	| Git.repoIsSsh r = commitOnCleanup r $ do
 		keysrc <- inRepo $ gitAnnexLocation key
 		rsyncHelper =<< rsyncParamsRemote r False key keysrc
 	| otherwise = error "copying to non-ssh repo not supported"
@@ -301,3 +302,23 @@ rsyncParams r = do
 	where
  		-- --inplace to resume partial files
 		options = [Params "-p --progress --inplace"]
+
+commitOnCleanup :: Git.Repo -> Annex a -> Annex a
+commitOnCleanup r a = go `after` a
+	where
+		go = Annex.addCleanup (Git.repoLocation r) cleanup
+		cleanup
+			| not $ Git.repoIsUrl r = liftIO $ onLocal r $
+				Annex.Branch.commit "update"
+			| otherwise = do
+				Just (shellcmd, shellparams) <-
+					git_annex_shell r "commit" []
+				-- Throw away stderr, since the remote may not
+				-- have a new enough git-annex shell to
+				-- support committing.
+				let cmd = shellcmd ++ " "
+					++ unwords (map shellEscape $ toCommand shellparams)
+					++ ">/dev/null 2>/dev/null"
+				_ <- liftIO $
+					boolSystem "sh" [Param "-c", Param cmd]
+				return ()

debian/changelog

@@ -29,12 +29,8 @@ git-annex (3.20120124) UNRELEASED; urgency=low
   * Store web special remote url info in a more efficient location.
   * Deal with NFS problem that caused a failure to remove a directory
     when removing content from the annex.
-  * Avoid repeated location log commits when a remote is receiving files.
-    Done by adding a oneshot mode, in which location log changes are
-    written to the journal, but not committed. Taking advantage of
-    git-annex's existing ability to recover in this situation. This is
-    used by git-annex-shell and other places where changes are made to
-    a remote's location log.
+  * Make a single location log commit after a remote has received or
+    dropped files. Uses a new "git-annex-shell commit" command.
   * To avoid commits of data to the git-annex branch after each command
     is run, set annex.alwayscommit=false. Its data will then be committed
     less frequently, when a merge or sync is done.

doc/bugs/copy_doesn__39__t_scale.mdwn

@@ -33,3 +33,6 @@ are local. It seems to be just overhead.)
 Oneshot mode is now implemented, making git-annex-shell and other
 short lifetime processes not bother with committing changes.
 [[done]] --[[Joey]] 
+
+Update: Now it makes one commit at the very end of such a mass transfer.
+--[[Joey]]