-- | Command-line tool for opening and communicating through magic wormholes.
--
-- Intended to inter-operate with the `wormhole` command-line tool from
-- [magic-wormhole](https://github.com/warner/magic-wormhole).
module Main (main) where
import Protolude
import qualified Options.Applicative as Opt
import qualified Crypto.Spake2 as Spake2
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import qualified MagicWormhole
data Options
= Options
{ cmd :: Command
, rendezvousEndpoint :: MagicWormhole.WebSocketEndpoint
} deriving (Eq, Show)
optionsParser :: Opt.Parser Options
optionsParser
= Options
<$> commandParser
<*> Opt.option
(Opt.maybeReader MagicWormhole.parseWebSocketEndpoint)
( Opt.long "rendezvous-url" <>
Opt.help "Endpoint for the Rendezvous server" <>
Opt.value defaultEndpoint <>
Opt.showDefault )
where
-- | Default URI for rendezvous server.
--
-- This is Brian Warner's personal server.
defaultEndpoint = fromMaybe (panic "Invalid default URL") (MagicWormhole.parseWebSocketEndpoint "ws://relay.magic-wormhole.io:4000/v1")
data Command
= Send
| Receive
| Bounce -- Send and receive to the same server.
deriving (Eq, Show)
commandParser :: Opt.Parser Command
commandParser = Opt.hsubparser $
Opt.command "send" (Opt.info (pure Send) (Opt.progDesc "Send a text message, file, or directory")) <>
Opt.command "receive" (Opt.info (pure Receive) (Opt.progDesc "Receive a text message, file, or directory")) <>
Opt.command "bounce" (Opt.info (pure Bounce) (Opt.progDesc "Send and receive a message through a server"))
makeOptions :: Text -> Opt.Parser a -> Opt.ParserInfo a
makeOptions headerText parser = Opt.info (Opt.helper <*> parser) (Opt.fullDesc <> Opt.header (toS headerText))
-- | A password used to exchange with a Magic Wormhole peer.
--
-- XXX: Just picking ByteString because that's the least amount of work. Need
-- to look up exact type of password in the magic-wormhole docs.
type Password = ByteString
-- | Send a text message to a Magic Wormhole peer.
sendText :: MagicWormhole.Session -> Password -> Text -> IO ()
sendText session password message = do
nameplate <- MagicWormhole.allocate session
mailbox <- MagicWormhole.claim session nameplate
peer <- MagicWormhole.open session mailbox -- XXX: We should run `close` in the case of exceptions?
let (MagicWormhole.Nameplate n) = nameplate
MagicWormhole.withEncryptedConnection peer (Spake2.makePassword (toS n <> "-" <> password))
(\conn -> do
let offer = MagicWormhole.Message message
MagicWormhole.sendMessage conn (MagicWormhole.PlainText (toS (Aeson.encode offer))))
-- | Receive a text message from a Magic Wormhole peer.
receiveText :: MagicWormhole.Session -> IO Text
receiveText session = do
nameplates <- MagicWormhole.list session
putStrLn $ "Nameplates: " <> Text.intercalate ", " [ n | MagicWormhole.Nameplate n <- nameplates ]
putText "Choose nameplate: "
nameplate <- getLine
mailbox <- MagicWormhole.claim session (MagicWormhole.Nameplate nameplate)
peer <- MagicWormhole.open session mailbox
putText "Password: "
password <- getLine
let fullPassword = toS nameplate <> "-" <> toS password
MagicWormhole.withEncryptedConnection peer (Spake2.makePassword fullPassword)
(\conn -> do
MagicWormhole.PlainText received <- atomically $ MagicWormhole.receiveMessage conn
case Aeson.eitherDecode (toS received) of
Left err -> panic $ "Could not decode message: " <> show err
Right (MagicWormhole.Message message) -> pure message
Right (MagicWormhole.File _ _) -> pure $ "File transfer is not supported"
Right (MagicWormhole.Directory _ _ _ _ _) -> pure $ "Directory transfer is not supported")
-- | Bounce a trivial message to and from a Rendezvous server.
bounce :: MagicWormhole.WebSocketEndpoint -> MagicWormhole.AppID -> IO ()
bounce endpoint appID = do
side1 <- MagicWormhole.generateSide
side2 <- MagicWormhole.generateSide
MagicWormhole.runClient endpoint appID side1 Nothing $ \session1 -> do
nameplate <- MagicWormhole.allocate session1
mailbox1 <- MagicWormhole.claim session1 nameplate
peer1 <- MagicWormhole.open session1 mailbox1
MagicWormhole.runClient endpoint appID side2 Nothing $ \session2 -> do
mailbox2 <- MagicWormhole.claim session2 nameplate
peer2 <- MagicWormhole.open session2 mailbox2
let message = "aoeu"
(_, output) <- concurrently (send peer1 message) (receive peer2)
unless (output == message) $ panic $ "Mismatched messages: " <> show message <> " != " <> show output
where
send peer message = MagicWormhole.withEncryptedConnection peer password $ \conn -> do
let offer = MagicWormhole.Message message
MagicWormhole.sendMessage conn (MagicWormhole.PlainText (toS (Aeson.encode offer)))
receive peer = MagicWormhole.withEncryptedConnection peer password $ \conn -> do
MagicWormhole.PlainText received <- atomically $ MagicWormhole.receiveMessage conn
case Aeson.eitherDecode (toS received) of
Left err -> panic $ "Could not decode message: " <> show err
Right (MagicWormhole.Message message) -> pure message
Right (MagicWormhole.File _ _) -> pure $ "File transfer is not supported"
Right (MagicWormhole.Directory _ _ _ _ _) -> pure $ "Directory transfer is not supported"
password = Spake2.makePassword "potato"
main :: IO ()
main = do
options <- Opt.execParser (makeOptions "hocus-pocus - summon and traverse magic wormholes" optionsParser)
side <- MagicWormhole.generateSide
let endpoint = rendezvousEndpoint options
case cmd options of
Send -> MagicWormhole.runClient endpoint appID side Nothing $ \session ->
sendText session "potato" "Brave new world that has such offers in it"
Receive -> MagicWormhole.runClient endpoint appID side Nothing $ \session -> do
message <- receiveText session
putStr message
Bounce -> bounce endpoint appID
where
appID = MagicWormhole.AppID "jml.io/hocus-pocus"