p2p --pair with magic wormhole (untested)

It builds. I have not tried to run it yet. :)

This commit was sponsored by Jake Vosloo on Patreon.

1 files changed, 196 insertions, 25 deletions

diff --git a/Command/P2P.hs b/Command/P2P.hs
index d59d774c4..ddc6c29df 100644
--- a/Command/P2P.hs
+++ b/Command/P2P.hs
@@ -12,13 +12,20 @@ import P2P.Address
 import P2P.Auth
 import P2P.IO
 import qualified P2P.Protocol as P2P
-import Utility.AuthToken
 import Git.Types
 import qualified Git.Remote
 import qualified Git.Command
 import qualified Annex
 import Annex.UUID
 import Config
+import Utility.AuthToken
+import Utility.Tmp
+import Utility.FileMode
+import Utility.ThreadScheduler
+import qualified Utility.MagicWormhole as Wormhole
+
+import Control.Concurrent.Async
+import qualified Data.Text as T
 
 cmd :: Command
 cmd = command "p2p" SectionSetup
@@ -28,10 +35,11 @@ cmd = command "p2p" SectionSetup
 data P2POpts
 	= GenAddresses
 	| LinkRemote
+	| Pair
 
 optParser :: CmdParamsDesc -> Parser (P2POpts, Maybe RemoteName)
 optParser _ = (,)
-	<$> (genaddresses <|> linkremote)
+	<$> (pair <|> linkremote <|> genaddresses)
 	<*> optional name
   where
 	genaddresses = flag' GenAddresses
@@ -42,7 +50,11 @@ optParser _ = (,)
 		( long "link"
 		<> help "set up a P2P link to a git remote"
 		)
-	name = strOption
+	pair = flag' Pair
+		( long "pair"
+		<> help "pair with another repository"
+		)
+	name = Git.Remote.makeLegalName <$> strOption
 		( long "name"
 		<> metavar paramName
 		<> help "name of remote"
@@ -51,9 +63,14 @@ optParser _ = (,)
 seek :: (P2POpts, Maybe RemoteName) -> CommandSeek
 seek (GenAddresses, _) = genAddresses =<< loadP2PAddresses
 seek (LinkRemote, Just name) = commandAction $
-	linkRemote (Git.Remote.makeLegalName name)
+	linkRemote name
 seek (LinkRemote, Nothing) = commandAction $
 	linkRemote =<< unusedPeerRemoteName
+seek (Pair, Just name) = commandAction $
+	pairing name =<< loadP2PAddresses
+seek (Pair, Nothing) = commandAction $ do
+	name <- unusedPeerRemoteName
+	pairing name =<< loadP2PAddresses
 
 unusedPeerRemoteName :: Annex RemoteName
 unusedPeerRemoteName = go (1 :: Integer) =<< usednames
@@ -95,24 +112,178 @@ linkRemote remotename = do
 				Nothing -> do
 					liftIO $ hPutStrLn stderr "Unable to parse that address, please check its format and try again."
 					prompt
-				Just addr -> setup addr
-	setup (P2PAddressAuth addr authtoken) = do
-		g <- Annex.gitRepo
-		conn <- liftIO $ connectPeer g addr
-			`catchNonAsync` connerror
-		u <- getUUID
-		v <- liftIO $ runNetProto conn $ P2P.auth u authtoken
-		case v of
-			Right (Just theiruuid) -> do
-				ok <- inRepo $ Git.Command.runBool
-					[ Param "remote", Param "add"
-					, Param remotename
-					, Param (formatP2PAddress addr)
-					]
-				when ok $ do
-					storeUUIDIn (remoteConfig remotename "uuid") theiruuid
-					storeP2PRemoteAuthToken addr authtoken
-				return ok
-			Right Nothing -> giveup "Unable to authenticate with peer. Please check the address and try again."
-			Left e -> giveup $ "Unable to authenticate with peer: " ++ e
-	connerror e = giveup $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. ("  ++ show e ++ ")"
+				Just addr -> do
+					r <- setupLink remotename addr
+					case r of
+						LinkSuccess -> return True
+						ConnectionError e -> giveup e
+						AuthenticationError e -> giveup e
+
+pairing :: RemoteName -> [P2PAddress] -> CommandStart
+pairing _ [] = giveup "No P2P networks are currrently available."
+pairing remotename addrs = do
+	showStart "p2p pair" remotename
+	next $ next $ do
+		r <- wormholePairing remotename addrs ui
+		case r of
+			PairSuccess -> return True
+			SendFailed -> do
+				warning "Failed sending data to pair."
+				return False
+			ReceiveFailed -> do
+				warning "Failed receiving data from pair."
+				return False
+			LinkFailed e -> do
+				warning $ "Failed linking to pair: " ++ e
+				return False
+  where
+	ui observer producer = do
+		ourcode <- Wormhole.waitCode observer
+		putStrLn ""
+		putStrLn $ "This repository's pairing code is: " ++
+			Wormhole.fromCode ourcode
+		putStrLn ""
+		theircode <- getcode ourcode
+		Wormhole.sendCode producer theircode
+	
+	getcode ourcode = do
+		putStr "Enter the other repository's pairing code: "
+		hFlush stdout
+		fileEncoding stdin
+		l <- getLine
+		case Wormhole.toCode l of
+			Just code
+				| code /= ourcode -> return code
+				| otherwise -> do
+					putStrLn "Oops -- You entered this repository's pairing code. We need the pairing code of the *other* repository."
+					getcode ourcode
+			Nothing -> do
+				putStrLn "That does not look like a valid code. Try again..."
+				getcode ourcode
+
+-- We generate half of the authtoken; the pair will provide
+-- the other half.
+newtype HalfAuthToken = HalfAuthToken T.Text
+	deriving (Show)
+
+data PairData = PairData HalfAuthToken [P2PAddress]
+	deriving (Show)
+
+serializePairData :: PairData -> String
+serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $
+	T.unpack ha : map formatP2PAddress addrs
+
+deserializePairData :: String -> Maybe PairData
+deserializePairData s = case lines s of
+	[] -> Nothing
+	(ha:l) -> do
+		addrs <- mapM unformatP2PAddress l
+		return (PairData (HalfAuthToken (T.pack ha)) addrs)
+
+data PairingResult
+	= PairSuccess
+	| SendFailed
+	| ReceiveFailed
+	| LinkFailed String
+
+wormholePairing
+	:: RemoteName
+	-> [P2PAddress]
+	-> (Wormhole.CodeObserver -> Wormhole.CodeProducer -> IO ())
+	-> Annex PairingResult
+wormholePairing remotename ouraddrs ui = do
+	ourhalf <- liftIO $ HalfAuthToken . fromAuthToken
+		<$> genAuthToken 64
+	let ourpairdata = PairData ourhalf ouraddrs
+
+	-- The magic wormhole interface only supports exchanging
+	-- files. Permissions of received files may allow others
+	-- to read them. So, set up a temp directory that only
+	-- we can read.
+	withTmpDir "pair" $ \tmp -> do
+		liftIO $ void $ tryIO $ modifyFileMode tmp $ 
+			removeModes otherGroupModes
+		let sendf = tmp </> "send"
+		let recvf = tmp </> "recv"
+		liftIO $ writeFileProtected sendf $
+			serializePairData ourpairdata
+
+		observer <- liftIO Wormhole.mkCodeObserver
+		producer <- liftIO Wormhole.mkCodeProducer
+		void $ liftIO $ async $ ui observer producer
+		(sendres, recvres) <- liftIO $
+			Wormhole.sendFile sendf observer []
+				`concurrently`
+			Wormhole.receiveFile recvf producer []
+		liftIO $ nukeFile sendf
+		if sendres /= True
+			then return SendFailed
+			else if recvres /= True
+				then return ReceiveFailed
+				else do
+					r <- liftIO $ tryIO $
+						readFileStrictAnyEncoding recvf
+					case r of
+						Left _e -> return ReceiveFailed
+						Right s -> maybe 
+							(return ReceiveFailed)
+							(finishPairing 100 remotename ourhalf)
+							(deserializePairData s)
+
+-- | Allow the peer we're pairing with to authenticate to us,
+-- using an authtoken constructed from the two HalfAuthTokens.
+-- Connect to the peer we're pairing with, and try to link to them.
+--
+-- Multiple addresses may have been received for the peer. This only
+-- makes a link to one address.
+--
+-- Since we're racing the peer as they do the same, the first try is likely
+-- to fail to authenticate. Can retry any number of times, to avoid the
+-- users needing to redo the whole process.
+finishPairing :: Int -> RemoteName -> HalfAuthToken -> PairData -> Annex PairingResult
+finishPairing retries remotename (HalfAuthToken ourhalf) (PairData (HalfAuthToken theirhalf) theiraddrs) = do
+	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
+		_ -> return ReceiveFailed
+  where
+	go 0 [] _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "."
+	go n [] theirauthtoken = do
+		liftIO $ threadDelaySeconds (Seconds 2)
+		liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..."
+		go (n-1) theiraddrs theirauthtoken
+	go n (addr:rest) theirauthtoken = do
+		r <- setupLink remotename (P2PAddressAuth addr theirauthtoken)
+		case r of
+			LinkSuccess -> return PairSuccess
+			_ -> go n rest theirauthtoken
+
+data LinkResult
+	= LinkSuccess
+	| ConnectionError String
+	| AuthenticationError String
+
+setupLink :: RemoteName -> P2PAddressAuth -> Annex LinkResult
+setupLink remotename (P2PAddressAuth addr authtoken) = do
+	g <- Annex.gitRepo
+	cv <- liftIO $ tryNonAsync $ connectPeer g addr
+	case cv of
+		Left e -> return $ ConnectionError $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. ("  ++ show e ++ ")"
+		Right conn -> do
+			u <- getUUID
+			go =<< liftIO (runNetProto conn $ P2P.auth u authtoken)
+  where
+	go (Right (Just theiruuid)) = do
+		ok <- inRepo $ Git.Command.runBool
+			[ Param "remote", Param "add"
+			, Param remotename
+			, Param (formatP2PAddress addr)
+			]
+		when ok $ do
+			storeUUIDIn (remoteConfig remotename "uuid") theiruuid
+			storeP2PRemoteAuthToken addr authtoken
+		return LinkSuccess
+	go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again."
+	go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ e