mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

check if wormhole is installed

Browse source
This commit is contained in:
Joey Hess 2016-12-18 17:01:15 -04:00
parent ccde0932a5
commit 7f2e7fa271
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
2 changed files with 26 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

28
Command/P2P.hs
View file

@ -67,10 +67,10 @@ seek (LinkRemote, Just name) = commandAction $
seek (LinkRemote, Nothing) = commandAction $ seek (LinkRemote, Nothing) = commandAction $
linkRemote =<< unusedPeerRemoteName linkRemote =<< unusedPeerRemoteName
seek (Pair, Just name) = commandAction $ seek (Pair, Just name) = commandAction $
pairing name =<< loadP2PAddresses startPairing name =<< loadP2PAddresses
seek (Pair, Nothing) = commandAction $ do seek (Pair, Nothing) = commandAction $ do
name <- unusedPeerRemoteName name <- unusedPeerRemoteName
pairing name =<< loadP2PAddresses startPairing name =<< loadP2PAddresses
unusedPeerRemoteName :: Annex RemoteName unusedPeerRemoteName :: Annex RemoteName
unusedPeerRemoteName = go (1 :: Integer) =<< usednames unusedPeerRemoteName = go (1 :: Integer) =<< usednames
@ -119,11 +119,23 @@ linkRemote remotename = do
ConnectionError e -> giveup e ConnectionError e -> giveup e
AuthenticationError e -> giveup e AuthenticationError e -> giveup e
pairing :: RemoteName -> [P2PAddress] -> CommandStart startPairing :: RemoteName -> [P2PAddress] -> CommandStart
pairing _ [] = giveup "No P2P networks are currrently available." startPairing _ [] = giveup "No P2P networks are currrently available."
pairing remotename addrs = do startPairing remotename addrs = do
showStart "p2p pair" remotename showStart "p2p pair" remotename
next $ next $ do ifM (liftIO Wormhole.isInstalled)
( next $ performPairing remotename addrs
, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
)
performPairing :: RemoteName -> [P2PAddress] -> CommandPerform
performPairing remotename addrs = do
-- This note is displayed mainly so when magic wormhole
-- complains about possible protocol mismatches or other problems,
-- it's clear what's doing the complaining.
showLongNote "Will use Magic Wormhole for pairing."
next $ do
showOutput
r <- wormholePairing remotename addrs ui r <- wormholePairing remotename addrs ui
case r of case r of
PairSuccess -> return True PairSuccess -> return True
@ -153,7 +165,9 @@ pairing remotename addrs = do
l <- getLine l <- getLine
case Wormhole.toCode l of case Wormhole.toCode l of
Just code Just code
| code /= ourcode -> return code | code /= ourcode -> do
putStrLn "Pairing in process..."
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. We need the pairing code of the *other* repository."
getcode ourcode getcode ourcode

5
Utility/MagicWormhole.hs
View file

@ -20,6 +20,7 @@ module Utility.MagicWormhole (
WormHoleParams, WormHoleParams,
sendFile, sendFile,
receiveFile, receiveFile,
isInstalled,
) where ) where
import Utility.Process import Utility.Process
@ -28,6 +29,7 @@ import Utility.Monad
import Utility.Misc import Utility.Misc
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Utility.Env import Utility.Env
import Utility.Path
import System.IO import System.IO
import System.Exit import System.Exit
@ -153,3 +155,6 @@ runWormHoleProcess p consumer =
ExitSuccess -> True ExitSuccess -> True
ExitFailure _ -> False ExitFailure _ -> False
go h@(hin, hout, _) = consumer hin hout <&&> cleanup h go h@(hin, hout, _) = consumer hin hout <&&> cleanup h
isInstalled :: IO Bool
isInstalled = inPath "wormhole"