implement lockContent for ssh remotes

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 0dc47d9e29c26f87a368482a1658b3492497d006..0b15ce53b1a525be51570be48ea528d5822c631e 100644 (file)
--- a/Annex/Content.hs
+++ b/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

diff --git a/Command/LockContent.hs b/Command/LockContent.hs
index e37d4cca51b548d0656f439a3dbbb6fed239494c..72b2bb096e9b0bd9ed389acd1ddd2f02b6c92761 100644 (file)
--- a/Command/LockContent.hs
+++ b/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

diff --git a/Remote/Git.hs b/Remote/Git.hs
index a6c4315ab4cc73b913374e971af7d47a1023611b..c2bd307ada9194f20defa53bbc1908f50dc86d49 100644 (file)
--- 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 162c34f4eb717e39e40ccebe0025415d558c0603..0442ce8398986ae83ffd87beaa8aa4af6b1b12a9 100644 (file)
--- 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"

diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs
index 60e0db58098b83e0246afd3f6ba843b005da0020..8677e22b3b0fb13cc10d18a3628641de21ab555f 100644 (file)
--- a/Types/NumCopies.hs
+++ b/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