webapp: full wormhole pairing UI (untested)

This commit was sponsored by Riku Voipio.

Assistant/Threads/WebApp.hs

@@ -36,6 +36,7 @@ import Assistant.WebApp.Documentation
 import Assistant.WebApp.Control
 import Assistant.WebApp.OtherRepos
 import Assistant.WebApp.Repair
+import Assistant.WebApp.Pairing
 import Assistant.Types.ThreadedMonad
 import Utility.WebApp
 import Utility.AuthToken
@@ -82,6 +83,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
 		<*> pure cannotrun
 		<*> pure noannex
 		<*> pure listenhost'
+		<*> newWormholePairingState
 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
 	app <- toWaiAppPlain webapp
 	app' <- ifM debugEnabled

Assistant/WebApp/Configurators.hs

@@ -31,8 +31,8 @@ makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")
 makeCloudRepositories :: Widget
 makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
 
-makeTorConnection :: Widget
-makeTorConnection = $(widgetFile "configurators/addrepository/torconnection")
+makeWormholePairing :: Widget
+makeWormholePairing = $(widgetFile "configurators/addrepository/wormholepairing")
 
 makeSshRepository :: Widget
 makeSshRepository = $(widgetFile "configurators/addrepository/ssh")

Assistant/WebApp/Configurators/Pairing.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Configurators.Pairing where
@@ -14,18 +14,26 @@ import Assistant.Pairing
 import Assistant.WebApp.Common
 import Annex.UUID
 #ifdef WITH_PAIRING
-import Assistant.Pairing.Network
+import Assistant.DaemonStatus
 import Assistant.Pairing.MakeRemote
+import Assistant.Pairing.Network
 import Assistant.Ssh
 import Assistant.Alert
-import Assistant.DaemonStatus
 import Utility.Verifiable
 #endif
 import Utility.UserInfo
 import Utility.Tor
+import Assistant.WebApp.Pairing
 import qualified Utility.MagicWormhole as Wormhole
+import Assistant.MakeRemote
+import Assistant.RemoteControl
+import Assistant.Sync
+import Command.P2P (unusedPeerRemoteName, PairingResult(..))
+import P2P.Address
 import Git
+import Config.Files
 
+import qualified Data.Map as M
 import qualified Data.Text as T
 #ifdef WITH_PAIRING
 import qualified Data.Text.Encoding as T
@@ -34,39 +42,96 @@ import Data.Char
 import qualified Control.Exception as E
 import Control.Concurrent
 #endif
+import Control.Concurrent.STM hiding (check)
 
-data PairingWith = PairingWithSelf | PairingWithFriend
+getStartWormholePairFriendR :: Handler Html
+getStartWormholePairFriendR = startWormholePairR PairingWithFriend
 
-getStartTorPairFriendR :: Handler Html
-getStartTorPairFriendR = postStartTorPairR PairingWithFriend
+getStartWormholePairSelfR :: Handler Html
+getStartWormholePairSelfR = startWormholePairR PairingWithSelf
 
-getStartTorPairSelfR :: Handler Html
-getStartTorPairSelfR = postStartTorPairR PairingWithSelf
+startWormholePairR :: PairingWith -> Handler Html
+startWormholePairR pairingwith = whenTorInstalled $ whenWormholeInstalled $
+	pairPage $
+		$(widgetFile "configurators/pairing/wormhole/start")
 
-postStartTorPairFriendR :: Handler Html
-postStartTorPairFriendR = postStartTorPairR PairingWithFriend
+getPrepareWormholePairR :: PairingWith -> Handler Html
+getPrepareWormholePairR pairingwith = do
+	enableTor
+	myaddrs <- liftAnnex loadP2PAddresses
+	remotename <- liftAnnex unusedPeerRemoteName
+	h <- liftAssistant $
+		startWormholePairing pairingwith remotename myaddrs
+	i <- liftIO . addWormholePairingState h
+		=<< wormholePairingState <$> getYesod
+	redirect $ RunningWormholePairR i
 
-postStartTorPairSelfR :: Handler Html
-postStartTorPairSelfR = postStartTorPairR PairingWithSelf
+enableTor :: Handler ()
+enableTor = do
+	gitannex <- liftIO readProgramFile
+	(transcript, ok) <- liftIO $ processTranscript gitannex ["enable-tor"] Nothing
+	if ok
+		-- Reload remotedameon so it's serving the tor hidden
+		-- service.
+		then liftAssistant $ sendRemoteControl RELOAD
+		else giveup $ "Failed to enable tor\n\n" ++ transcript
 
-postStartTorPairR :: PairingWith -> Handler Html
-postStartTorPairR pairingwith = whenTorInstalled $ whenWormholeInstalled $
-	pairPage $ do
-		let Just ourcode = Wormhole.mkCode "11-bannana-bananna" -- XXX tmp
+getRunningWormholePairR :: WormholePairingId -> Handler Html
+getRunningWormholePairR = runningWormholePairR
+
+postRunningWormholePairR :: WormholePairingId -> Handler Html
+postRunningWormholePairR = runningWormholePairR
+
+runningWormholePairR :: WormholePairingId -> Handler Html
+runningWormholePairR i = go =<< getWormholePairingHandle i
+  where
+	go Nothing = redirect StartWormholePairFriendR
+	go (Just h) = pairPage $  withPairingWith h $ \pairingwith -> do
+		ourcode <- liftIO $ getOurWormholeCode h
+		let codeprompt = case pairingwith of
+			PairingWithFriend -> "Your friend's pairing code"
+			PairingWithSelf -> "The other device's pairing code"
 		((result, form), enctype) <- liftH $
 			runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
-				areq wormholeCodeField (bfs codeprompt) Nothing
+				areq (checkwormholecode ourcode pairingwith textField) (bfs codeprompt) Nothing
 		case result of
-			FormSuccess v -> error "TODO"
-			_ -> showform form enctype ourcode
-  where
-	showform form enctype ourcode = $(widgetFile "configurators/pairing/tor/prompt")
-	codeprompt = case pairingwith of
-		PairingWithFriend -> "Your friend's pairing code"
-		PairingWithSelf -> "The other device's pairing code"
-	wormholeCodeField = checkBool (Wormhole.validCode . T.unpack)
-		("That does not look like a valid pairing code. Try again..." :: T.Text)
-		textField
+			FormSuccess t -> case Wormhole.toCode (T.unpack t) of
+				Nothing -> giveup invalidcode
+				Just theircode -> finish h theircode
+			_ -> showform form enctype ourcode pairingwith
+	
+	showform form enctype ourcode pairingwith =
+		$(widgetFile "configurators/pairing/wormhole/prompt")
+	
+	checkwormholecode ourcode pairingwith = check $ \t ->
+		case Wormhole.toCode (T.unpack t) of
+			Nothing -> Left (T.pack invalidcode)
+			Just theircode
+				| theircode == ourcode -> Left $
+					case pairingwith of
+						PairingWithSelf -> "Oops -- You entered this repository's pairing code. Enter the pairing code of the *other* repository."
+						PairingWithFriend -> "Oops -- You entered your pairing code. Enter your friend's pairing code."
+				| otherwise -> Right t
+
+	invalidcode = "That does not look like a valid pairing code. Try again..."
+
+	finish h theircode = do
+		void $ liftIO $ sendTheirWormholeCode h theircode
+		res <- liftAssistant $ finishWormholePairing h
+		case res of
+			SendFailed -> giveup "Failed sending data to pair."
+			ReceiveFailed -> giveup "Failed receiving data from pair."
+			LinkFailed e -> giveup $ "Failed linking to pair: " ++ e
+			PairSuccess -> withRemoteName h $ \remotename -> do
+				r <- liftAnnex $ addRemote (return remotename)
+				liftAssistant $ syncRemote r
+				liftAssistant $ sendRemoteControl RELOAD
+				redirect DashboardR
+
+getWormholePairingHandle :: WormholePairingId -> Handler (Maybe WormholePairingHandle)
+getWormholePairingHandle i = do
+	s <- wormholePairingState <$> getYesod
+	liftIO $ atomically $ M.lookup i <$> readTVar s
 
 whenTorInstalled :: Handler Html -> Handler Html
 whenTorInstalled a = ifM (liftIO torIsInstalled)

Assistant/WebApp/Pairing.hs

@@ -0,0 +1,79 @@
+{- git-annex assistant pairing
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Assistant.WebApp.Pairing where
+
+import Assistant.Common
+import qualified Utility.MagicWormhole as Wormhole
+import Command.P2P (wormholePairing, PairingResult(..))
+import P2P.Address
+import Annex.Concurrent
+import Git.Types
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import qualified Data.Map as M
+
+data PairingWith = PairingWithSelf | PairingWithFriend
+	deriving (Eq, Show, Read)
+
+type WormholePairingState = TVar (M.Map WormholePairingId WormholePairingHandle)
+
+type WormholePairingHandle = (PairingWith, RemoteName, MVar Wormhole.CodeObserver, MVar Wormhole.Code, Async (Annex PairingResult))
+
+newtype WormholePairingId = WormholePairingId Int
+	deriving (Ord, Eq, Show, Read)
+
+newWormholePairingState :: IO WormholePairingState
+newWormholePairingState = newTVarIO M.empty
+
+addWormholePairingState :: WormholePairingHandle -> WormholePairingState -> IO WormholePairingId
+addWormholePairingState h tv = atomically $ do
+	m <- readTVar tv
+	-- use of head is safe because allids is infinite
+	let i = Prelude.head $ filter (`notElem` M.keys m) allids
+	writeTVar tv (M.insertWith' const i h m)
+	return i
+  where
+	allids = map WormholePairingId [1..]
+
+-- | Starts the wormhole pairing processes.
+startWormholePairing :: PairingWith -> RemoteName -> [P2PAddress] -> Assistant WormholePairingHandle
+startWormholePairing pairingwith remotename ouraddrs = do
+	observerrelay <- liftIO newEmptyMVar
+	producerrelay <- liftIO newEmptyMVar
+	-- wormholePairing needs to run in the Annex monad, and is a
+	-- long-duration action. So, don't just liftAnnex to run it;
+	-- fork the Annex state.
+	runner <- liftAnnex $ forkState $ 
+		wormholePairing remotename ouraddrs $ \observer producer -> do
+			putMVar observerrelay observer
+			theircode <- takeMVar producerrelay
+			Wormhole.sendCode producer theircode
+	tid <- liftIO $ async runner
+	return (pairingwith, remotename, observerrelay, producerrelay, tid)
+
+-- | Call after sendTheirWormholeCode. This can take some time to return.
+finishWormholePairing :: WormholePairingHandle -> Assistant PairingResult
+finishWormholePairing (_, _, _, _, tid) = liftAnnex =<< liftIO (wait tid)
+
+-- | Waits for wormhole to produce our code. Can be called repeatedly, safely.
+getOurWormholeCode :: WormholePairingHandle -> IO Wormhole.Code
+getOurWormholeCode (_, _, observerrelay, _, _) =
+	readMVar observerrelay >>= Wormhole.waitCode
+
+-- | Sends their code to wormhole. If their code has already been sent,
+-- avoids blocking and returns False.
+sendTheirWormholeCode :: WormholePairingHandle -> Wormhole.Code -> IO Bool
+sendTheirWormholeCode (_, _, _, producerrelay, _) = tryPutMVar producerrelay
+
+withPairingWith :: WormholePairingHandle -> (PairingWith -> a) -> a
+withPairingWith (pairingwith, _, _, _, _) a = a pairingwith
+
+withRemoteName :: WormholePairingHandle -> (RemoteName -> a) -> a
+withRemoteName (_, remotename, _, _, _) a = a remotename

Assistant/WebApp/Types.hs

@@ -27,6 +27,7 @@ import Utility.Gpg (KeyId)
 import Build.SysConfig (packageversion)
 import Types.ScheduledActivity
 import Assistant.WebApp.RepoId
+import Assistant.WebApp.Pairing
 import Types.Distribution
 
 import Yesod.Static
@@ -48,6 +49,7 @@ data WebApp = WebApp
 	, cannotRun :: Maybe String
 	, noAnnex :: Bool
 	, listenHost ::Maybe HostName
+	, wormholePairingState :: WormholePairingState
 	}
 
 mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
@@ -184,3 +186,11 @@ instance PathPiece RepoId where
 instance PathPiece GitAnnexDistribution where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
+
+instance PathPiece PairingWith where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack
+
+instance PathPiece WormholePairingId where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -62,8 +62,10 @@
 /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
 /config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST
 
-/config/repository/pair/tor/self/start StartTorPairSelfR GET POST
-/config/repository/pair/tor/friend/start StartTorPairFriendR GET POST
+/config/repository/pair/wormhole/start/self StartWormholePairSelfR GET
+/config/repository/pair/wormhole/start/friend StartWormholePairFriendR GET
+/config/repository/pair/wormhole/prepare/#PairingWith PrepareWormholePairR GET
+/config/repository/pair/wormhole/running/#WormholePairingId RunningWormholePairR GET POST
 
 /config/repository/enable/rsync/#UUID EnableRsyncR GET POST
 /config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST

CHANGELOG

@@ -1,7 +1,13 @@
-git-annex (6.20161211) UNRELEASED; urgency=medium
+git-annex (6.20170101) UNRELEASED; urgency=medium
 
-  * p2p --pair makes it easy to pair repositories over P2P, using
+  * XMPP support has been removed from the assistant in this release.
+    If your repositories used XMPP to keep in sync, that will no longer
+    work, and you should enable some other remote to keep them in sync.
+    A ssh server is one way, or use the new Tor pairing feature.
+  * p2p --pair makes it easy to pair repositories, using
     Magic Wormhole codes to find the other repository.
+  * webapp: The "Share with a friend" and "Share with your other devices"
+    pages have been changed to pair repositories using Tor and Magic Wormhole.
   * metadata --batch: Fix bug when conflicting metadata changes were
     made in the same batch run.
   * Pass annex.web-options to wget and curl after other options, so that

Command/P2P.hs

@@ -168,7 +168,7 @@ performPairing remotename addrs = do
 					putStrLn "Exchanging pairing data..."
 					return code
 				| otherwise -> do
-					putStrLn "Oops -- You entered this repository's pairing code. We need the pairing code of the *other* repository."
+					putStrLn "Oops -- You entered this repository's pairing code. Enter the pairing code of the *other* repository."
 					getcode ourcode
 			Nothing -> do
 				putStrLn "That does not look like a valiad pairing code. Try again..."

NEWS

@@ -1,3 +1,13 @@
+git-annex (6.20170101) unstable; urgency=low
+
+  XMPP support has been removed from the assistant in this release.
+
+  If your repositories used XMPP to keep in sync, that will no longer
+  work, and you should enable some other remote to keep them in sync.
+  A ssh server is one way, or use the new Tor pairing feature.
+
+ -- Joey Hess <id@joeyh.name>  Tue, 27 Dec 2016 16:37:46 -0400
+
 git-annex (4.20131002) unstable; urgency=low
 
    The layout of gcrypt repositories has changed, and

doc/assistant/release_notes.mdwn

@@ -1,6 +1,10 @@
 ## version 6.20170101
 
-This release removes XMPP support. Instead, the new Tor support can be used.
+XMPP support has been removed from the assistant in this release.
+
+If your repositories used XMPP to keep in sync, that will no longer
+work, and you should enable some other remote to keep them in sync.
+A ssh server is one way, or use the new Tor pairing feature.
 
 ## version 5.20140421
 

git-annex.cabal

@@ -197,7 +197,8 @@ Extra-Source-Files:
   templates/configurators/enablewebdav.hamlet
   templates/configurators/pairing/local/inprogress.hamlet
   templates/configurators/pairing/local/prompt.hamlet
-  templates/configurators/pairing/tor/prompt.hamlet
+  templates/configurators/pairing/wormhole/prompt.hamlet
+  templates/configurators/pairing/wormhole/start.hamlet
   templates/configurators/pairing/disabled.hamlet
   templates/configurators/addglacier.hamlet
   templates/configurators/fsck.cassius
@@ -220,9 +221,9 @@ Extra-Source-Files:
   templates/configurators/addrepository/archive.hamlet
   templates/configurators/addrepository/cloud.hamlet
   templates/configurators/addrepository/connection.hamlet
-  templates/configurators/addrepository/torconnection.hamlet
   templates/configurators/addrepository/ssh.hamlet
   templates/configurators/addrepository/misc.hamlet
+  templates/configurators/addrepository/wormholepairing.hamlet
   templates/configurators/rsync.net/add.hamlet
   templates/configurators/rsync.net/encrypt.hamlet
   templates/configurators/gitlab.com/add.hamlet
@@ -642,6 +643,7 @@ Executable git-annex
     Assistant.WebApp.Notifications
     Assistant.WebApp.OtherRepos
     Assistant.WebApp.Page
+    Assistant.WebApp.Pairing
     Assistant.WebApp.Repair
     Assistant.WebApp.RepoId
     Assistant.WebApp.RepoList

templates/configurators/addrepository/connection.hamlet

@@ -1,3 +1,3 @@
 ^{makeSshRepository}
 
-^{makeTorConnection}
+^{makeWormholePairing}

templates/configurators/addrepository/misc.hamlet

@@ -8,7 +8,7 @@
   <a href="http://en.wikipedia.org/wiki/Sneakernet">SneakerNet</a> #
   between computers. 
 
-^{makeTorConnection}
+^{makeWormholePairing}
 
 <h3>
   <a href="@{StartLocalPairR}">

templates/configurators/addrepository/wormholepairing.hamlet

@@ -1,12 +1,12 @@
 <h3>
-  <a href="@{StartTorPairSelfR}">
+  <a href="@{StartWormholePairSelfR}">
     <span .glyphicon .glyphicon-plus-sign>
     \ Share with your other devices
 <p>
   Keep files in sync between your devices running git-annex.
 
 <h3>
-  <a href="@{StartTorPairFriendR}">
+  <a href="@{StartWormholePairFriendR}">
     <span .glyphicon .glyphicon-plus-sign>
     \ Share with a friend
 <p>

templates/configurators/pairing/wormhole/start.hamlet

@@ -0,0 +1,31 @@
+<div .col-sm-9>
+  <div .content-box>
+    <h2>
+      $case pairingwith
+        $of PairingWithSelf
+          Preparing for pairing your devices
+        $of PairingWithFriend
+          reparing for pairing with a friend
+    <p>
+      Pairing will connect two git-annex repositories using #
+      <a href="https://torproject.org/">Tor</a>, #
+      allowing files to be shared between them.
+    <p>
+      First, a Tor hidden service needs to be set up on this computer.
+    <p>
+      <a .btn .btn-primary onclick="$('#setupmodal').modal('show');" href="@{PrepareWormholePairR pairingwith}">
+        <span .glyphicon .glyphicon-resize-small>
+        \ Let's get started #
+<div .modal .fade #setupmodal>
+  <div .modal-dialog>
+    <div .modal-content>
+      <div .modal-header>
+        <h3>
+          Enabling Tor hidden service ...
+      <div .modal-body>
+        <p>
+          This could take a few minutes, and you may be prompted for a #
+          password in order to enable the Tor hidden service.
+	<p>
+	  If this is taking too long, check that you are connected to the #
+	  network, and that Tor is working.