aboutsummaryrefslogtreecommitdiff
path: root/RemoteDaemon
diff options
context:
space:
mode:
Diffstat (limited to 'RemoteDaemon')
-rw-r--r--RemoteDaemon/Core.hs49
-rw-r--r--RemoteDaemon/Transport.hs2
-rw-r--r--RemoteDaemon/Transport/Tor.hs38
-rw-r--r--RemoteDaemon/Types.hs4
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