From 43efb9173bbf23d35106d980fc36c07c6c29a4e6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 16:55:41 -0400
Subject: implement lockContent for ssh remotes

---
 Remote/Git.hs        | 38 ++++++++++++++++++++++++++++++++++++--
 Remote/Helper/Ssh.hs |  5 +++++
 2 files changed, 41 insertions(+), 2 deletions(-)

(limited to 'Remote')

diff --git a/Remote/Git.hs b/Remote/Git.hs
index a6c4315ab..c2bd307ad 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -57,6 +57,7 @@ import Types.NumCopies
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
+import Control.Concurrent.Async
 import qualified Data.Map as M
 import Network.URI
 
@@ -370,8 +371,41 @@ lockKey r key callback
 			-- annex monad, not the remote's.
 			onLocal r $ Annex.Content.lockContentShared key $ 
 				liftIO . inorigrepo . callback
-	| Git.repoIsHttp (repo r) = cantlock
-	| otherwise = error "TODO"
+	| Git.repoIsSsh (repo r) = do
+		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"
+			[Param $ key2file key] []
+		(Just hin, Just hout, Nothing, p) <- liftIO $ createProcess $
+			 (proc cmd (toCommand params))
+				{ std_in = CreatePipe
+				, std_out = CreatePipe
+				}
+		-- Wait for either the process to exit, or for it to
+		-- indicate the content is locked.
+		v <- liftIO $ race 
+			(waitForProcess p)
+			(hGetLine hout)
+		let signaldone = void $ tryNonAsync $ liftIO $ do
+			hPutStrLn hout ""
+			hFlush hout
+			hClose hin
+			hClose hout
+			void $ waitForProcess p
+		let checkexited = not . isJust <$> getProcessExitCode p
+		case v of
+			Left _exited -> do
+				liftIO $ do
+					hClose hin
+					hClose hout
+				cantlock
+			Right l 
+				| l == Ssh.contentLockedMarker -> bracket_
+					noop
+					signaldone 
+					(withVerifiedCopy LockedCopy r checkexited callback)
+				| otherwise -> do
+					signaldone
+					cantlock
+	| otherwise = cantlock
   where
 	cantlock = error "can't lock content"
 
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 162c34f4e..0442ce839 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -173,3 +173,8 @@ rsyncParams r direction = do
 		| direction == Download = remoteAnnexRsyncDownloadOptions gc
 		| otherwise = remoteAnnexRsyncUploadOptions gc
 	gc = gitconfig r
+
+-- Used by git-annex-shell lockcontent to indicate the content is
+-- successfully locked.
+contentLockedMarker :: String
+contentLockedMarker = "OK"
-- 
cgit v1.2.3