diff options
| -rw-r--r-- | P2P/Annex.hs | 36 | ||||
| -rw-r--r-- | RemoteDaemon/Transport/Tor.hs | 30 | ||||
| -rw-r--r-- | git-annex.cabal | 1 |
3 files changed, 56 insertions, 11 deletions
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 |