From 9d6ee2fe7fa1ec5511070a964ba35d9c9711e235 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 2 Dec 2016 13:50:56 -0400
Subject: make remote-daemon able to send and receive objects over tor

Each worker thread needs to run in the Annex monad, but the
remote-daemon's liftAnnex can only run 1 action at a time. Used
Annex.Concurrent to deal with that.

P2P.Annex is incomplete as of yet.
---
 P2P/Annex.hs                  | 36 ++++++++++++++++++++++++++++++++++++
 RemoteDaemon/Transport/Tor.hs | 30 +++++++++++++++++++-----------
 git-annex.cabal               |  1 +
 3 files changed, 56 insertions(+), 11 deletions(-)
 create mode 100644 P2P/Annex.hs

diff --git a/P2P/Annex.hs b/P2P/Annex.hs
new file mode 100644
index 000000000..ad4b458dd
--- /dev/null
+++ b/P2P/Annex.hs
@@ -0,0 +1,36 @@
+{- P2P protocol, Annex implementation
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE RankNTypes, FlexibleContexts #-}
+
+module P2P.Annex
+	( RunEnv(..)
+	, runFullProto
+	) where
+
+import Annex.Common
+import Annex.Content
+import P2P.Protocol
+import P2P.IO
+
+import Control.Monad.Free
+
+-- Full interpreter for Proto, that can receive and send objects.
+runFullProto :: RunEnv -> Proto a -> Annex (Maybe a)
+runFullProto runenv = go
+  where
+	go :: RunProto Annex
+	go (Pure v) = pure (Just v)
+	go (Free (Net n)) = runNet runenv go n
+	go (Free (Local l)) = runLocal runenv go l
+
+runLocal :: RunEnv -> RunProto Annex -> LocalF (Proto a) -> Annex (Maybe a)
+runLocal runenv runner f = case f of
+	TmpContentSize k next -> do
+		tmp <- fromRepo $ gitAnnexTmpObjectLocation k
+		size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp
+		runner (next (Len size))
diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs
index 75b1a7923..3c715fbde 100644
--- a/RemoteDaemon/Transport/Tor.hs
+++ b/RemoteDaemon/Transport/Tor.hs
@@ -8,6 +8,8 @@
 module RemoteDaemon.Transport.Tor (server) where
 
 import Common
+import qualified Annex
+import Annex.Concurrent
 import RemoteDaemon.Types
 import RemoteDaemon.Common
 import Utility.Tor
@@ -15,7 +17,7 @@ import Utility.FileMode
 import Utility.AuthToken
 import Remote.Helper.Tor
 import P2P.Protocol
-import P2P.IO
+import P2P.Annex
 import P2P.Auth
 import Annex.UUID
 import Types.UUID
@@ -75,14 +77,20 @@ serveClient th u r q = bracket setup cleanup go
 	cleanup = hClose
 	go h = do
 		debugM "remotedaemon" "serving a TOR connection"
-		-- Load auth tokens for every connection, to notice
-		-- when the allowed set is changed.
-		allowed <- liftAnnex th loadP2PAuthTokens
-		let runenv = RunEnv
-			{ runRepo = r
-			, runCheckAuth = (`isAllowedAuthToken` allowed)
-			, runIhdl = h
-			, runOhdl = h
-			}
-		void $ runNetProto runenv (serve u)
+		-- Avoid doing any work in the liftAnnex, since only one
+		-- can run at a time.
+		st <- liftAnnex th dupState
+		((), st') <- Annex.run st $ do
+			-- Load auth tokens for every connection, to notice
+			-- when the allowed set is changed.
+			allowed <- loadP2PAuthTokens
+			let runenv = RunEnv
+				{ runRepo = r
+				, runCheckAuth = (`isAllowedAuthToken` allowed)
+				, runIhdl = h
+				, runOhdl = h
+				}
+			void $ runFullProto runenv (serve u)
+		-- Merge the duplicated state back in.
+		liftAnnex th $ mergeState st'
 		debugM "remotedaemon" "done with TOR connection"
diff --git a/git-annex.cabal b/git-annex.cabal
index 6991d2a04..f6d8c5482 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -908,6 +908,7 @@ Executable git-annex
     Messages.JSON
     Messages.Progress
     P2P.Address
+    P2P.Annex
     P2P.Auth
     P2P.IO
     P2P.Protocol
-- 
cgit v1.2.3