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.

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