diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-11-30 16:38:16 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-11-30 16:46:02 -0400 |
commit | ad7afb05bba11b372d66a6d5b685e013bb79a1a3 (patch) | |
tree | 2b7b6f94a0d61e10d7e80807e8ad216da27ec382 | |
parent | deca4cd90ad599f859fc9efafe509ed7375c6f39 (diff) |
actually check p2p authtokens for tor connections
This commit was sponsored by Ethan Aubin.
-rw-r--r-- | CmdLine/GitRemoteTorAnnex.hs | 8 | ||||
-rw-r--r-- | P2P/IO.hs | 51 | ||||
-rw-r--r-- | RemoteDaemon/Transport/Tor.hs | 19 |
3 files changed, 49 insertions, 29 deletions
diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index ea4532ae6..72211c995 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 @@ -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 ccb84d1e9..172948d37 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" |