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.

diff --git a/P2P/Annex.hs b/P2P/Annex.hs
new file mode 100644 (file)
index 0000000..ad4b458
--- /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 75b1a79230df856d397f8ce2f5bd68432a029382..3c715fbde113827104d3ab269d2c59b2aa67ed5a 100644 (file)
--- 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 6991d2a048cd4ab825dc921c1d468e60645b4c7d..f6d8c548230f005647c421ffd9dc99c042b89932 100644 (file)
--- 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