summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2015-10-09 16:55:41 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2015-10-09 16:55:41 -0400
commit43efb9173bbf23d35106d980fc36c07c6c29a4e6 (patch)
treedbbcfbaf7df02f0679753b85072c993ba5c6459e /Remote
parent8bb2283a50771025b5a9a729f4e832211e4990ee (diff)
implement lockContent for ssh remotes
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Git.hs38
-rw-r--r--Remote/Helper/Ssh.hs5
2 files changed, 41 insertions, 2 deletions
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"