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.

diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs
index 2166c2b7a24f78e96c780ad542159c9a4b7e7f4e..a3e4e6400ff6d23addd8c4063a4e460fa8b1091a 100644 (file)
--- 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 053973424f41d68456dc17dbe6130f4c1a3f76cb..231173a762993ded58ab539da1275b90e1d6730d 100644 (file)
--- 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 e7d3794d6616d2bcfbb0c6d98a8f2f8ad303d1a6..2a2ceccca1f4b48c87fd3650787f2446341891f7 100644 (file)
--- 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 c0d74e038a877d53066c0540f4321d97ad5a8c98..bc0fc1c0eb716c8e62327917bd38ca7ae61f9a2c 100644 (file)
--- 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