Added git-remote-tor-annex, which allows git pull and push to the tor hidden service.

Almost working, but there's a bug in the relaying.

Also, made tor hidden service setup pick a random port, to make it harder
to port scan.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.

3 files changed, 84 insertions, 25 deletions

diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs
index 1e1519560..7e49968ee 100644
--- a/Remote/Helper/P2P.hs
+++ b/Remote/Helper/P2P.hs
@@ -26,6 +26,12 @@ import qualified Data.ByteString.Lazy as L
 newtype AuthToken = AuthToken String
 	deriving (Show)
 
+mkAuthToken :: String -> Maybe AuthToken
+mkAuthToken = fmap AuthToken . headMaybe . lines
+
+nullAuthToken :: AuthToken
+nullAuthToken = AuthToken ""
+
 newtype Offset = Offset Integer
 	deriving (Show)
 
@@ -157,6 +163,7 @@ type Net = Free NetF
 data RelayData
 	= RelayData L.ByteString
 	| RelayMessage Message
+	deriving (Show)
 
 newtype RelayHandle = RelayHandle Handle
 
@@ -400,8 +407,8 @@ relayCallback hout (RelayMessage (DATA len)) = do
 	return Nothing
 relayCallback _ (RelayMessage (CONNECTDONE exitcode)) =
 	return (Just exitcode)
-relayCallback _ (RelayMessage _) = do
-	sendMessage (ERROR "expected DATA or CONNECTDONE")
+relayCallback _ (RelayMessage m) = do
+	sendMessage $ ERROR $ "expected DATA or CONNECTDONE not " ++ unwords (Proto.formatMessage m)
 	return (Just (ExitFailure 1))
 relayCallback _ (RelayData b) = do
 	let len = Len $ fromIntegral $ L.length b
diff --git a/Remote/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs
index 6908fd68c..c6a80cdbf 100644
--- a/Remote/Helper/P2P/IO.hs
+++ b/Remote/Helper/P2P/IO.hs
@@ -19,6 +19,7 @@ import Git
 import Git.Command
 import Utility.SafeCommand
 import Utility.SimpleProtocol
+import Utility.Exception
 
 import Control.Monad
 import Control.Monad.Free
@@ -30,7 +31,7 @@ import Control.Concurrent
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
-type RunProto = forall a m. MonadIO m => Proto a -> m a
+type RunProto = forall a m. (MonadIO m, MonadMask m) => Proto a -> m a
 
 data S = S
 	{ repo :: Repo
@@ -40,7 +41,7 @@ data S = S
 
 -- Implementation of the protocol, communicating with a peer
 -- over a Handle. No Local actions will be run.
-runNetProtoHandle :: MonadIO m => Handle -> Handle -> Repo -> Proto a -> m a
+runNetProtoHandle :: (MonadIO m, MonadMask m) => Handle -> Handle -> Repo -> Proto a -> m a
 runNetProtoHandle i o r = go
   where
 	go :: RunProto
@@ -48,7 +49,7 @@ runNetProtoHandle i o r = go
 	go (Free (Net n)) = runNetHandle (S r i o) go n
 	go (Free (Local _)) = error "local actions not allowed"
 
-runNetHandle :: MonadIO m => S -> RunProto -> NetF (Proto a) -> m a
+runNetHandle :: (MonadIO m, MonadMask m) => S -> RunProto -> NetF (Proto a) -> m a
 runNetHandle s runner f = case f of
 	SendMessage m next -> do
 		liftIO $ do
@@ -57,10 +58,11 @@ runNetHandle s runner f = case f of
 		runner next
 	ReceiveMessage next -> do
 		l <- liftIO $ hGetLine (ihdl s)
+		-- liftIO $ hPutStrLn stderr ("< " ++ show l)
 		case parseMessage l of
 			Just m -> runner (next m)
 			Nothing -> runner $ do
-				let e = ERROR "protocol parse error"
+				let e = ERROR $ "protocol parse error: " ++ show l
 				net $ sendMessage e
 				next e
 	SendBytes _len b next -> do
@@ -70,6 +72,7 @@ runNetHandle s runner f = case f of
 		runner next
 	ReceiveBytes (Len n) next -> do
 		b <- liftIO $ L.hGet (ihdl s) (fromIntegral n)
+		--liftIO $ hPutStrLn stderr $ "!!!" ++ show (L.length b)
 		runner (next b)
 	CheckAuthToken u t next -> do
 		authed <- return True -- TODO XXX FIXME really check
@@ -80,7 +83,8 @@ runNetHandle s runner f = case f of
 		runRelayService s runner service callback >>= runner . next
 	WriteRelay (RelayHandle h) b next -> do
 		liftIO $ do
-			L.hPut h b
+			-- L.hPut h b
+			hPutStrLn h (show ("relay got:", b, L.length b))
 			hFlush h
 		runner next
 
@@ -112,43 +116,57 @@ runRelay runner (RelayHandle hout) callback = do
 
 	drain v = do
 		d <- takeMVar v
+		liftIO $ hPutStrLn stderr (show d)
 		r <- runner $ net $ callback d
 		case r of
 			Nothing -> drain v
 			Just exitcode -> return exitcode
 
 runRelayService
-	:: MonadIO m
+	:: (MonadIO m, MonadMask m)
 	=> S
 	-> RunProto
 	-> Service
 	-> (RelayHandle -> RelayData -> Net (Maybe ExitCode))
 	-> m ExitCode
-runRelayService s runner service callback = do
-	v <- liftIO newEmptyMVar
-	(Just hin, Just hout, _, pid) <- liftIO $ createProcess serviceproc
-		{ std_out = CreatePipe
-		, std_in = CreatePipe
-		}
-	_ <- liftIO $ forkIO $ readout v hout
-	feeder <- liftIO $ forkIO $ feedin v
-	_ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid
-	exitcode <- liftIO $ drain v hin
-	liftIO $ killThread feeder
-	return exitcode
+runRelayService s runner service callback = bracket setup cleanup go
   where
 	cmd = case service of
 		UploadPack -> "upload-pack"
 		ReceivePack -> "receive-pack"
-	serviceproc = gitCreateProcess [Param cmd, File (repoPath (repo s))] (repo s)
+	
+	serviceproc = gitCreateProcess
+		[ Param cmd
+		, File (repoPath (repo s))
+		] (repo s)
+
+	setup = do
+		v <- liftIO newEmptyMVar
+		(Just hin, Just hout, _, pid) <- liftIO $ 
+			createProcess serviceproc
+				{ std_out = CreatePipe
+				, std_in = CreatePipe
+				}
+		feeder <- liftIO $ forkIO $ feedin v
+		return (v, feeder, hin, hout, pid)
+
+	cleanup (_, feeder, hin, hout, pid) = liftIO $ do
+		hClose hin
+		hClose hout
+		liftIO $ killThread feeder
+		void $ waitForProcess pid
+
+	go (v, _, hin, hout, pid) = do
+		_ <- liftIO $ forkIO $ readout v hout
+		_ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid
+		liftIO $ drain v hin
 
 	drain v hin = do
 		d <- takeMVar v
 		case d of
-			Left exitcode -> do
-				hClose hin
-				return exitcode
+			Left exitcode -> return exitcode
 			Right relaydata -> do
+				liftIO $ hPutStrLn stderr ("> " ++ show relaydata)
 				_ <- runner $ net $
 					callback (RelayHandle hin) relaydata
 				drain v hin
@@ -156,7 +174,7 @@ runRelayService s runner service callback = do
 	readout v hout = do
 		b <- B.hGetSome hout 65536
 		if B.null b
-			then hClose hout
+			then return ()
 			else do
 				putMVar v $ Right $ 
 					RelayData (L.fromChunks [b])
diff --git a/Remote/Helper/Tor.hs b/Remote/Helper/Tor.hs
new file mode 100644
index 000000000..e91083362
--- /dev/null
+++ b/Remote/Helper/Tor.hs
@@ -0,0 +1,34 @@
+{- 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 Remote.Helper.P2P (mkAuthToken, AuthToken)
+import Creds
+import Utility.Tor
+import Utility.Env
+
+import Network.Socket
+
+getTorAuthToken :: OnionAddress -> Annex (Maybe AuthToken)
+getTorAuthToken (OnionAddress onionaddress) =
+	maybe Nothing mkAuthToken <$> getM id 
+		[ liftIO $ getEnv torAuthTokenEnv
+		, readCacheCreds onionaddress
+		]
+
+torAuthTokenEnv :: String
+torAuthTokenEnv = "GIT_ANNEX_TOR_AUTHTOKEN"
+
+torHandle :: Socket -> IO Handle
+torHandle s = do
+	h <- socketToHandle s ReadWriteMode
+	hSetBuffering h LineBuffering
+	hSetBinaryMode h False
+	fileEncoding h
+	return h