mocked up wormhole pairing interface in webapp

Assistant/WebApp/Configurators.hs

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

Assistant/WebApp/Configurators/Pairing.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant webapp configurator for pairing
  -
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012,2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -22,6 +22,7 @@ import Assistant.DaemonStatus
 import Utility.Verifiable
 #endif
 import Utility.UserInfo
+import qualified Utility.MagicWormhole as Wormhole
 import Git
 
 import qualified Data.Text as T
@@ -33,6 +34,38 @@ import qualified Control.Exception as E
 import Control.Concurrent
 #endif
 
+data PairingWith = PairingWithSelf | PairingWithFriend
+
+getStartTorPairFriendR :: Handler Html
+getStartTorPairFriendR = postStartTorPairR PairingWithFriend
+
+getStartTorPairSelfR :: Handler Html
+getStartTorPairSelfR = postStartTorPairR PairingWithSelf
+
+postStartTorPairFriendR :: Handler Html
+postStartTorPairFriendR = postStartTorPairR PairingWithFriend
+
+postStartTorPairSelfR :: Handler Html
+postStartTorPairSelfR = postStartTorPairR PairingWithSelf
+
+postStartTorPairR :: PairingWith -> Handler Html
+postStartTorPairR pairingwith = pairPage $ do
+	let Just ourcode = Wormhole.mkCode "11-bannana-bananna" -- XXX tmp
+	((result, form), enctype) <- liftH $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
+			areq wormholeCodeField (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 code. Try again..." :: T.Text)
+		textField
+
 {- Starts local pairing. -}
 getStartLocalPairR :: Handler Html
 getStartLocalPairR = postStartLocalPairR

Assistant/WebApp/routes

@@ -62,6 +62,9 @@
 /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/enable/rsync/#UUID EnableRsyncR GET POST
 /config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST
 /config/repository/enable/directory/#UUID EnableDirectoryR GET