diff options
| -rw-r--r-- | Remote/Git.hs | 4 | ||||
| -rw-r--r-- | Remote/Helper/P2P.hs | 67 | ||||
| -rw-r--r-- | Remote/P2P.hs | 66 | ||||
| -rw-r--r-- | git-annex.cabal | 1 |
4 files changed, 83 insertions, 55 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs index 63cfdeae9..328f64217 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -758,8 +758,8 @@ mkDeferredUUIDCheck r u gc -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action. -runSsh :: Remote -> Ssh.P2PSshConnectionPool -> P2P.Proto a -> Annex a -> Annex a -runSsh r connpool proto fallback = +runSsh :: Remote -> Ssh.P2PSshConnectionPool -> Annex a -> P2P.Proto a -> Annex a +runSsh r connpool fallback proto = Ssh.getP2PSshConnection r connpool >>= maybe fallback go where go c = do diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs new file mode 100644 index 000000000..272489755 --- /dev/null +++ b/Remote/Helper/P2P.hs @@ -0,0 +1,67 @@ +{- Helpers for remotes using the git-annex P2P protocol. + - + - Copyright 2016-2018 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes #-} + +module Remote.Helper.P2P where + +import Annex.Common +import qualified P2P.Protocol as P2P +import P2P.IO +import Types.Remote +import Annex.Content +import Config.Cost +import Messages.Progress +import Utility.Metered +import Types.NumCopies + +import Control.Concurrent + +-- Runs a Proto action using a connection it sets up. +type ProtoRunner a = P2P.Proto a -> Annex (Maybe a) + +-- Runs a Proto action using a ClosableConnection. +type ProtoConnRunner c = forall a. P2P.Proto a -> ClosableConnection c -> Annex (ClosableConnection c, Maybe a) + +-- Runs an Annex action with a connection from the pool, adding it back to +-- the pool when done. +type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a + +store :: ProtoRunner Bool -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool +store runner k af p = do + let getsrcfile = fmap fst <$> prepSendAnnex k + metered (Just p) k getsrcfile $ \p' -> + fromMaybe False + <$> runner (P2P.put k af p') + +retrieve :: ProtoRunner Bool -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +retrieve runner k af dest p = unVerified $ + metered (Just p) k (return Nothing) $ \p' -> fromMaybe False + <$> runner (P2P.get dest k af p') + +remove :: ProtoRunner Bool -> Key -> Annex Bool +remove runner k = fromMaybe False <$> runner (P2P.remove k) + +checkpresent :: ProtoRunner Bool -> Key -> Annex Bool +checkpresent runner k = maybe unavail return =<< runner (P2P.checkPresent k) + where + unavail = giveup "can't connect to remote" + +lock :: WithConn a c -> ProtoConnRunner c -> UUID -> Key -> (VerifiedCopy -> Annex a) -> Annex a +lock withconn connrunner u k callback = withconn $ \conn -> do + connv <- liftIO $ newMVar conn + let runproto d p = do + c <- liftIO $ takeMVar connv + (c', mr) <- connrunner p c + liftIO $ putMVar connv c' + return (fromMaybe d mr) + r <- P2P.lockContentWhile runproto k go + conn' <- liftIO $ takeMVar connv + return (conn', r) + where + go False = giveup "can't lock content" + go True = withVerifiedCopy LockedCopy u (return True) callback diff --git a/Remote/P2P.hs b/Remote/P2P.hs index cfed5c604..95c7f6ede 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -1,6 +1,6 @@ {- git remotes using the git-annex P2P protocol - - - Copyright 2016 Joey Hess <id@joeyh.name> + - Copyright 2016-2018 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,17 +21,13 @@ import Types.Remote import Types.GitConfig import qualified Git import Annex.UUID -import Annex.Content import Config import Config.Cost import Remote.Helper.Git import Remote.Helper.Export -import Messages.Progress -import Utility.Metered +import Remote.Helper.P2P import Utility.AuthToken -import Types.NumCopies -import Control.Concurrent import Control.Concurrent.STM remote :: RemoteType @@ -49,16 +45,18 @@ chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> chainGen addr r u c gc = do connpool <- mkConnectionPool cst <- remoteCost gc veryExpensiveRemoteCost + let protorunner = runProto u addr connpool + let withconn = withConnection u addr connpool let this = Remote { uuid = u , cost = cst , name = Git.repoDescribe r - , storeKey = store u addr connpool - , retrieveKeyFile = retrieve u addr connpool + , storeKey = store protorunner + , retrieveKeyFile = retrieve protorunner , retrieveKeyFileCheap = \_ _ _ -> return False - , removeKey = remove u addr connpool - , lockContent = Just (lock u addr connpool) - , checkPresent = checkpresent u addr connpool + , removeKey = remove protorunner + , lockContent = Just $ lock withconn runProtoConn u + , checkPresent = checkpresent protorunner , checkPresentCheap = False , exportActions = exportUnsupported , whereisKey = Nothing @@ -78,44 +76,6 @@ chainGen addr r u c gc = do } return (Just this) -store :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool -store u addr connpool k af p = do - let getsrcfile = fmap fst <$> prepSendAnnex k - metered (Just p) k getsrcfile $ \p' -> - fromMaybe False - <$> runProto u addr connpool (P2P.put k af p') - -retrieve :: UUID -> P2PAddress -> ConnectionPool -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) -retrieve u addr connpool k af dest p = unVerified $ - metered (Just p) k (return Nothing) $ \p' -> fromMaybe False - <$> runProto u addr connpool (P2P.get dest k af p') - -remove :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool -remove u addr connpool k = fromMaybe False - <$> runProto u addr connpool (P2P.remove k) - -checkpresent :: UUID -> P2PAddress -> ConnectionPool -> Key -> Annex Bool -checkpresent u addr connpool k = maybe unavail return - =<< runProto u addr connpool (P2P.checkPresent k) - where - unavail = giveup "can't connect to peer" - -lock :: UUID -> P2PAddress -> ConnectionPool -> Key -> (VerifiedCopy -> Annex r) -> Annex r -lock u addr connpool k callback = - withConnection u addr connpool $ \conn -> do - connv <- liftIO $ newMVar conn - let runproto d p = do - c <- liftIO $ takeMVar connv - (c', mr) <- runProto' p c - liftIO $ putMVar connv c' - return (fromMaybe d mr) - r <- P2P.lockContentWhile runproto k go - conn' <- liftIO $ takeMVar connv - return (conn', r) - where - go False = giveup "can't lock content" - go True = withVerifiedCopy LockedCopy u (return True) callback - -- | A connection to the peer, which can be closed. type Connection = ClosableConnection P2PConnection @@ -126,11 +86,11 @@ mkConnectionPool = liftIO $ newTVarIO [] -- Runs the Proto action. runProto :: UUID -> P2PAddress -> ConnectionPool -> P2P.Proto a -> Annex (Maybe a) -runProto u addr connpool a = withConnection u addr connpool (runProto' a) +runProto u addr connpool a = withConnection u addr connpool (runProtoConn a) -runProto' :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a) -runProto' _ ClosedConnection = return (ClosedConnection, Nothing) -runProto' a (OpenConnection conn) = do +runProtoConn :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a) +runProtoConn _ ClosedConnection = return (ClosedConnection, Nothing) +runProtoConn a (OpenConnection conn) = do v <- runFullProto Client conn a -- When runFullProto fails, the connection is no longer usable, -- so close it. diff --git a/git-annex.cabal b/git-annex.cabal index 6a8aa490a..f577c583a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -931,6 +931,7 @@ Executable git-annex Remote.Helper.Hooks Remote.Helper.Http Remote.Helper.Messages + Remote.Helper.P2P Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh |