non-tor AuthTokens

As groundwork for making git-annex p2p support other P2P networks than
tor hidden services, when an AuthToken is not a TorAnnex value, but
something else (that will be added later), store the P2PAddress that it
will be used with along with the AuthToken. And in loadP2PAuthTokens,
only return AuthTokens for the specified P2PAddress.

See commit 2de27751d6 for some design work
that led to this.

Also, git-annex p2p --gen-addresses is changed to generate a separate
AuthToken for every P2P address. Rather than generating a single
AuthToke and using it for every one. When we have more than just tor,
this will be important for security, to avoid a compromise of one P2P
network exposing the AuthToken used for another network.

Command/P2P.hs

@@ -90,12 +90,16 @@ unusedPeerRemoteName = go (1 :: Integer) =<< usednames
 genAddresses :: [P2PAddress] -> Annex ()
 genAddresses [] = giveup "No P2P networks are currently available."
 genAddresses addrs = do
-	authtoken <- liftIO $ genAuthToken 128
+	addrauths <- forM addrs go
-	storeP2PAuthToken authtoken
 	earlyWarning "These addresses allow access to this git-annex repository. Only share them with people you trust with that access, using trusted communication channels!"
 	liftIO $ putStr $ safeOutput $ unlines $
-		map formatP2PAddress $
+		map formatP2PAddress addrauths
-			map (`P2PAddressAuth` authtoken) addrs
+	
+  where
+	go addr = do
+		authtoken <- liftIO $ genAuthToken 128
+		storeP2PAuthToken addr authtoken
+		return $ P2PAddressAuth addr authtoken
 
 -- Address is read from stdin, to avoid leaking it in shell history.
 linkRemote :: RemoteName -> CommandStart
@@ -268,20 +272,20 @@ finishPairing retries remotename (HalfAuthToken ourhalf) (PairData (HalfAuthToke
 	case (toAuthToken (ourhalf <> theirhalf), toAuthToken (theirhalf <> ourhalf)) of
 		(Just ourauthtoken, Just theirauthtoken) -> do
 			liftIO $ putStrLn $ "Successfully exchanged pairing data. Connecting to " ++ remotename ++  "..."
-			storeP2PAuthToken ourauthtoken
+			go retries theiraddrs theirauthtoken ourauthtoken
-			go retries theiraddrs theirauthtoken
 		_ -> return ReceiveFailed
   where
-	go 0 [] _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "."
+	go 0 [] _ _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "."
-	go n [] theirauthtoken = do
+	go n [] theirauthtoken ourauthtoken = do
 		liftIO $ threadDelaySeconds (Seconds 2)
 		liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..."
-		go (n-1) theiraddrs theirauthtoken
+		go (n-1) theiraddrs theirauthtoken ourauthtoken
-	go n (addr:rest) theirauthtoken = do
+	go n (addr:rest) theirauthtoken ourauthtoken = do
+		storeP2PAuthToken addr ourauthtoken
 		r <- setupLink remotename (P2PAddressAuth addr theirauthtoken)
 		case r of
 			LinkSuccess -> return PairSuccess
-			_ -> go n rest theirauthtoken
+			_ -> go n rest theirauthtoken ourauthtoken
 
 data LinkResult
 	= LinkSuccess

P2P/Auth.hs

@@ -1,6 +1,6 @@
 {- P2P authtokens
  -
- - Copyright 2016 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -18,24 +18,49 @@ import Utility.Env
 
 import qualified Data.Text as T
 
--- | Load authtokens that are accepted by this repository.
+-- | Load authtokens that are accepted by this repository for tor.
-loadP2PAuthTokens :: Annex AllowedAuthTokens
+loadP2PAuthTokensTor :: Annex AllowedAuthTokens
-loadP2PAuthTokens = allowedAuthTokens <$> loadP2PAuthTokens'
+loadP2PAuthTokensTor = allowedAuthTokens 
+	. map fst . filter istor
+	<$> loadP2PAuthTokens'
+  where
+	istor (_, Nothing) = True
+	istor _ = False
 
-loadP2PAuthTokens' :: Annex [AuthToken]
+-- | Load authtokens that are accepted for a given P2PAddress.
-loadP2PAuthTokens' = mapMaybe toAuthToken
+loadP2PAuthTokens :: P2PAddress -> Annex AllowedAuthTokens
-        . map T.pack
+loadP2PAuthTokens addr = allowedAuthTokens 
+	. map fst . filter ((== Just addr) . snd)
+	<$> loadP2PAuthTokens'
+
+loadP2PAuthTokens' :: Annex [(AuthToken, Maybe P2PAddress)]
+loadP2PAuthTokens' = mapMaybe parse
         . lines
         . fromMaybe []
         <$> readCreds p2pAuthCredsFile
+  where
+	parse l = 
+		let (tok, addr) = separate (== ' ') l
+		in do
+			tok' <- toAuthToken (T.pack tok) 
+			return (tok', unformatP2PAddress addr)
 
 -- | Stores an AuthToken, making it be accepted by this repository.
-storeP2PAuthToken :: AuthToken -> Annex ()
+storeP2PAuthToken :: P2PAddress -> AuthToken -> Annex ()
-storeP2PAuthToken t = do
+storeP2PAuthToken addr t = do
 	ts <- loadP2PAuthTokens'
-	unless (t `elem` ts) $ do
+	unless (v `elem` ts) $ do
-		let d = unlines $ map (T.unpack . fromAuthToken) (t:ts)
+		let d = unlines $ map fmt (v:ts)
 		writeCreds d p2pAuthCredsFile
+  where
+	v = case addr of
+		TorAnnex _ _ -> (t, Nothing)
+		-- _ -> (t, Just addr)
+	
+	fmt (tok, Nothing) = T.unpack (fromAuthToken tok)
+  	fmt (tok, Just addr') = T.unpack (fromAuthToken tok) 
+		++ " " ++ formatP2PAddress addr'
+
 
 p2pAuthCredsFile :: OsPath
 p2pAuthCredsFile = literalOsPath "p2pauth"

RemoteDaemon/Transport/Tor.hs

@@ -109,7 +109,7 @@ serveClient th@(TransportHandle _ _ rd) u r q = bracket setup cleanup start
 		((), (st', _rd)) <- Annex.run (st, rd) $ do
 			-- Load auth tokens for every connection, to notice
 			-- when the allowed set is changed.
-			allowed <- loadP2PAuthTokens
+			allowed <- loadP2PAuthTokensTor
 			let conn = P2PConnection
 				{ connRepo = Just r
 				, connCheckAuth = (`isAllowedAuthToken` allowed)