git-annex-shell: Added lockcontent command, to prevent dropping of key's content.

CmdLine/GitAnnexShell.hs

@@ -20,6 +20,7 @@ import Remote.GCrypt (getGCryptUUID)
 
 import qualified Command.ConfigList
 import qualified Command.InAnnex
+import qualified Command.LockContent
 import qualified Command.DropKey
 import qualified Command.RecvKey
 import qualified Command.SendKey
@@ -32,6 +33,7 @@ cmds_readonly :: [Command]
 cmds_readonly =
 	[ Command.ConfigList.cmd
 	, gitAnnexShellCheck Command.InAnnex.cmd
+	, gitAnnexShellCheck Command.LockContent.cmd
 	, gitAnnexShellCheck Command.SendKey.cmd
 	, gitAnnexShellCheck Command.TransferInfo.cmd
 	, gitAnnexShellCheck Command.NotifyChanges.cmd

Command/LockContent.hs

@@ -0,0 +1,45 @@
+{- git-annex-shell command
+ -
+ - Copyright 2015 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.LockContent where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Types.Key
+
+cmd :: Command
+cmd = noCommit $ 
+	command "lockcontent" SectionPlumbing 
+		"locks key's content in the annex, preventing it being dropped"
+		paramKey
+		(withParams seek)
+
+seek :: CmdParams -> CommandSeek
+seek = withWords start
+
+-- First, lock the content. Then, make sure the content is actually
+-- present, and print out a "1". Wait for the caller to send a line before
+-- dropping the lock.
+start :: [String] -> CommandStart
+start [ks] = do
+	ok <- lockContentShared k locksuccess
+		`catchNonAsync` (const $ return False)
+	liftIO $ if ok
+		then exitSuccess
+		else exitFailure
+  where
+	k = fromMaybe (error "bad key") (file2key ks)
+	locksuccess = ifM (inAnnex k)
+		( liftIO $ do
+			putStrLn "OK"
+			hFlush stdout
+			_ <- getLine
+			return True
+		, return False
+		)
+start _ = error "Specify exactly 1 key."

debian/changelog

@@ -20,6 +20,8 @@ git-annex (5.20150931) UNRELEASED; urgency=medium
     and stop recommending bittornado | bittorrent.
   * Debian: Remove dependency on transformers library, as it is now
     included in ghc.
+  * git-annex-shell: Added lockcontent command, to prevent dropping of
+    key's content.
 
  -- Joey Hess <id@joeyh.name>  Thu, 01 Oct 2015 12:42:56 -0400
 

doc/git-annex-shell.mdwn

@@ -43,6 +43,17 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
   Exits 100 if it's unable to tell (perhaps the key is in the process of
   being removed from the annex).
 
+* lockcontent directory key
+
+  This locks a key's content in place in the annex, preventing it from
+  being dropped.
+
+  Once the content is successfully locked, outputs "OK". Then the content
+  remains locked until a newline is received from the caller or the
+  connection is broken.
+
+  Exits nonzero if the content is not present, or could not be locked.
+
 * dropkey directory [key ...]
 
   This drops the annexed data for the specified keys.