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

1 files changed, 45 insertions, 0 deletions

diff --git a/Command/LockContent.hs b/Command/LockContent.hs
new file mode 100644
index 000000000..bab5c9276
--- /dev/null
+++ b/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."