From b68d2a4b68e3ebce4c6bfb12ffe79ce73c414796 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Dec 2016 16:36:05 -0400 Subject: [PATCH] webapp: full wormhole pairing UI (untested) This commit was sponsored by Riku Voipio. --- Assistant/Threads/WebApp.hs | 2 + Assistant/WebApp/Configurators.hs | 4 +- Assistant/WebApp/Configurators/Pairing.hs | 119 ++++++++++++++---- Assistant/WebApp/Pairing.hs | 79 ++++++++++++ Assistant/WebApp/Types.hs | 10 ++ Assistant/WebApp/routes | 6 +- CHANGELOG | 10 +- Command/P2P.hs | 2 +- NEWS | 10 ++ doc/assistant/release_notes.mdwn | 6 +- git-annex.cabal | 6 +- .../addrepository/connection.hamlet | 2 +- .../configurators/addrepository/misc.hamlet | 2 +- ...nnection.hamlet => wormholepairing.hamlet} | 4 +- .../pairing/{tor => wormhole}/prompt.hamlet | 0 .../pairing/wormhole/start.hamlet | 31 +++++ 16 files changed, 252 insertions(+), 41 deletions(-) create mode 100644 Assistant/WebApp/Pairing.hs rename templates/configurators/addrepository/{torconnection.hamlet => wormholepairing.hamlet} (79%) rename templates/configurators/pairing/{tor => wormhole}/prompt.hamlet (100%) create mode 100644 templates/configurators/pairing/wormhole/start.hamlet diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 928d0cdd32..dfb631bc6f 100644 --- a/Assistant/Threads/WebApp.hs +++ b/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 diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 864b89f0e1..0042638b15 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/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") diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 3381b4f647..fa9c53dae2 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/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) diff --git a/Assistant/WebApp/Pairing.hs b/Assistant/WebApp/Pairing.hs new file mode 100644 index 0000000000..c999debac5 --- /dev/null +++ b/Assistant/WebApp/Pairing.hs @@ -0,0 +1,79 @@ +{- git-annex assistant pairing + - + - Copyright 2016 Joey Hess + - + - 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 diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index c316f0981a..5450638d92 100644 --- a/Assistant/WebApp/Types.hs +++ b/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 diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 28aaffd0dc..9be10ba940 100644 --- a/Assistant/WebApp/routes +++ b/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 diff --git a/CHANGELOG b/CHANGELOG index 7a0ca2eb20..985b9965c4 100644 --- a/CHANGELOG +++ b/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 diff --git a/Command/P2P.hs b/Command/P2P.hs index 48e6472739..b70e3e2b74 100644 --- a/Command/P2P.hs +++ b/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..." diff --git a/NEWS b/NEWS index 1266bae205..0e3db783fd 100644 --- a/NEWS +++ b/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 Tue, 27 Dec 2016 16:37:46 -0400 + git-annex (4.20131002) unstable; urgency=low The layout of gcrypt repositories has changed, and diff --git a/doc/assistant/release_notes.mdwn b/doc/assistant/release_notes.mdwn index dc3b7b7b76..6c7c432de4 100644 --- a/doc/assistant/release_notes.mdwn +++ b/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 diff --git a/git-annex.cabal b/git-annex.cabal index f2ba889793..b58f40e32a 100644 --- a/git-annex.cabal +++ b/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 diff --git a/templates/configurators/addrepository/connection.hamlet b/templates/configurators/addrepository/connection.hamlet index a90a5d85c7..7c528f7ccf 100644 --- a/templates/configurators/addrepository/connection.hamlet +++ b/templates/configurators/addrepository/connection.hamlet @@ -1,3 +1,3 @@ ^{makeSshRepository} -^{makeTorConnection} +^{makeWormholePairing} diff --git a/templates/configurators/addrepository/misc.hamlet b/templates/configurators/addrepository/misc.hamlet index ab9dbcd19d..4a4c2aaea2 100644 --- a/templates/configurators/addrepository/misc.hamlet +++ b/templates/configurators/addrepository/misc.hamlet @@ -8,7 +8,7 @@ SneakerNet # between computers. -^{makeTorConnection} +^{makeWormholePairing}

diff --git a/templates/configurators/addrepository/torconnection.hamlet b/templates/configurators/addrepository/wormholepairing.hamlet similarity index 79% rename from templates/configurators/addrepository/torconnection.hamlet rename to templates/configurators/addrepository/wormholepairing.hamlet index f5daa9b9db..d5cce64a8b 100644 --- a/templates/configurators/addrepository/torconnection.hamlet +++ b/templates/configurators/addrepository/wormholepairing.hamlet @@ -1,12 +1,12 @@

- + \ Share with your other devices

Keep files in sync between your devices running git-annex.

- + \ Share with a friend

diff --git a/templates/configurators/pairing/tor/prompt.hamlet b/templates/configurators/pairing/wormhole/prompt.hamlet similarity index 100% rename from templates/configurators/pairing/tor/prompt.hamlet rename to templates/configurators/pairing/wormhole/prompt.hamlet diff --git a/templates/configurators/pairing/wormhole/start.hamlet b/templates/configurators/pairing/wormhole/start.hamlet new file mode 100644 index 0000000000..74ed94cfc3 --- /dev/null +++ b/templates/configurators/pairing/wormhole/start.hamlet @@ -0,0 +1,31 @@ +