remotedaemon: notice on RELOAD when tor hidden service has been enabled

and start serving it. This makes the webapp wormhole tor pairing work 100%!

This commit was sponsored by Andrea Rota.

4 files changed, 62 insertions, 31 deletions

diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs
index 2166c2b7a..a3e4e6400 100644
--- a/RemoteDaemon/Core.hs
+++ b/RemoteDaemon/Core.hs
@@ -74,12 +74,13 @@ runController :: TChan Consumed -> TChan Emitted -> IO ()
 runController ichan ochan = do
 	h <- genTransportHandle
 	m <- genRemoteMap h ochan
-	startrunning m
-	mapM_ (\s -> async (s h)) remoteServers
-	go h False m
+	starttransports m
+	serverchans <- mapM (startserver h) remoteServers
+	go h False m serverchans
   where
-	go h paused m = do
+	go h paused m serverchans = do
 		cmd <- atomically $ readTChan ichan
+		broadcast cmd serverchans
 		case cmd of
 			RELOAD -> do
 				h' <- updateTransportHandle h
@@ -87,36 +88,42 @@ runController ichan ochan = do
 				let common = M.intersection m m'
 				let new = M.difference m' m
 				let old = M.difference m m'
-				broadcast STOP old
+				broadcast STOP (mchans old)
 				unless paused $
-					startrunning new
-				go h' paused (M.union common new)
+					starttransports new
+				go h' paused (M.union common new) serverchans
 			LOSTNET -> do
 				-- force close all cached ssh connections
 				-- (done here so that if there are multiple
 				-- ssh remotes, it's only done once)
 				liftAnnex h forceSshCleanup
-				broadcast LOSTNET m
-				go h True m
+				broadcast LOSTNET transportchans
+				go h True m serverchans
 			PAUSE -> do
-				broadcast STOP m
-				go h True m
+				broadcast STOP transportchans
+				go h True m serverchans
 			RESUME -> do
 				when paused $
-					startrunning m
-				go h False m
+					starttransports m
+				go h False m serverchans
 			STOP -> exitSuccess
 			-- All remaining messages are sent to
 			-- all Transports.
 			msg -> do
-				unless paused $ atomically $
-					forM_ chans (`writeTChan` msg)
-				go h paused m
+				unless paused $
+					broadcast msg transportchans
+				go h paused m serverchans
 	  where
-		chans = map snd (M.elems m)
+		transportchans = mchans m
+		mchans = map snd . M.elems
+	
+	startserver h server = do
+		c <- newTChanIO
+		void $ async $ server c h
+		return c
 
-	startrunning m = forM_ (M.elems m) startrunning'
-	startrunning' (transport, c) = do
+	starttransports m = forM_ (M.elems m) starttransports'
+	starttransports' (transport, c) = do
 		-- drain any old control messages from the channel
 		-- to avoid confusing the transport with them
 		atomically $ drain c
@@ -124,9 +131,7 @@ runController ichan ochan = do
 	
 	drain c = maybe noop (const $ drain c) =<< tryReadTChan c
 	
-	broadcast msg m = atomically $ forM_ (M.elems m) send
-	  where
-		send (_, c) = writeTChan c msg
+	broadcast msg cs = atomically $ forM_ cs $ \c -> writeTChan c msg
 
 -- Generates a map with a transport for each supported remote in the git repo,
 -- except those that have annex.sync = false
diff --git a/RemoteDaemon/Transport.hs b/RemoteDaemon/Transport.hs
index 053973424..231173a76 100644
--- a/RemoteDaemon/Transport.hs
+++ b/RemoteDaemon/Transport.hs
@@ -26,5 +26,5 @@ remoteTransports = M.fromList
 	, (torAnnexScheme, RemoteDaemon.Transport.Tor.transport)
 	]
 
-remoteServers :: [TransportHandle -> IO ()]
+remoteServers :: [Server]
 remoteServers = [RemoteDaemon.Transport.Tor.server]
diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs
index e7d3794d6..2a2ceccca 100644
--- a/RemoteDaemon/Transport/Tor.hs
+++ b/RemoteDaemon/Transport/Tor.hs
@@ -34,14 +34,25 @@ import Control.Concurrent.STM.TBMQueue
 import Control.Concurrent.Async
 
 -- Run tor hidden service.
-server :: TransportHandle -> IO ()
-server th@(TransportHandle (LocalRepo r) _) = do
-	u <- liftAnnex th getUUID
-	uid <- getRealUserID
-	let ident = fromUUID u
-	go u =<< getHiddenServiceSocketFile torAppName uid ident
+server :: Server
+server ichan th@(TransportHandle (LocalRepo r) _) = go
   where
-	go u (Just sock) = do
+	go = checkstartservice >>= handlecontrol
+
+	checkstartservice = do
+		u <- liftAnnex th getUUID
+		uid <- getRealUserID
+		let ident = fromUUID u
+		msock <- getHiddenServiceSocketFile torAppName uid ident
+		case msock of
+			Nothing -> do
+				debugM "remotedaemon" "Tor hidden service not enabled"
+				return False
+			Just sock -> do
+				void $ async $ startservice sock u
+				return True
+	
+	startservice sock u = do
 		q <- newTBMQueueIO maxConnections
 		replicateM_ maxConnections $
 			forkIO $ forever $ serveClient th u r q
@@ -57,7 +68,18 @@ server th@(TransportHandle (LocalRepo r) _) = do
 			unless ok $ do
 				hClose conn
 				warningIO "dropped Tor connection, too busy"
-	go _ Nothing = debugM "remotedaemon" "Tor hidden service not enabled"
+	
+	handlecontrol servicerunning = do
+		msg <- atomically $ readTChan ichan
+		case msg of
+			-- On reload, the configuration may have changed to
+			-- enable the tor hidden service. If it was not
+			-- enabled before, start it,
+			RELOAD | not servicerunning -> go
+			-- We can ignore all other messages; no need
+			-- to restart the hidden service when the network
+			-- changes as tor takes care of all that.
+			_ -> handlecontrol servicerunning
 
 -- How many clients to serve at a time, maximum. This is to avoid DOS attacks.
 maxConnections :: Int
diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs
index c0d74e038..bc0fc1c0e 100644
--- a/RemoteDaemon/Types.hs
+++ b/RemoteDaemon/Types.hs
@@ -28,6 +28,10 @@ newtype RemoteURI = RemoteURI URI
 -- from a Chan, and emits others to another Chan.
 type Transport = RemoteRepo -> RemoteURI -> TransportHandle -> TChan Consumed -> TChan Emitted -> IO ()
 
+-- A server for a Transport consumes some messages from a Chan in
+-- order to learn about network changes, reloads, etc.
+type Server = TChan Consumed -> TransportHandle -> IO ()
+
 data RemoteRepo = RemoteRepo Git.Repo RemoteGitConfig
 newtype LocalRepo = LocalRepo Git.Repo