implement lockContent for ssh remotes

Annex/Content.hs

@@ -184,7 +184,7 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key)
 lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a
 lockContentShared key a = lockContentUsing lock key $ do
 	u <- getUUID
-	withVerifiedCopy LockedCopy u a
+	withVerifiedCopy LockedCopy u (return True) a
   where
 #ifndef mingw32_HOST_OS
 	lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile

Command/LockContent.hs

@@ -11,6 +11,7 @@ import Common.Annex
 import Command
 import Annex.Content
 import Types.Key
+import Remote.Helper.Ssh (contentLockedMarker)
 
 cmd :: Command
 cmd = noCommit $ 
@@ -36,7 +37,7 @@ start [ks] = do
 	k = fromMaybe (error "bad key") (file2key ks)
 	locksuccess = ifM (inAnnex k)
 		( liftIO $ do
-			putStrLn "OK"
+			putStrLn contentLockedMarker
 			hFlush stdout
 			_ <- getLine
 			return True

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"
 

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"

Types/NumCopies.hs

@@ -25,6 +25,7 @@ module Types.NumCopies (
 import Types.UUID
 import Types.Key
 import Utility.Exception (bracketIO)
+import Utility.Monad
 
 import qualified Data.Map as M
 import Control.Concurrent.MVar
@@ -98,14 +99,14 @@ deDupVerifiedCopies l = M.elems $
 mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy
 mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ())
 
-invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO VerifiedCopy
-invalidatableVerifiedCopy mk u = do
+invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO Bool -> IO VerifiedCopy
+invalidatableVerifiedCopy mk u check = do
 	v <- newEmptyMVar
 	let invalidate = do
 		_ <- tryPutMVar v ()
 		return ()
-	let check = isEmptyMVar v
-	return $ mk $ V (toUUID u) check invalidate
+	let check' = isEmptyMVar v <&&> check
+	return $ mk $ V (toUUID u) check' invalidate
 
 -- Constructs a VerifiedCopy, and runs the action, ensuring that the
 -- verified copy is invalidated when the action returns, or on error.
@@ -113,11 +114,12 @@ withVerifiedCopy
 	:: (Monad m, MonadMask m, MonadIO m, ToUUID u)
 	=> (V -> VerifiedCopy)
 	-> u
+	-> IO Bool
 	-> (VerifiedCopy -> m a)
 	-> m a
-withVerifiedCopy mk u = bracketIO setup cleanup
+withVerifiedCopy mk u check = bracketIO setup cleanup
   where
-	setup = invalidatableVerifiedCopy mk u
+	setup = invalidatableVerifiedCopy mk u check
 	cleanup = invalidateVerifiedCopy
 
 {- Check whether enough verification has been done of copies to allow