refactor

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

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)

P2P/IO.hs

@@ -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

Remote/Helper/Tor.hs

@@ -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

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

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.

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