From 64dfd213e46f983d5cb504b446597e87f71440de Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 8 Oct 2015 14:47:46 -0400
Subject: git-annex-shell: Added lockcontent command, to prevent dropping of
 key's content.

---
 Command/LockContent.hs | 45 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 45 insertions(+)
 create mode 100644 Command/LockContent.hs

(limited to 'Command')

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."
-- 
cgit v1.2.3