diff options
Diffstat (limited to 'RemoteDaemon')
| -rw-r--r-- | RemoteDaemon/Core.hs | 49 | ||||
| -rw-r--r-- | RemoteDaemon/Transport.hs | 2 | ||||
| -rw-r--r-- | RemoteDaemon/Transport/Tor.hs | 38 | ||||
| -rw-r--r-- | RemoteDaemon/Types.hs | 4 |
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 |