diff options
Diffstat (limited to 'Remote')
| -rw-r--r-- | Remote/Git.hs | 32 | ||||
| -rw-r--r-- | Remote/Helper/Ssh.hs | 15 |
2 files changed, 26 insertions, 21 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs index 328f64217..0edd04117 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -54,10 +54,11 @@ import Remote.Helper.Export import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt import qualified Remote.P2P -import P2P.Address +import qualified Remote.Helper.P2P as P2PHelper import qualified P2P.Protocol as P2P import qualified P2P.Annex as P2P import qualified P2P.IO as P2P +import P2P.Address import Annex.Path import Creds import Messages.Progress @@ -150,11 +151,12 @@ gen r u c gc | otherwise = case repoP2PAddress r of Nothing -> do duc <- mkDeferredUUIDCheck r u gc - go duc <$> remoteCost gc defcst + connpool <- Ssh.mkP2PSshConnectionPool + go duc connpool <$> remoteCost gc defcst Just addr -> Remote.P2P.chainGen addr r u c gc where defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost - go duc cst = Just new + go duc connpool cst = Just new where new = Remote { uuid = u @@ -163,7 +165,7 @@ gen r u c gc , storeKey = copyToRemote new duc , retrieveKeyFile = copyFromRemote new , retrieveKeyFileCheap = copyFromRemoteCheap new - , removeKey = dropKey new duc + , removeKey = dropKey new duc connpool , lockContent = Just (lockKey new duc) , checkPresent = inAnnex new duc , checkPresentCheap = repoCheap r @@ -368,8 +370,8 @@ keyUrls r key = map tourl locs' remoteconfig = gitconfig r cfg = remoteGitConfig remoteconfig -dropKey :: Remote -> DeferredUUIDCheck -> Key -> Annex Bool -dropKey r duc key +dropKey :: Remote -> DeferredUUIDCheck -> Ssh.P2PSshConnectionPool -> Key -> Annex Bool +dropKey r duc connpool key | not $ Git.repoIsUrl (repo r) = ifM duc ( guardUsable (repo r) (return False) $ commitOnCleanup r $ onLocalFast r $ do @@ -383,7 +385,9 @@ dropKey r duc key , return False ) | Git.repoIsHttp (repo r) = giveup "dropping from http remote not supported" - | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key + | otherwise = commitOnCleanup r $ do + let fallback = Ssh.dropKey (repo r) key + P2PHelper.remove (runProto r connpool fallback) key lockKey :: Remote -> DeferredUUIDCheck -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey r duc key callback @@ -758,12 +762,12 @@ mkDeferredUUIDCheck r u gc -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action. -runSsh :: Remote -> Ssh.P2PSshConnectionPool -> Annex a -> P2P.Proto a -> Annex a -runSsh r connpool fallback proto = - Ssh.getP2PSshConnection r connpool >>= maybe fallback go +runProto :: Remote -> Ssh.P2PSshConnectionPool -> Annex a -> P2P.Proto a -> Annex (Maybe a) +runProto r connpool fallback proto = Just <$> + (Ssh.getP2PSshConnection r connpool >>= maybe fallback go) where go c = do - (c', v) <- runSsh' proto c + (c', v) <- runProtoConn proto c case v of Just res -> do liftIO $ Ssh.storeP2PSshConnection connpool c' @@ -773,9 +777,9 @@ runSsh r connpool fallback proto = -- connection, and run the fallback. Nothing -> fallback -runSsh' :: P2P.Proto a -> Ssh.P2PSshConnection -> Annex (Ssh.P2PSshConnection, Maybe a) -runSsh' _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing) -runSsh' a conn@(P2P.OpenConnection (c, _pid)) = +runProtoConn :: P2P.Proto a -> Ssh.P2PSshConnection -> Annex (Ssh.P2PSshConnection, Maybe a) +runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing) +runProtoConn a conn@(P2P.OpenConnection (c, _pid)) = P2P.runFullProto P2P.Client c a >>= \case Right r -> return (conn, Just r) -- When runFullProto fails, the connection is no longer diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 96c419dd4..84a1ee8cc 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -26,7 +26,6 @@ import Config import qualified P2P.Protocol as P2P import qualified P2P.IO as P2P -import Control.Concurrent.Async import Control.Concurrent.STM toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam]) @@ -192,7 +191,7 @@ closeP2PSshConnection :: P2PSshConnection -> IO P2PSshConnection closeP2PSshConnection P2P.ClosedConnection = return P2P.ClosedConnection closeP2PSshConnection (P2P.OpenConnection (conn, pid)) = do P2P.closeConnection conn - void $ async $ waitForProcess pid + void $ waitForProcess pid return P2P.ClosedConnection -- Pool of connections over ssh to git-annex-shell p2pstdio. @@ -235,8 +234,10 @@ storeP2PSshConnection connpool conn = atomically $ modifyTVar' connpool $ \case -- If the remote does not support the P2P protocol, that's remembered in -- the connection pool. openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection) -openP2PSshConnection r connpool = - git_annex_shell ConsumeStdin (repo r) "p2pstdio" [] [] >>= \case +openP2PSshConnection r connpool = do + u <- getUUID + let ps = [Param (fromUUID u)] + git_annex_shell ConsumeStdin (repo r) "p2pstdio" ps [] >>= \case Nothing -> do liftIO $ rememberunsupported return Nothing @@ -254,11 +255,11 @@ openP2PSshConnection r connpool = let conn = P2P.P2PConnection { P2P.connRepo = repo r , P2P.connCheckAuth = const False - , P2P.connIhdl = from - , P2P.connOhdl = to + , P2P.connIhdl = to + , P2P.connOhdl = from } let c = P2P.OpenConnection (conn, pid) - -- When the connection is successful, the peer + -- When the connection is successful, the remote -- will send an AUTH_SUCCESS with its uuid. tryNonAsync (P2P.runNetProto conn $ P2P.postAuth) >>= \case Right (Right (Just theiruuid)) | theiruuid == uuid r -> |