diff options
| -rw-r--r-- | CmdLine/GitRemoteTorAnnex.hs | 11 | ||||
| -rw-r--r-- | P2P/Annex.hs | 8 | ||||
| -rw-r--r-- | P2P/IO.hs | 73 | ||||
| -rw-r--r-- | Remote/Helper/Tor.hs | 20 | ||||
| -rw-r--r-- | Remote/P2P.hs | 30 | ||||
| -rw-r--r-- | RemoteDaemon/Transport/Tor.hs | 17 | ||||
| -rw-r--r-- | git-annex.cabal | 1 |
7 files changed, 74 insertions, 86 deletions
diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index 517ce7c82..c4bf26c85 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -12,7 +12,6 @@ import qualified Annex import qualified Git.CurrentRepo import P2P.Protocol import P2P.IO -import Remote.Helper.Tor import Utility.Tor import Utility.AuthToken import Annex.UUID @@ -59,14 +58,8 @@ connectService address port service = do <$> loadP2PRemoteAuthToken (TorAnnex address port) myuuid <- getUUID g <- Annex.gitRepo - h <- liftIO $ torHandle =<< connectHiddenService address port - let runenv = RunEnv - { runRepo = g - , runCheckAuth = const False - , runIhdl = h - , runOhdl = h - } - liftIO $ runNetProto runenv $ do + conn <- liftIO $ connectPeer g (TorAnnex address port) + liftIO $ runNetProto conn $ do v <- auth myuuid authtoken case v of Just _theiruuid -> connect service stdin stdout diff --git a/P2P/Annex.hs b/P2P/Annex.hs index d0c00def3..4105abe32 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -9,7 +9,7 @@ module P2P.Annex ( RunMode(..) - , RunEnv(..) + , P2PConnection(..) , runFullProto ) where @@ -31,12 +31,12 @@ data RunMode | Client -- Full interpreter for Proto, that can receive and send objects. -runFullProto :: RunMode -> RunEnv -> Proto a -> Annex (Maybe a) -runFullProto runmode runenv = go +runFullProto :: RunMode -> P2PConnection -> Proto a -> Annex (Maybe a) +runFullProto runmode conn = go where go :: RunProto Annex go (Pure v) = pure (Just v) - go (Free (Net n)) = runNet runenv go n + go (Free (Net n)) = runNet conn go n go (Free (Local l)) = runLocal runmode go l runLocal :: RunMode -> RunProto Annex -> LocalF (Proto a) -> Annex (Maybe a) @@ -9,12 +9,15 @@ module P2P.IO ( RunProto - , RunEnv(..) + , P2PConnection(..) + , connectPeer + , setupHandle , runNetProto , runNet ) where import P2P.Protocol +import P2P.Address import Utility.Process import Git import Git.Command @@ -22,11 +25,14 @@ import Utility.AuthToken import Utility.SafeCommand import Utility.SimpleProtocol import Utility.Exception +import Utility.Tor +import Utility.FileSystemEncoding import Control.Monad import Control.Monad.Free import Control.Monad.IO.Class import System.Exit (ExitCode(..)) +import Network.Socket import System.IO import Control.Concurrent import Control.Concurrent.Async @@ -36,41 +42,60 @@ import qualified Data.ByteString.Lazy as L -- Type of interpreters of the Proto free monad. type RunProto m = forall a. (MonadIO m, MonadMask m) => Proto a -> m (Maybe a) -data RunEnv = RunEnv - { runRepo :: Repo - , runCheckAuth :: (AuthToken -> Bool) - , runIhdl :: Handle - , runOhdl :: Handle +data P2PConnection = P2PConnection + { connRepo :: Repo + , connCheckAuth :: (AuthToken -> Bool) + , connIhdl :: Handle + , connOhdl :: Handle } +-- Opens a connection to a peer. Does not authenticate with it. +connectPeer :: Git.Repo -> P2PAddress -> IO P2PConnection +connectPeer g (TorAnnex onionaddress onionport) = do + h <- setupHandle =<< connectHiddenService onionaddress onionport + return $ P2PConnection + { connRepo = g + , connCheckAuth = const False + , connIhdl = h + , connOhdl = h + } + +setupHandle :: Socket -> IO Handle +setupHandle s = do + h <- socketToHandle s ReadWriteMode + hSetBuffering h LineBuffering + hSetBinaryMode h False + fileEncoding h + return h + -- Purposefully incomplete interpreter of Proto. -- -- This only runs Net actions. No Local actions will be run -- (those need the Annex monad) -- if the interpreter reaches any, -- it returns Nothing. -runNetProto :: RunEnv -> Proto a -> IO (Maybe a) -runNetProto runenv = go +runNetProto :: P2PConnection -> Proto a -> IO (Maybe a) +runNetProto conn = go where go :: RunProto IO go (Pure v) = pure (Just v) - go (Free (Net n)) = runNet runenv go n + go (Free (Net n)) = runNet conn go n go (Free (Local _)) = return Nothing -- Interpreter of the Net part of Proto. -- -- An interpreter of Proto has to be provided, to handle the rest of Proto -- actions. -runNet :: (MonadIO m, MonadMask m) => RunEnv -> RunProto m -> NetF (Proto a) -> m (Maybe a) -runNet runenv runner f = case f of +runNet :: (MonadIO m, MonadMask m) => P2PConnection -> RunProto m -> NetF (Proto a) -> m (Maybe a) +runNet conn runner f = case f of SendMessage m next -> do v <- liftIO $ tryNonAsync $ do - hPutStrLn (runOhdl runenv) (unwords (formatMessage m)) - hFlush (runOhdl runenv) + hPutStrLn (connOhdl conn) (unwords (formatMessage m)) + hFlush (connOhdl conn) case v of Left _e -> return Nothing Right () -> runner next ReceiveMessage next -> do - v <- liftIO $ tryNonAsync $ hGetLine (runIhdl runenv) + v <- liftIO $ tryNonAsync $ hGetLine (connIhdl conn) case v of Left _e -> return Nothing Right l -> case parseMessage l of @@ -81,19 +106,19 @@ runNet runenv runner f = case f of next e SendBytes len b next -> do v <- liftIO $ tryNonAsync $ do - ok <- sendExactly len b (runOhdl runenv) - hFlush (runOhdl runenv) + ok <- sendExactly len b (connOhdl conn) + hFlush (connOhdl conn) return ok case v of Right True -> runner next _ -> return Nothing ReceiveBytes (Len n) next -> do - v <- liftIO $ tryNonAsync $ L.hGet (runIhdl runenv) (fromIntegral n) + v <- liftIO $ tryNonAsync $ L.hGet (connIhdl conn) (fromIntegral n) case v of Left _e -> return Nothing Right b -> runner (next b) CheckAuthToken _u t next -> do - let authed = runCheckAuth runenv t + let authed = connCheckAuth conn t runner (next authed) Relay hin hout next -> do v <- liftIO $ runRelay runnerio hin hout @@ -101,7 +126,7 @@ runNet runenv runner f = case f of Nothing -> return Nothing Just exitcode -> runner (next exitcode) RelayService service next -> do - v <- liftIO $ runRelayService runenv runnerio service + v <- liftIO $ runRelayService conn runnerio service case v of Nothing -> return Nothing Just () -> runner next @@ -109,7 +134,7 @@ runNet runenv runner f = case f of -- This is only used for running Net actions when relaying, -- so it's ok to use runNetProto, despite it not supporting -- all Proto actions. - runnerio = runNetProto runenv + runnerio = runNetProto conn -- Send exactly the specified number of bytes or returns False. -- @@ -150,8 +175,8 @@ runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go go v = relayHelper runner v hin -runRelayService :: RunEnv -> RunProto IO -> Service -> IO (Maybe ()) -runRelayService runenv runner service = bracket setup cleanup go +runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Maybe ()) +runRelayService conn runner service = bracket setup cleanup go where cmd = case service of UploadPack -> "upload-pack" @@ -159,8 +184,8 @@ runRelayService runenv runner service = bracket setup cleanup go serviceproc = gitCreateProcess [ Param cmd - , File (repoPath (runRepo runenv)) - ] (runRepo runenv) + , File (repoPath (connRepo conn)) + ] (connRepo conn) setup = do (Just hin, Just hout, _, pid) <- createProcess serviceproc diff --git a/Remote/Helper/Tor.hs b/Remote/Helper/Tor.hs deleted file mode 100644 index b5a819c3b..000000000 --- a/Remote/Helper/Tor.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- Helpers for tor remotes. - - - - Copyright 2016 Joey Hess <id@joeyh.name> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Remote.Helper.Tor where - -import Annex.Common - -import Network.Socket - -torHandle :: Socket -> IO Handle -torHandle s = do - h <- socketToHandle s ReadWriteMode - hSetBuffering h LineBuffering - hSetBinaryMode h False - fileEncoding h - return h diff --git a/Remote/P2P.hs b/Remote/P2P.hs index f97d76e71..0c7ca0574 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -15,14 +15,13 @@ import qualified Annex import qualified P2P.Protocol as P2P import P2P.Address import P2P.Annex +import P2P.IO import Types.Remote import Types.GitConfig import qualified Git import Config import Config.Cost import Remote.Helper.Git -import Remote.Helper.Tor -import Utility.Tor import Utility.Metered import Types.NumCopies @@ -108,7 +107,7 @@ lock theiruuid addr connpool k callback = -- | A connection to the peer. data Connection - = TorAnnexConnection RunEnv + = OpenConnection P2PConnection | ClosedConnection type ConnectionPool = TVar [Connection] @@ -122,14 +121,15 @@ runProto addr connpool a = withConnection addr connpool (runProto' a) runProto' :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a) runProto' _ ClosedConnection = return (ClosedConnection, Nothing) -runProto' a conn@(TorAnnexConnection runenv) = do - r <- runFullProto Client runenv a +runProto' a (OpenConnection conn) = do + r <- runFullProto Client conn a -- When runFullProto fails, the connection is no longer usable, -- so close it. if isJust r - then return (conn, r) + then return (OpenConnection conn, r) else do - liftIO $ hClose (runIhdl runenv) + liftIO $ hClose (connIhdl conn) + liftIO $ hClose (connOhdl conn) return (ClosedConnection, r) -- Uses an open connection if one is available in the ConnectionPool; @@ -161,17 +161,9 @@ withConnection addr connpool a = bracketOnError get cache go return r openConnection :: P2PAddress -> Annex Connection -openConnection (TorAnnex onionaddress onionport) = do - v <- liftIO $ tryNonAsync $ - torHandle =<< connectHiddenService onionaddress onionport +openConnection addr = do + g <- Annex.gitRepo + v <- liftIO $ tryNonAsync $ connectPeer g addr case v of - Right h -> do - g <- Annex.gitRepo - let runenv = RunEnv - { runRepo = g - , runCheckAuth = const False - , runIhdl = h - , runOhdl = h - } - return (TorAnnexConnection runenv) + Right conn -> return (OpenConnection conn) Left _e -> return ClosedConnection diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 2caa7cdb1..e5d4e97ad 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -15,7 +15,6 @@ import RemoteDaemon.Common import Utility.Tor import Utility.FileMode import Utility.AuthToken -import Remote.Helper.Tor import P2P.Protocol import P2P.IO import P2P.Annex @@ -55,7 +54,7 @@ server th@(TransportHandle (LocalRepo r) _) = do debugM "remotedaemon" "tor hidden service running" forever $ do (conn, _) <- accept soc - h <- torHandle conn + h <- setupHandle conn ok <- atomically $ ifM (isFullTBQueue q) ( return False , do @@ -85,16 +84,16 @@ serveClient th u r q = bracket setup cleanup go -- 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 + let conn = P2PConnection + { connRepo = r + , connCheckAuth = (`isAllowedAuthToken` allowed) + , connIhdl = h + , connOhdl = h } - v <- liftIO $ runNetProto runenv $ serveAuth u + v <- liftIO $ runNetProto conn $ serveAuth u case v of Just (Just theiruuid) -> void $ - runFullProto (Serving theiruuid) runenv $ + runFullProto (Serving theiruuid) conn $ serveAuthed u _ -> return () -- Merge the duplicated state back in. diff --git a/git-annex.cabal b/git-annex.cabal index 7fcba0623..c894e6610 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -934,7 +934,6 @@ Executable git-annex Remote.Helper.ReadOnly Remote.Helper.Special Remote.Helper.Ssh - Remote.Helper.Tor Remote.Hook Remote.List Remote.P2P |