diff options
Diffstat (limited to 'Remote/Git.hs')
| -rw-r--r-- | Remote/Git.hs | 57 |
1 files changed, 47 insertions, 10 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs index caa677464..0edd04117 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -54,6 +54,10 @@ import Remote.Helper.Export import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt import qualified Remote.P2P +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 @@ -147,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 @@ -160,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 @@ -365,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 @@ -380,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 @@ -729,10 +736,11 @@ mkCopier remotewanthardlink rsyncparams = do , return copier ) -{- Normally the UUID is checked at startup, but annex-checkuuid config - - can prevent that. To avoid getting confused, a deferred - - check is done just before the repository is used. This returns False - - when the repository UUID is not as expected. -} +{- Normally the UUID of a local repository is checked at startup, + - but annex-checkuuid config can prevent that. To avoid getting + - confused, a deferred check is done just before the repository + - is used. + - This returns False when the repository UUID is not as expected. -} type DeferredUUIDCheck = Annex Bool mkDeferredUUIDCheck :: Git.Repo -> UUID -> RemoteGitConfig -> Annex DeferredUUIDCheck @@ -751,3 +759,32 @@ mkDeferredUUIDCheck r u gc return ok , liftIO $ readMVar v ) + +-- Runs a P2P Proto action on a remote when it supports that, +-- otherwise the fallback action. +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) <- runProtoConn proto c + case v of + Just res -> do + liftIO $ Ssh.storeP2PSshConnection connpool c' + return res + -- Running the proto failed, either due to a protocol + -- error or a network error, so discard the + -- connection, and run the fallback. + Nothing -> fallback + +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 + -- usable, so close it. + Left e -> do + warning $ "Lost connection (" ++ e ++ ")" + conn' <- liftIO $ Ssh.closeP2PSshConnection conn + return (conn', Nothing) |