1 files changed, 67 insertions, 0 deletions
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