From e714e0f67a4c706c3a99f542a7ea33dc3ba9cf43 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 30 Nov 2016 16:38:16 -0400 Subject: [PATCH] actually check p2p authtokens for tor connections This commit was sponsored by Ethan Aubin. --- CmdLine/GitRemoteTorAnnex.hs | 8 +++++- P2P/IO.hs | 51 ++++++++++++++++++----------------- RemoteDaemon/Transport/Tor.hs | 19 ++++++++++--- 3 files changed, 49 insertions(+), 29 deletions(-) diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index ea4532ae63..72211c995c 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -60,7 +60,13 @@ connectService address port service = do myuuid <- getUUID g <- Annex.gitRepo h <- liftIO $ torHandle =<< connectHiddenService address port - runNetProtoHandle h h g $ do + let runenv = RunEnv + { runRepo = g + , runCheckAuth = const False + , runIhdl = h + , runOhdl = h + } + runNetProtoHandle runenv $ do v <- auth myuuid authtoken case v of Just _theiruuid -> connect service stdin stdout diff --git a/P2P/IO.hs b/P2P/IO.hs index 822eb524ef..c0b14edca7 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -5,17 +5,19 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE RankNTypes, CPP #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} module P2P.IO - ( RunProto + ( RunEnv(..) , runNetProtoHandle + , runNetHandle ) where import P2P.Protocol import Utility.Process import Git import Git.Command +import Utility.AuthToken import Utility.SafeCommand import Utility.SimpleProtocol import Utility.Exception @@ -32,33 +34,34 @@ import qualified Data.ByteString.Lazy as L type RunProto = forall a m. (MonadIO m, MonadMask m) => Proto a -> m (Maybe a) -data S = S - { repo :: Repo - , ihdl :: Handle - , ohdl :: Handle +data RunEnv = RunEnv + { runRepo :: Repo + , runCheckAuth :: (AuthToken -> Bool) + , runIhdl :: Handle + , runOhdl :: Handle } -- Implementation of the protocol, communicating with a peer -- over a Handle. No Local actions will be run. -runNetProtoHandle :: (MonadIO m, MonadMask m) => Handle -> Handle -> Repo -> Proto a -> m (Maybe a) -runNetProtoHandle i o r = go +runNetProtoHandle :: (MonadIO m, MonadMask m) => RunEnv -> Proto a -> m (Maybe a) +runNetProtoHandle runenv = go where go :: RunProto go (Pure v) = pure (Just v) - go (Free (Net n)) = runNetHandle (S r i o) go n + go (Free (Net n)) = runNetHandle runenv go n go (Free (Local _)) = return Nothing -runNetHandle :: (MonadIO m, MonadMask m) => S -> RunProto -> NetF (Proto a) -> m (Maybe a) -runNetHandle s runner f = case f of +runNetHandle :: (MonadIO m, MonadMask m) => RunEnv -> RunProto -> NetF (Proto a) -> m (Maybe a) +runNetHandle runenv runner f = case f of SendMessage m next -> do v <- liftIO $ tryIO $ do - hPutStrLn (ohdl s) (unwords (formatMessage m)) - hFlush (ohdl s) + hPutStrLn (runOhdl runenv) (unwords (formatMessage m)) + hFlush (runOhdl runenv) case v of Left _e -> return Nothing Right () -> runner next ReceiveMessage next -> do - v <- liftIO $ tryIO $ hGetLine (ihdl s) + v <- liftIO $ tryIO $ hGetLine (runIhdl runenv) case v of Left _e -> return Nothing Right l -> case parseMessage l of @@ -69,18 +72,18 @@ runNetHandle s runner f = case f of next e SendBytes _len b next -> do v <- liftIO $ tryIO $ do - L.hPut (ohdl s) b - hFlush (ohdl s) + L.hPut (runOhdl runenv) b + hFlush (runOhdl runenv) case v of Left _e -> return Nothing Right () -> runner next ReceiveBytes (Len n) next -> do - v <- liftIO $ tryIO $ L.hGet (ihdl s) (fromIntegral n) + v <- liftIO $ tryIO $ L.hGet (runIhdl runenv) (fromIntegral n) case v of Left _e -> return Nothing Right b -> runner (next b) - CheckAuthToken u t next -> do - authed <- return True -- TODO XXX FIXME really check + CheckAuthToken _u t next -> do + let authed = runCheckAuth runenv t runner (next authed) Relay hin hout next -> do v <- liftIO $ runRelay runner hin hout @@ -88,7 +91,7 @@ runNetHandle s runner f = case f of Nothing -> return Nothing Just exitcode -> runner (next exitcode) RelayService service next -> do - v <- liftIO $ runRelayService s runner service + v <- liftIO $ runRelayService runenv runner service case v of Nothing -> return Nothing Just () -> runner next @@ -108,8 +111,8 @@ runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go go v = relayHelper runner v hin -runRelayService :: S -> RunProto -> Service -> IO (Maybe ()) -runRelayService s runner service = bracket setup cleanup go +runRelayService :: RunEnv -> RunProto -> Service -> IO (Maybe ()) +runRelayService runenv runner service = bracket setup cleanup go where cmd = case service of UploadPack -> "upload-pack" @@ -117,8 +120,8 @@ runRelayService s runner service = bracket setup cleanup go serviceproc = gitCreateProcess [ Param cmd - , File (repoPath (repo s)) - ] (repo s) + , File (repoPath (runRepo runenv)) + ] (runRepo runenv) setup = do (Just hin, Just hout, _, pid) <- createProcess serviceproc diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index ccb84d1e90..172948d37f 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -12,9 +12,11 @@ import RemoteDaemon.Types import RemoteDaemon.Common import Utility.Tor import Utility.FileMode +import Utility.AuthToken import Remote.Helper.Tor import P2P.Protocol import P2P.IO +import P2P.Auth import Annex.UUID import Types.UUID import Messages @@ -33,7 +35,7 @@ server th@(TransportHandle (LocalRepo r) _) = do q <- newTBQueueIO maxConnections replicateM_ maxConnections $ - forkIO $ forever $ serveClient u r q + forkIO $ forever $ serveClient th u r q uid <- getRealUserID let ident = fromUUID u @@ -66,12 +68,21 @@ server th@(TransportHandle (LocalRepo r) _) = do maxConnections :: Int maxConnections = 10 -serveClient :: UUID -> Repo -> TBQueue Handle -> IO () -serveClient u r q = bracket setup cleanup go +serveClient :: TransportHandle -> UUID -> Repo -> TBQueue Handle -> IO () +serveClient th u r q = bracket setup cleanup go where setup = atomically $ readTBQueue q cleanup = hClose go h = do debugM "remotedaemon" "serving a TOR connection" - void $ runNetProtoHandle h h r (serve u) + -- Load auth tokens for every connection, to notice + -- when the allowed set is changed. + allowed <- liftAnnex th loadP2PAuthTokens + let runenv = RunEnv + { runRepo = r + , runCheckAuth = (`isAllowedAuthToken` allowed) + , runIhdl = h + , runOhdl = h + } + void $ runNetProtoHandle runenv (serve u) debugM "remotedaemon" "done with TOR connection"