actually check p2p authtokens for tor connections

This commit was sponsored by Ethan Aubin.

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

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

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"