refactor p2p remote action code

Make a Remote.Helper.P2P using code that was in Remote.P2P, converted to
use generic protocol runner actions.

This will allow it to be reused in Remote.Git.

This commit was sponsored by mo on Patreon.
This commit is contained in:
Joey Hess 2018-03-08 16:11:00 -04:00
parent c036a380b2
commit 16af259209
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 83 additions and 55 deletions

View file

@ -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

67
Remote/Helper/P2P.hs Normal file
View file

@ -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

View file

@ -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.

View file

@ -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