diff options
| -rw-r--r-- | Annex/Content.hs | 2 | ||||
| -rw-r--r-- | Command/LockContent.hs | 3 | ||||
| -rw-r--r-- | Remote/Git.hs | 38 | ||||
| -rw-r--r-- | Remote/Helper/Ssh.hs | 5 | ||||
| -rw-r--r-- | Types/NumCopies.hs | 14 |
5 files changed, 52 insertions, 10 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index 0dc47d9e2..0b15ce53b 100644 --- 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 e37d4cca5..72b2bb096 100644 --- 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 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" diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 60e0db580..8677e22b3 100644 --- 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 |