remotedaemon: serve tor hidden service

CHANGELOG

@@ -1,5 +1,7 @@
 git-annex (6.20161119) UNRELEASED; urgency=medium
 
+  * enable-tor: New command, enables tor hidden service for P2P syncing.
+  * remotedaemon: Serve tor hidden service.
   * remotedaemon: Fork to background by default. Added --foreground switch
     to enable old behavior.
 

Command/RemoteDaemon.hs

@@ -14,7 +14,7 @@ import RemoteDaemon.Core
 import Utility.Daemon
 
 cmd :: Command
-cmd = noCommit $ dontCheck repoExists $
+cmd = noCommit $
 	command "remotedaemon" SectionMaintenance
 		"persistent communication with remotes"
 		paramNothing (run <$$> const parseDaemonOptions)

Remote/Helper/P2P/IO.hs

@@ -9,7 +9,7 @@
 
 module Remote.Helper.P2P.IO
 	( RunProto
-	, runProtoHandle
+	, runNetProtoHandle
 	) where
 
 import Remote.Helper.P2P
@@ -38,8 +38,8 @@ data S = S
 
 -- Implementation of the protocol, communicating with a peer
 -- over a Handle. No Local actions will be run.
-runProtoHandle :: MonadIO m => Handle -> Repo -> Proto a -> m a
+runNetProtoHandle :: MonadIO m => Handle -> Repo -> Proto a -> m a
-runProtoHandle h r = go
+runNetProtoHandle h r = go
   where
 	go :: RunProto
 	go (Pure a) = pure a

RemoteDaemon/Core.hs

@@ -45,7 +45,9 @@ runInteractive = do
 	let controller = runController ichan ochan
 	
 	-- If any thread fails, the rest will be killed.
-	void $ tryIO $ reader `concurrently` writer `concurrently` controller
+	void $ tryIO $ reader
+		`concurrently` writer
+		`concurrently` controller
 
 runNonInteractive :: IO ()
 runNonInteractive = do
@@ -59,7 +61,9 @@ runNonInteractive = do
 		void $ atomically $ readTChan ochan
 	let controller = runController ichan ochan
 	
-	void $ tryIO $ reader `concurrently` writer `concurrently` controller
+	void $ tryIO $ reader
+		`concurrently` writer
+		`concurrently` controller
 
 type RemoteMap = M.Map Git.Repo (IO (), TChan Consumed)
 
@@ -70,6 +74,7 @@ runController ichan ochan = do
 	h <- genTransportHandle
 	m <- genRemoteMap h ochan
 	startrunning m
+	mapM_ (\s -> async (s h)) remoteServers
 	go h False m
   where
 	go h paused m = do

RemoteDaemon/Transport.hs

@@ -10,6 +10,7 @@ module RemoteDaemon.Transport where
 import RemoteDaemon.Types
 import qualified RemoteDaemon.Transport.Ssh
 import qualified RemoteDaemon.Transport.GCrypt
+import qualified RemoteDaemon.Transport.Tor
 import qualified Git.GCrypt
 
 import qualified Data.Map as M
@@ -22,3 +23,6 @@ remoteTransports = M.fromList
 	[ ("ssh:", RemoteDaemon.Transport.Ssh.transport)
 	, (Git.GCrypt.urlScheme, RemoteDaemon.Transport.GCrypt.transport)
 	]
+
+remoteServers :: [TransportHandle -> IO ()]
+remoteServers = [RemoteDaemon.Transport.Tor.server]

RemoteDaemon/Transport/Tor.hs

@@ -0,0 +1,51 @@
+{- git-remote-daemon, tor hidden service transport
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module RemoteDaemon.Transport.Tor (server) where
+
+import Common
+import RemoteDaemon.Types
+import RemoteDaemon.Common
+import Utility.Tor
+import Utility.FileMode
+import Remote.Helper.P2P
+import Remote.Helper.P2P.IO
+import Annex.UUID
+import Types.UUID
+
+import System.PosixCompat.User
+import Network.Socket
+import Control.Concurrent
+import System.Log.Logger (debugM)
+
+-- Run tor hidden service.
+server :: TransportHandle -> IO ()
+server th@(TransportHandle (LocalRepo r) _) = do
+	u <- liftAnnex th getUUID
+	uid <- getRealUserID
+	let ident = fromUUID u
+	let sock = socketFile uid ident
+	nukeFile sock
+	soc <- socket AF_UNIX Stream defaultProtocol
+	bind soc (SockAddrUnix sock)
+	-- Allow everyone to read and write to the socket; tor is probably
+	-- running as a different user. Connections have to authenticate
+	-- to do anything, so it's fine that other local users can connect.
+	modifyFileMode sock $ addModes
+		[groupReadMode, groupWriteMode, otherReadMode, otherWriteMode]
+	listen soc 2
+	debugM "remotedaemon" "tor hidden service running"
+	forever $ do
+		(conn, _) <- accept soc
+		forkIO $ do
+			debugM "remotedaemon" "handling a connection"
+			h <- socketToHandle conn ReadWriteMode
+			hSetBuffering h LineBuffering
+			hSetBinaryMode h False
+			runNetProtoHandle h r (serve u)
+			hClose h
+

Utility/Tor.hs

@@ -15,6 +15,7 @@ import Data.Char
 type OnionPort = Int
 type OnionAddress = String
 type OnionSocket = FilePath
+type UniqueIdent = String
 
 -- | Adds a hidden service connecting to localhost, using some kind
 -- of unique identifier.
@@ -27,7 +28,7 @@ type OnionSocket = FilePath
 -- 
 -- If there is already a hidden service for the specified unique
 -- identifier, returns its information without making any changes.
-addHiddenService :: UserID -> String -> IO (OnionAddress, OnionPort, OnionSocket)
+addHiddenService :: UserID -> UniqueIdent -> IO (OnionAddress, OnionPort, OnionSocket)
 addHiddenService uid ident = do
 	ls <- lines <$> readFile torrc
 	let portssocks = mapMaybe (parseportsock . separate isSpace) ls
@@ -39,7 +40,7 @@ addHiddenService uid ident = do
 			writeFile torrc $ unlines $
 				ls ++
 				[ ""
-				, "HiddenServiceDir " ++ hsdir
+				, "HiddenServiceDir " ++ hiddenServiceDir uid ident
 				, "HiddenServicePort " ++ show newport ++ 
 					" unix:" ++ sockfile
 				]
@@ -58,13 +59,12 @@ addHiddenService uid ident = do
 		return (p, drop 1 (dropWhile (/= ':') l))
 	parseportsock _ = Nothing
 	
-	hsdir = libDir </> "hidden_service_" ++ show uid ++ "_" ++ ident
+	sockfile = socketFile uid ident
-	sockfile = runDir uid </> ident ++ ".sock"
 
 	waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort, OnionSocket)
 	waithiddenservice 0 _ = error "tor failed to create hidden service, perhaps the tor service is not running"
 	waithiddenservice n p = do
-		v <- tryIO $ readFile (hsdir </> "hostname")
+		v <- tryIO $ readFile $ hiddenServiceHostnameFile uid ident
 		case v of
 			Right s | ".onion\n" `isSuffixOf` s -> 
 				return (takeWhile (/= '\n') s, p, sockfile)
@@ -80,3 +80,12 @@ libDir = "/var/lib/tor"
 
 runDir :: UserID -> FilePath
 runDir uid = "/var/run/user" </> show uid
+
+socketFile :: UserID -> UniqueIdent -> FilePath
+socketFile uid ident = runDir uid </> ident ++ ".sock"
+
+hiddenServiceDir :: UserID -> UniqueIdent -> FilePath
+hiddenServiceDir uid ident = libDir </> "hidden_service_" ++ show uid ++ "_" ++ ident
+
+hiddenServiceHostnameFile :: UserID -> UniqueIdent -> FilePath
+hiddenServiceHostnameFile uid ident = hiddenServiceDir uid ident </> "hostname"

git-annex.cabal

@@ -937,6 +937,7 @@ Executable git-annex
     RemoteDaemon.Core
     RemoteDaemon.Transport
     RemoteDaemon.Transport.GCrypt
+    RemoteDaemon.Transport.Tor
     RemoteDaemon.Transport.Ssh
     RemoteDaemon.Transport.Ssh.Types
     RemoteDaemon.Types