webapp: full wormhole pairing UI (untested)

This commit was sponsored by Riku Voipio.
This commit is contained in:
Joey Hess 2016-12-27 16:36:05 -04:00
parent 9a35077168
commit b68d2a4b68
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
16 changed files with 252 additions and 41 deletions

View file

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

View file

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

View file

@ -5,7 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings #-} {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Assistant.WebApp.Configurators.Pairing where module Assistant.WebApp.Configurators.Pairing where
@ -14,18 +14,26 @@ import Assistant.Pairing
import Assistant.WebApp.Common import Assistant.WebApp.Common
import Annex.UUID import Annex.UUID
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
import Assistant.Pairing.Network import Assistant.DaemonStatus
import Assistant.Pairing.MakeRemote import Assistant.Pairing.MakeRemote
import Assistant.Pairing.Network
import Assistant.Ssh import Assistant.Ssh
import Assistant.Alert import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Verifiable import Utility.Verifiable
#endif #endif
import Utility.UserInfo import Utility.UserInfo
import Utility.Tor import Utility.Tor
import Assistant.WebApp.Pairing
import qualified Utility.MagicWormhole as Wormhole 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 Git
import Config.Files
import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
@ -34,39 +42,96 @@ import Data.Char
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Concurrent import Control.Concurrent
#endif #endif
import Control.Concurrent.STM hiding (check)
data PairingWith = PairingWithSelf | PairingWithFriend getStartWormholePairFriendR :: Handler Html
getStartWormholePairFriendR = startWormholePairR PairingWithFriend
getStartTorPairFriendR :: Handler Html getStartWormholePairSelfR :: Handler Html
getStartTorPairFriendR = postStartTorPairR PairingWithFriend getStartWormholePairSelfR = startWormholePairR PairingWithSelf
getStartTorPairSelfR :: Handler Html startWormholePairR :: PairingWith -> Handler Html
getStartTorPairSelfR = postStartTorPairR PairingWithSelf startWormholePairR pairingwith = whenTorInstalled $ whenWormholeInstalled $
pairPage $
$(widgetFile "configurators/pairing/wormhole/start")
postStartTorPairFriendR :: Handler Html getPrepareWormholePairR :: PairingWith -> Handler Html
postStartTorPairFriendR = postStartTorPairR PairingWithFriend 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 enableTor :: Handler ()
postStartTorPairSelfR = postStartTorPairR PairingWithSelf 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 getRunningWormholePairR :: WormholePairingId -> Handler Html
postStartTorPairR pairingwith = whenTorInstalled $ whenWormholeInstalled $ getRunningWormholePairR = runningWormholePairR
pairPage $ do
let Just ourcode = Wormhole.mkCode "11-bannana-bananna" -- XXX tmp 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 $ ((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
areq wormholeCodeField (bfs codeprompt) Nothing areq (checkwormholecode ourcode pairingwith textField) (bfs codeprompt) Nothing
case result of case result of
FormSuccess v -> error "TODO" FormSuccess t -> case Wormhole.toCode (T.unpack t) of
_ -> showform form enctype ourcode Nothing -> giveup invalidcode
where Just theircode -> finish h theircode
showform form enctype ourcode = $(widgetFile "configurators/pairing/tor/prompt") _ -> showform form enctype ourcode pairingwith
codeprompt = case pairingwith of
PairingWithFriend -> "Your friend's pairing code" showform form enctype ourcode pairingwith =
PairingWithSelf -> "The other device's pairing code" $(widgetFile "configurators/pairing/wormhole/prompt")
wormholeCodeField = checkBool (Wormhole.validCode . T.unpack)
("That does not look like a valid pairing code. Try again..." :: T.Text) checkwormholecode ourcode pairingwith = check $ \t ->
textField 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 :: Handler Html -> Handler Html
whenTorInstalled a = ifM (liftIO torIsInstalled) whenTorInstalled a = ifM (liftIO torIsInstalled)

View file

@ -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

View file

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

View file

@ -62,8 +62,10 @@
/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST /config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST
/config/repository/pair/tor/self/start StartTorPairSelfR GET POST /config/repository/pair/wormhole/start/self StartWormholePairSelfR GET
/config/repository/pair/tor/friend/start StartTorPairFriendR GET POST /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/rsync/#UUID EnableRsyncR GET POST
/config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST /config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST

View file

@ -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. 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 * metadata --batch: Fix bug when conflicting metadata changes were
made in the same batch run. made in the same batch run.
* Pass annex.web-options to wget and curl after other options, so that * Pass annex.web-options to wget and curl after other options, so that

View file

@ -168,7 +168,7 @@ performPairing remotename addrs = do
putStrLn "Exchanging pairing data..." putStrLn "Exchanging pairing data..."
return code return code
| otherwise -> do | 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 getcode ourcode
Nothing -> do Nothing -> do
putStrLn "That does not look like a valiad pairing code. Try again..." putStrLn "That does not look like a valiad pairing code. Try again..."

10
NEWS
View file

@ -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 git-annex (4.20131002) unstable; urgency=low
The layout of gcrypt repositories has changed, and The layout of gcrypt repositories has changed, and

View file

@ -1,6 +1,10 @@
## version 6.20170101 ## 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 ## version 5.20140421

View file

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

View file

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

View file

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

View file

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

View file

@ -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.