diff options
| -rw-r--r-- | P2P/Annex.hs | 21 | ||||
| -rw-r--r-- | RemoteDaemon/Transport/Tor.hs | 31 |
2 files changed, 29 insertions, 23 deletions
diff --git a/P2P/Annex.hs b/P2P/Annex.hs index e9b59652c..351fb38bb 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -25,10 +25,8 @@ import Utility.Metered import Control.Monad.Free --- When we're serving a peer, we know their uuid, and can use it to update --- transfer logs. data RunMode - = Serving UUID + = Serving UUID ChangedRefsHandle | Client -- Full interpreter for Proto, that can receive and send objects. @@ -115,18 +113,17 @@ runLocal runmode runner a = case a of protoaction False next Right _ -> runner next - WaitRefChange next -> do - v <- tryNonAsync $ bracket - watchChangedRefs - (liftIO . stopWatchingChangedRefs) - (liftIO . waitChangedRefs) - case v of - Left e -> return (Left (show e)) - Right changedrefs -> runner (next changedrefs) + WaitRefChange next -> case runmode of + Serving _ h -> do + v <- tryNonAsync $ liftIO $ waitChangedRefs h + case v of + Left e -> return (Left (show e)) + Right changedrefs -> runner (next changedrefs) + _ -> return $ Left "change notification not implemented for client" where transfer mk k af ta = case runmode of -- Update transfer logs when serving. - Serving theiruuid -> + Serving theiruuid _ -> mk theiruuid k af noRetry ta noNotification -- Transfer logs are updated higher in the stack when -- a client. diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 0dd1d1ba2..5ea06ac2c 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -10,6 +10,7 @@ module RemoteDaemon.Transport.Tor (server) where import Common import qualified Annex import Annex.Concurrent +import Annex.ChangedRefs import RemoteDaemon.Types import RemoteDaemon.Common import Utility.Tor @@ -71,12 +72,18 @@ maxConnections :: Int maxConnections = 10 serveClient :: TransportHandle -> UUID -> Repo -> TBQueue Handle -> IO () -serveClient th u r q = bracket setup cleanup go +serveClient th u r q = bracket setup cleanup start where - setup = atomically $ readTBQueue q - cleanup = hClose - go h = do + setup = do + h <- atomically $ readTBQueue q debugM "remotedaemon" "serving a Tor connection" + return h + + cleanup h = do + debugM "remotedaemon" "done with Tor connection" + hClose h + + start h = do -- Avoid doing any work in the liftAnnex, since only one -- can run at a time. st <- liftAnnex th dupState @@ -92,16 +99,18 @@ serveClient th u r q = bracket setup cleanup go } v <- liftIO $ runNetProto conn $ serveAuth u case v of - Right (Just theiruuid) -> void $ do - v' <- runFullProto (Serving theiruuid) conn $ - serveAuthed u - case v' of - Right () -> return () - Left e -> liftIO $ debugM "remotedaemon" ("Tor connection error: " ++ e) + Right (Just theiruuid) -> authed conn theiruuid Right Nothing -> liftIO $ debugM "remotedaemon" "Tor connection failed to authenticate" Left e -> liftIO $ debugM "remotedaemon" ("Tor connection error before authentication: " ++ e) -- Merge the duplicated state back in. liftAnnex th $ mergeState st' - debugM "remotedaemon" "done with Tor connection" + + authed conn theiruuid = + bracket watchChangedRefs (liftIO . stopWatchingChangedRefs) $ \crh -> do + v' <- runFullProto (Serving theiruuid crh) conn $ + serveAuthed u + case v' of + Right () -> return () + Left e -> liftIO $ debugM "remotedaemon" ("Tor connection error: " ++ e) |