packages feed

magic-wormhole (empty) → 0.1.0

raw patch · 26 files changed

+2651/−0 lines, 26 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, cryptonite, hashable, hedgehog, magic-wormhole, memory, network, network-uri, optparse-applicative, pqueue, process, protolude, saltine, spake2, stm, tasty, tasty-hedgehog, tasty-hspec, text, unordered-containers, websockets

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Changelog++## 0.1.0 (2018-01-17)++Initial release++* Exchange text messages with Magic Wormhole peers
+ LICENSE view
@@ -0,0 +1,163 @@+Apache License++Version 2.0, January 2004++http://www.apache.org/licenses/++TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++1. Definitions.++"License" shall mean the terms and conditions for use, reproduction, and+distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the+copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all other+entities that control, are controlled by, or are under common control with+that entity. For the purposes of this definition, "control" means (i) the+power, direct or indirect, to cause the direction or management of such+entity, whether by contract or otherwise, or (ii) ownership of fifty percent+(50%) or more of the outstanding shares, or (iii) beneficial ownership of such+entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising+permissions granted by this License.++"Source" form shall mean the preferred form for making modifications,+including but not limited to software source code, documentation source, and+configuration files.++"Object" form shall mean any form resulting from mechanical transformation or+translation of a Source form, including but not limited to compiled object+code, generated documentation, and conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object form,+made available under the License, as indicated by a copyright notice that is+included in or attached to the work (an example is provided in the Appendix+below).++"Derivative Works" shall mean any work, whether in Source or Object form, that+is based on (or derived from) the Work and for which the editorial revisions,+annotations, elaborations, or other modifications represent, as a whole, an+original work of authorship. For the purposes of this License, Derivative+Works shall not include works that remain separable from, or merely link (or+bind by name) to the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the original+version of the Work and any modifications or additions to that Work or+Derivative Works thereof, that is intentionally submitted to Licensor for+inclusion in the Work by the copyright owner or by an individual or Legal+Entity authorized to submit on behalf of the copyright owner. For the purposes+of this definition, "submitted" means any form of electronic, verbal, or+written communication sent to the Licensor or its representatives, including+but not limited to communication on electronic mailing lists, source code+control systems, and issue tracking systems that are managed by, or on behalf+of, the Licensor for the purpose of discussing and improving the Work, but+excluding communication that is conspicuously marked or otherwise designated+in writing by the copyright owner as "Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity on behalf+of whom a Contribution has been received by Licensor and subsequently+incorporated within the Work.++2. Grant of Copyright License. Subject to the terms and conditions of this+License, each Contributor hereby grants to You a perpetual, worldwide,+non-exclusive, no-charge, royalty-free, irrevocable copyright license to+reproduce, prepare Derivative Works of, publicly display, publicly perform,+sublicense, and distribute the Work and such Derivative Works in Source or+Object form.++3. Grant of Patent License. Subject to the terms and conditions of this+License, each Contributor hereby grants to You a perpetual, worldwide,+non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this+section) patent license to make, have made, use, offer to sell, sell, import,+and otherwise transfer the Work, where such license applies only to those+patent claims licensable by such Contributor that are necessarily infringed by+their Contribution(s) alone or by combination of their Contribution(s) with+the Work to which such Contribution(s) was submitted. If You institute patent+litigation against any entity (including a cross-claim or counterclaim in a+lawsuit) alleging that the Work or a Contribution incorporated within the Work+constitutes direct or contributory patent infringement, then any patent+licenses granted to You under this License for that Work shall terminate as of+the date such litigation is filed.++4. Redistribution. You may reproduce and distribute copies of the Work or+Derivative Works thereof in any medium, with or without modifications, and in+Source or Object form, provided that You meet the following conditions:++You must give any other recipients of the Work or Derivative Works a copy of+this License; and++You must cause any modified files to carry prominent notices stating that You+changed the files; and++You must retain, in the Source form of any Derivative Works that You+distribute, all copyright, patent, trademark, and attribution notices from the+Source form of the Work, excluding those notices that do not pertain to any+part of the Derivative Works; and++If the Work includes a "NOTICE" text file as part of its distribution, then+any Derivative Works that You distribute must include a readable copy of the+attribution notices contained within such NOTICE file, excluding those notices+that do not pertain to any part of the Derivative Works, in at least one of+the following places: within a NOTICE text file distributed as part of the+Derivative Works; within the Source form or documentation, if provided along+with the Derivative Works; or, within a display generated by the Derivative+Works, if and wherever such third-party notices normally appear. The contents+of the NOTICE file are for informational purposes only and do not modify the+License. You may add Your own attribution notices within Derivative Works that+You distribute, alongside or as an addendum to the NOTICE text from the Work,+provided that such additional attribution notices cannot be construed as+modifying the License.++You may add Your own copyright statement to Your modifications and may provide+additional or different license terms and conditions for use, reproduction, or+distribution of Your modifications, or for any such Derivative Works as a+whole, provided Your use, reproduction, and distribution of the Work otherwise+complies with the conditions stated in this License.++5. Submission of Contributions. Unless You explicitly state otherwise, any+Contribution intentionally submitted for inclusion in the Work by You to the+Licensor shall be under the terms and conditions of this License, without any+additional terms or conditions. Notwithstanding the above, nothing herein+shall supersede or modify the terms of any separate license agreement you may+have executed with Licensor regarding such Contributions.++6. Trademarks. This License does not grant permission to use the trade names,+trademarks, service marks, or product names of the Licensor, except as+required for reasonable and customary use in describing the origin of the Work+and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty. Unless required by applicable law or agreed to in+writing, Licensor provides the Work (and each Contributor provides its+Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+KIND, either express or implied, including, without limitation, any warranties+or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+PARTICULAR PURPOSE. You are solely responsible for determining the+appropriateness of using or redistributing the Work and assume any risks+associated with Your exercise of permissions under this License.++8. Limitation of Liability. In no event and under no legal theory, whether in+tort (including negligence), contract, or otherwise, unless required by+applicable law (such as deliberate and grossly negligent acts) or agreed to in+writing, shall any Contributor be liable to You for damages, including any+direct, indirect, special, incidental, or consequential damages of any+character arising as a result of this License or out of the use or inability+to use the Work (including but not limited to damages for loss of goodwill,+work stoppage, computer failure or malfunction, or any and all other+commercial damages or losses), even if such Contributor has been advised of+the possibility of such damages.++9. Accepting Warranty or Additional Liability. While redistributing the Work+or Derivative Works thereof, You may choose to offer, and charge a fee for,+acceptance of support, warranty, indemnity, or other liability obligations+and/or rights consistent with this License. However, in accepting such+obligations, You may act only on Your own behalf and on Your sole+responsibility, not on behalf of any other Contributor, and only if You agree+to indemnify, defend, and hold each Contributor harmless for any liability+incurred by, or claims asserted against, such Contributor by reason of your+accepting any such warranty or additional liability.++END OF TERMS AND CONDITIONS
+ cmd/HocusPocus.hs view
@@ -0,0 +1,134 @@+-- | 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)++-- | 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 $ \session1 -> do+    nameplate <- MagicWormhole.allocate session1+    mailbox1 <- MagicWormhole.claim session1 nameplate+    peer1 <- MagicWormhole.open session1 mailbox1+    MagicWormhole.runClient endpoint appID side2 $ \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++    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 $ \session ->+      sendText session "potato" "Brave new world that has such offers in it"+    Receive -> MagicWormhole.runClient endpoint appID side $ \session -> do+      message <- receiveText session+      putStr message+    Bounce -> bounce endpoint appID+  where+    appID = MagicWormhole.AppID "jml.io/hocus-pocus"
+ magic-wormhole.cabal view
@@ -0,0 +1,121 @@+-- This file has been generated from package.yaml by hpack version 0.17.1.+--+-- see: https://github.com/sol/hpack++name:           magic-wormhole+version:        0.1.0+synopsis:       Interact with Magic Wormhole+description:    Client library for interacting with a Magic Wormhole server.+                .+                Magic Wormhole is a technology for getting things from one computer to another, safely.+                It does this by using a server to locate peers, and then using SPAKE2 encryption to+                negotiate a secure connection to a peer. It is especially useful for sending files+                and short messages to other humans.+                .+                You can learn more about Magic Wormhole by exploring the documentation on+                the [canonical, Python+                implementation](https://github.com/warner/magic-wormhole).+category:       Crypto+homepage:       https://github.com/LeastAuthority/haskell-magic-wormhole#readme+bug-reports:    https://github.com/LeastAuthority/haskell-magic-wormhole/issues+maintainer:     Jonathan M. Lange <jml@mumak.net>+license:        Apache+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    CHANGELOG.md++data-files:+    tests/python/derive_phase_key.py+    tests/python/nacl_exchange.py+    tests/python/spake2_exchange.py+    tests/python/version_exchange.py++source-repository head+  type: git+  location: https://github.com/LeastAuthority/haskell-magic-wormhole++library+  hs-source-dirs:+      src+  default-extensions: NoImplicitPrelude OverloadedStrings TypeApplications+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , protolude >= 0.2+    , spake2 >= 0.4.1+    , aeson+    , bytestring+    , containers+    , cryptonite+    , hashable+    , memory+    , network+    , network-uri+    , pqueue+    , saltine+    , stm+    , unordered-containers+    , websockets+  exposed-modules:+      MagicWormhole+      MagicWormhole.Internal.ClientProtocol+      MagicWormhole.Internal.FileTransfer+      MagicWormhole.Internal.Messages+      MagicWormhole.Internal.Pake+      MagicWormhole.Internal.Peer+      MagicWormhole.Internal.Rendezvous+      MagicWormhole.Internal.Sequential+      MagicWormhole.Internal.Versions+      MagicWormhole.Internal.WebSockets+  default-language: Haskell2010++executable hocus-pocus+  main-is: HocusPocus.hs+  hs-source-dirs:+      cmd+  default-extensions: NoImplicitPrelude OverloadedStrings TypeApplications+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , protolude >= 0.2+    , spake2 >= 0.4.1+    , aeson+    , magic-wormhole+    , optparse-applicative+    , text+  default-language: Haskell2010++test-suite tasty+  type: exitcode-stdio-1.0+  main-is: Tasty.hs+  hs-source-dirs:+      tests+  default-extensions: NoImplicitPrelude OverloadedStrings TypeApplications+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , protolude >= 0.2+    , spake2 >= 0.4.1+    , aeson+    , bytestring+    , hedgehog+    , magic-wormhole+    , memory+    , process+    , saltine+    , stm+    , tasty+    , tasty-hedgehog+    , tasty-hspec+  other-modules:+      ClientProtocol+      Generator+      Integration+      Messages+      Pake+      Sequential+      WebSockets+  default-language: Haskell2010
+ src/MagicWormhole.hs view
@@ -0,0 +1,87 @@+-- |+-- Description : A Magic Wormhole client.+--+-- Magic Wormhole is a technology for getting things from one computer to another, safely.+--+-- To use it, you must+--+--   1. Start a 'Rendezvous.Session' with the Rendezvous server, to allow peers to find each other ('Rendezvous.runClient')+--   2. Negotiate a shared 'Messages.Nameplate' so peers can find each other on the server ('Rendezvous.allocate', 'Rendezvous.list')+--   3. Use the shared 'Messages.Nameplate' to 'Rendezvous.open' a shared 'Messages.Mailbox'+--   4. Use a secret password shared between peers to establish an encrypted connection ('Peer.withEncryptedConnection')+--+-- Once you've done this, you can communicate with your peer via 'Peer.sendMessage' and 'Peer.receiveMessage'.+--+-- The password is never sent over the wire.+-- Rather, it is used to negotiate a session key using SPAKE2,+-- and that key itself is used to derive many per-message keys,+-- so that each message is encrypted using NaCl SecretBox.+--+-- This library is a client library for the Rendezvous server /and/ a library+-- for communicating with Magic Wormhole peers.+module MagicWormhole+  ( -- * Client/server+    --+    -- | Before you can communicate with a Magic Wormhole peer, you must first find them.+    -- The way to do this is to establish a 'Rendezvous.Session' with a Magic Wormhole Rendezvous server.++    -- ** Establishing a session+    Rendezvous.Session+  , Rendezvous.runClient+  , Messages.AppID(..)+  , Messages.Side(..)+  , Messages.generateSide+    -- ** Locating the server+    --+    -- | Rendezvous servers are implemented as web sockets.+  , WebSockets.WebSocketEndpoint(..)+  , WebSockets.parseWebSocketEndpoint+    -- ** Operations on the server+  , Rendezvous.allocate+  , Messages.Nameplate(..)+  , Rendezvous.list+  , Rendezvous.claim+  , Messages.Mailbox(..)+  , Rendezvous.open+  , Rendezvous.close+    -- ** Errors+  , Rendezvous.ServerError(..)+  , Rendezvous.ClientError(..)+    -- * Peer-to-peer+    --+    -- | Opening a 'Messgaes.Mailbox' shared with a peer gets you a 'ClientProtocol.Connection',+    -- but this is not enough to securely communicate with a peer.+    -- The next step is to establish an 'Peer.EncryptedConnection'+    -- (via -- 'Peer.withEncryptedConnection'),+    -- and then communicate with 'Peer.sendMessage' and 'Peer.receiveMessage'.++    -- ** Establishing a secure connection+  , Peer.withEncryptedConnection+  , ClientProtocol.Connection+  , Peer.EncryptedConnection+    -- *** Errors+  , ClientProtocol.PeerError+  , Versions.VersionsError+  , Pake.PakeError+    -- ** Communicating with a peer+  , Peer.sendMessage+  , Peer.receiveMessage+  , ClientProtocol.PlainText(..)+    -- * Magic Wormhole applications+    --+    -- | Once you've established an 'Peer.EncryptedConnection' to your peer, the world is your oyster.+    -- You can send whatever data you'd like.+    --+    -- However, Magic Wormhole comes with at least one built-in "application": message and file transfer.+    -- This Haskell implementation only supports sending and receiving a simple message.+  , FileTransfer.Offer(..)+  ) where++import qualified MagicWormhole.Internal.ClientProtocol as ClientProtocol+import qualified MagicWormhole.Internal.FileTransfer as FileTransfer+import qualified MagicWormhole.Internal.Messages as Messages+import qualified MagicWormhole.Internal.Pake as Pake+import qualified MagicWormhole.Internal.Peer as Peer+import qualified MagicWormhole.Internal.Rendezvous as Rendezvous+import qualified MagicWormhole.Internal.Versions as Versions+import qualified MagicWormhole.Internal.WebSockets as WebSockets
+ src/MagicWormhole/Internal/ClientProtocol.hs view
@@ -0,0 +1,154 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE TupleSections #-}+-- |+-- Description : Low-level details for talking to a Magic Wormhole peer.+--+-- Low-level details for talking to a Magic Wormhole peer.+--+-- For a user-facing interface, see "MagicWormhole.Internal.Peer".+module MagicWormhole.Internal.ClientProtocol+  ( Connection(..)+  , SessionKey(..)+  , PeerError(..)+  , sendEncrypted+  , receiveEncrypted+  , PlainText(..)+  -- * Exported for testing+  , CipherText(..)+  , decrypt+  , encrypt+  , deriveKey+  , Purpose+  , phasePurpose+  ) where++import Protolude hiding (phase)++import Crypto.Hash (SHA256(..), hashWith)+import qualified Crypto.KDF.HKDF as HKDF+import qualified Crypto.Saltine.Internal.ByteSizes as ByteSizes+import qualified Crypto.Saltine.Class as Saltine+import qualified Crypto.Saltine.Core.SecretBox as SecretBox+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as ByteString++import qualified MagicWormhole.Internal.Messages as Messages++-- | A connection to a peer via the Rendezvous server.+--+-- Normally construct this with 'MagicWormhole.open'.+data Connection+  = Connection+  { -- | The application ID for this connection.+    appID :: Messages.AppID+    -- | The identifier for this side of the connection.+  , ourSide :: Messages.Side+    -- | Send a message to the other side.+  , send :: Messages.Phase -> Messages.Body -> IO ()+    -- | Receive a message from the other side.+  , receive :: STM Messages.MailboxMessage+  }++-- | SPAKE2 key used for the duration of a Magic Wormhole peer-to-peer connection.+--+-- You can obtain a 'SessionKey' using 'MagicWormhole.Internal.Pake.pakeExchange'.+--+-- Individual messages will be encrypted using 'encrypt' ('decrypt'), which+-- must be given a key that's /generated/ from this one (see 'deriveKey').+newtype SessionKey = SessionKey ByteString++-- | Send an encrypted message to the peer.+sendEncrypted+  :: Connection -- ^ Connection to the peer+  -> SessionKey -- ^ The key established for this session+  -> Messages.Phase -- ^ Phase of the protocol this message represents+  -> PlainText -- ^ Content of the message+  -> IO ()+sendEncrypted conn key phase plaintext = do+  encryptedBody <- encryptMessage conn key phase plaintext+  send conn phase encryptedBody++-- | Pull a message from the peer and decrypt it. If the message fails to+-- decrypt, an exception will be thrown, aborting the transaction and leaving+-- the message on the queue.+receiveEncrypted+  :: Connection -- ^ Connection to the peer+  -> SessionKey -- ^ The key established for this session+  -> STM (Messages.Phase, PlainText)  -- ^ The phase and content of the message we received+receiveEncrypted conn key = do+  message <- receive conn+  either throwSTM pure $ decryptMessage key message++-- | Encrypt a mailbox message, deriving the key from the phase.+encryptMessage :: Connection -> SessionKey -> Messages.Phase -> PlainText -> IO Messages.Body+encryptMessage conn key phase plaintext = Messages.Body . cipherTextToByteString <$> encrypt derivedKey plaintext+  where+    derivedKey = deriveKey key (phasePurpose (ourSide conn) phase)++-- | Encrypt a message using 'SecretBox'. Get the key from 'deriveKey'.+-- Decrypt with 'decrypt'.+encrypt :: SecretBox.Key -> PlainText -> IO CipherText+encrypt key (PlainText message) = do+  nonce <- SecretBox.newNonce+  let ciphertext = SecretBox.secretbox key nonce message+  pure . CipherText $ Saltine.encode nonce <> ciphertext++-- | Decrypt a 'MailboxMessage' using 'SecretBox'. Derives the key from the phase.+decryptMessage :: SessionKey -> Messages.MailboxMessage -> Either PeerError (Messages.Phase, PlainText)+decryptMessage key message =+  let Messages.Body ciphertext = Messages.body message+  in (Messages.phase message,) <$> decrypt (derivedKey message) (CipherText ciphertext)+  where+    derivedKey msg = deriveKey key (phasePurpose (Messages.side msg) (Messages.phase msg))++-- | Decrypt a message using 'SecretBox'. Get the key from 'deriveKey'.+-- Encrypted using 'encrypt'.+decrypt :: SecretBox.Key -> CipherText -> Either PeerError PlainText+decrypt key (CipherText ciphertext) = do+  let (nonce', ciphertext') = ByteString.splitAt ByteSizes.secretBoxNonce ciphertext+  nonce <- note (InvalidNonce nonce') $ Saltine.decode nonce'+  note (CouldNotDecrypt ciphertext') $ PlainText <$> SecretBox.secretboxOpen key nonce ciphertext'++-- | Unencrypted text.+newtype PlainText = PlainText { plainTextToByteString :: ByteString } deriving (Eq, Ord, Show)++-- | Encrypted text.+newtype CipherText = CipherText { cipherTextToByteString :: ByteString } deriving (Eq, Ord, Show)++-- | The purpose of a message. 'deriveKey' combines this with the 'SessionKey'+-- to make a unique 'SecretBox.Key'. Do not re-use a 'Purpose' to send more+-- than message.+type Purpose = ByteString++-- | Derive a one-off key from the SPAKE2 'SessionKey'. Use this key only once.+deriveKey+  :: SessionKey -- ^ Key established for this session+  -> Purpose -- ^ What this key is for. Normally created using 'phasePurpose'.+  -> SecretBox.Key  -- ^ A key to use once to send or receive a message+deriveKey (SessionKey key) purpose =+  fromMaybe (panic "Could not encode to SecretBox key") $ -- Impossible. We guarntee it's the right size.+    Saltine.decode (HKDF.expand (HKDF.extract salt key :: HKDF.PRK SHA256) purpose keySize)+  where+    salt = "" :: ByteString+    keySize = ByteSizes.secretBoxKey++-- | Obtain a 'Purpose' for deriving a key to send a message that's part of a+-- peer-to-peer communication.+phasePurpose :: Messages.Side -> Messages.Phase -> Purpose+phasePurpose (Messages.Side side) phase = "wormhole:phase:" <> sideHashDigest <> phaseHashDigest+  where+    sideHashDigest = hashDigest (toS @Text @ByteString side)+    phaseHashDigest = hashDigest (toS (Messages.phaseName phase) :: ByteString)+    hashDigest thing = ByteArray.convert (hashWith SHA256 thing)++-- | Something that went wrong with the client protocol.+data PeerError+  -- | We received a message from the other side that we could not decrypt+  = CouldNotDecrypt ByteString+  -- | We could not determine the SecretBox nonce from the message we received+  | InvalidNonce ByteString+  -- | We received a message for a phase that we have already received a message for.+  | MessageOutOfOrder Messages.Phase PlainText+  deriving (Eq, Show, Typeable)++instance Exception PeerError
+ src/MagicWormhole/Internal/FileTransfer.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_HADDOCK not-home #-}+-- |+-- Description : File transfer and simple text message protocol+--+-- Partial implementation of the [Magic Wormhole file transfer protocol](https://github.com/warner/magic-wormhole/blob/master/docs/file-transfer-protocol.md).+--+-- Once a connection has been made between peers (see 'MagicWormhole.withEncryptedConnection'),+-- you can send an 'Offer' to share a simple text message.+module MagicWormhole.Internal.FileTransfer+  ( Offer(..)+  ) where++import Protolude++import Data.Aeson+  ( FromJSON(..)+  , ToJSON(..)+  , (.:)+  , (.=)+  , object+  , withObject+  )++-- | An offer made by a sender as part of the Magic Wormhole file transfer protocol.+--+-- Currently only supports sending simple text messages. A full version would+-- also support sending files and directories.+newtype Offer+  -- | A simple text message.+  = Message Text deriving (Eq, Show)++instance ToJSON Offer where+  toJSON (Message text) = object [ "offer" .= object [ "message" .= text ] ]++instance FromJSON Offer where+  parseJSON = withObject "Offer" $ \obj -> do+    offer <- obj .: "offer"+    Message <$> offer .: "message"
+ src/MagicWormhole/Internal/Messages.hs view
@@ -0,0 +1,377 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Messages sent to and from the Rendezvous server.+module MagicWormhole.Internal.Messages+  ( ClientMessage(..)+  , ServerMessage(..)+  , AppID(..)+  , MailboxMessage(..)+  , WelcomeMessage(..)+  , MessageID(..)+  , Side(..)+  , generateSide+  , Phase(..)+  , phaseName+  , Body(..)+  , Nameplate(..)+  , Mailbox(..)+  , Mood(..)+  ) where++import Protolude++import Control.Monad (fail)+import Crypto.Random (MonadRandom(..))+import Data.Aeson+  ( FromJSON(..)+  , ToJSON(..)+  , Value(Object, String)+  , (.:)+  , (.:?)+  , (.=)+  , object+  )+import Data.Aeson.Types (Pair, typeMismatch)+import Data.ByteArray.Encoding (convertFromBase, convertToBase, Base(Base16))+import Numeric (readHex, showHex)+++-- | A message received from the server.+--+-- Some open questions:+-- * general message stuff--how are we going to model this?+--   * outgoing messages include a randomly generated 'id' field, which is+--     returned by the server+--   * messages from the server include 'server_tx', a float timestamp recording+--     when the server received the message+--   * messages from the server that are direct responses include a 'server_rx'+--     timestamp--unclear what this means?+--   * do we want a separate Haskell type for each message type? e.g. PingMessage+--   * if we do that, how do associate request/response pairs? e.g. PingMessage &+--     PongMessage?+--   * do we want to (can we even?) structurally distinguish between messages that+--     make sense outside the scope of a binding (e.g. ping) and messages that only+--     make sense after a bind (e.g. allocate)+data ServerMessage+  = -- | Sent by the server on initial connection.+    Welcome WelcomeMessage+  | -- | Sent in response to "list"+    Nameplates+    {+      nameplates :: [Nameplate]+    }+  | -- | Sent in response to "allocate"+    Allocated+    {+      -- | The nameplate allocated to this connection (?).+      nameplate :: Nameplate+    }+  | -- | Sent in response to "claim"+    Claimed+    { -- | The mailbox claimed by this connection (?)+      mailbox :: Mailbox+    }+  | -- | Sent in response to "release"+    Released+  | -- | A message sent to the mailbox+    Message MailboxMessage+  | -- | Sent in response to "close"+    Closed+  | -- | Sent immediately after every message. Unused.+    Ack+  | -- | Sent in response to "pong"+    Pong Int+  | -- | Sent by the server when it receives something from the client that it does not understand.+    Error+    { -- | Message explaining what the problem is+      errorMessage :: Text+      -- | The message that caused the problem.+    , original :: ClientMessage+    }+  deriving (Eq, Show)++instance FromJSON ServerMessage where+  parseJSON (Object v) = do+    t <- v .: "type"+    case t of+      "welcome" -> do+        welcome <- v .: "welcome"+        Welcome <$> (WelcomeMessage <$> welcome .:? "motd" <*> welcome .:? "error")+      "nameplates" -> do+        ns <- v .: "nameplates"+        Nameplates <$> sequence [ Nameplate <$> n .: "id" | n <- ns ]+      "allocated" -> Allocated <$> v .: "nameplate"+      "claimed" -> Claimed <$> v .: "mailbox"+      "released" -> pure Released+      "message" -> Message <$> (MailboxMessage <$> v .: "side" <*> v .: "phase" <*> v .:? "id" <*> v .: "body")+      "closed" -> pure Closed+      "ack" -> pure Ack+      "pong" -> Pong <$> v .: "pong"+      "error" -> Error <$> v .: "error" <*> v .: "orig"+      _ -> fail $ "Unrecognized wormhole message type: " <> t+  parseJSON unknown = typeMismatch "Message" unknown++instance ToJSON ServerMessage where+  toJSON (Welcome (WelcomeMessage motd' error')) =+    objectWithType "welcome"+    [ "welcome" .= object (catMaybes [ ("motd" .=) <$> motd'+                                     , ("error" .=) <$> error'+                                     ])+    ]+  toJSON (Nameplates nameplates') =+    objectWithType "nameplates" ["nameplates" .= [ object ["id" .= n] | n <- nameplates' ] ]+  toJSON (Allocated nameplate') =+    objectWithType "allocated" [ "nameplate" .= nameplate' ]+  toJSON (Claimed mailbox') =+    objectWithType "claimed" [ "mailbox" .= mailbox' ]+  toJSON Released = objectWithType "released" []+  toJSON (Message (MailboxMessage side' phase' id body')) =+    objectWithType "message"+    [ "phase" .= phase'+    , "side" .= side'+    , "body" .= body'+    , "id" .= id+    ]+  toJSON Closed = objectWithType "closed" []+  toJSON Ack = objectWithType "ack" []+  toJSON (Pong n) = objectWithType "pong" ["pong" .= n]+  toJSON (Error errorMsg orig) =+    objectWithType "error" [ "error" .= errorMsg+                           , "orig" .= orig+                           ]++-- | Create a JSON object with a "type" field.+--+-- Use this to construct objects for client and server messages.+objectWithType :: Text -> [Pair] -> Value+objectWithType typ pairs = object $ ("type" .= typ):pairs++-- | Identifier for a "nameplate".+--+-- A nameplate is a very short string that identifies one peer to another. Its+-- purpose is to allow peers to find each other without having to communicate+-- the 'Mailbox' identifier, which is generally too lengthy and cumbersome to+-- be easily shared between humans.+--+-- Typically, one peer will allocate a nameplate and then communicate it+-- out-of-band to the other peer.+newtype Nameplate = Nameplate Text deriving (Eq, Show, ToJSON, FromJSON)++-- | A phase in the peer-to-peer (aka "client") protocol.+--+-- Phases proceed in strict order: 'PakePhase', 'VersionPhase', then+-- many 'ApplicationPhase'.+data Phase+  = -- | Sent immediately on opening the mailbox.+    PakePhase+  | -- | Used to negotiate capabilities.+    VersionPhase+    -- | Reserved for application data. Messages with these phases will be+    -- delivered in numeric order.+  | ApplicationPhase Int+  deriving (Eq, Show)++-- | Get the name of the phase. Used to derive message keys.+phaseName :: Phase -> Text+phaseName PakePhase = "pake"+phaseName VersionPhase = "version"+phaseName (ApplicationPhase n) = show n+-- TODO: Add test to ensure this can be cleanly encoded & decoded to ASCII.++instance ToJSON Phase where+  toJSON = toJSON . phaseName++instance FromJSON Phase where+  parseJSON (String "pake") = pure PakePhase+  parseJSON (String "version") = pure VersionPhase+  parseJSON (String number) =+    let number' = toS number in+    case readMaybe number' of+      Just n -> pure (ApplicationPhase n)+      Nothing -> fail $ "Unrecognized phase: " <> number'+  parseJSON other = typeMismatch "Phase" other++-- | Identifier for a mailbox.+--+-- A mailbox is a shared access point between Magic Wormhole peers within the+-- same application (specified by 'AppID'). To get a mailbox, you must first+-- acquire a 'Nameplate' and then claim that nameplate for your side with+-- 'MagicWormhole.claim'.+--+-- A mailbox ID is defined in the+-- [spec](https://github.com/warner/magic-wormhole/blob/master/docs/server-protocol.md)+-- as a "large random string", but in practice is a 13 character, lower-case,+-- alpha-numeric string.+newtype Mailbox = Mailbox Text deriving (Eq, Show, ToJSON, FromJSON)++-- | The body of a Magic Wormhole message.+--+-- This can be any arbitrary bytestring that is sent to or received from a+-- wormhole peer.+newtype Body = Body ByteString deriving (Eq, Show)++instance ToJSON Body where+  toJSON (Body bytes) = toJSON (toS @ByteString @Text (convertToBase Base16 bytes))++instance FromJSON Body where+  parseJSON (String s) = either fail (pure . Body) (convertFromBase Base16 (toS @Text @ByteString s))+  parseJSON x = typeMismatch "Body" x++-- | A message sent from a rendezvous client to the server.+data ClientMessage+  = -- | Set the application ID and the "side" for the duration of the connection.+    Bind AppID Side+    -- | Get a list of all allocated nameplates.+  | List+    -- | Ask the server to allocate a nameplate+  | Allocate+    -- | Claim a nameplate.+  | Claim Nameplate+    -- | Release a claimed nameplate.+    --+    -- If no nameplate is provided, the server will attempt to release the+    -- nameplate claimed (via 'Claim') earlier in this connection.+  | Release (Maybe Nameplate)+    -- | Open a mailbox.+  | Open Mailbox+    -- | Send a message to an open mailbox. The message will be delivered to+    -- all connected clients that also have that mailbox open, including this+    -- one.+  | Add Phase Body+    -- | Close a mailbox. Since only one mailbox can be open at a time, if+    -- mailbox isn't specified, then close the open mailbox.+  | Close (Maybe Mailbox) (Maybe Mood)+    -- | Internal "ping". Response is 'Pong'. Used for testing.+  | Ping Int+  deriving (Eq, Show)++instance FromJSON ClientMessage where+  parseJSON (Object v) = do+    t <- v .: "type"+    case t of+      "bind" -> Bind <$> v .: "appid" <*> v .: "side"+      "list" -> pure List+      "allocate" -> pure Allocate+      "claim" -> Claim <$> v .: "nameplate"+      "release" -> Release <$> v .:? "nameplate"+      "open" -> Open <$> v .: "mailbox"+      "add" -> Add <$> v .: "phase" <*> v .: "body"+      "close" -> Close <$> v .:? "mailbox" <*> v .:? "mood"+      "ping" -> Ping <$> v .: "ping"+      _ -> fail $ "Unrecognized rendezvous client message type: " <> t+  parseJSON unknown = typeMismatch "Message" unknown++instance ToJSON ClientMessage where+  toJSON (Bind appID side') =+    objectWithType "bind"  [ "appid" .= appID+                           , "side" .= side'+                           ]+  toJSON List = objectWithType "list" []+  toJSON Allocate = objectWithType "allocate" []+  toJSON (Claim nameplate') = objectWithType "claim" [ "nameplate" .= nameplate' ]+  toJSON (Release nameplate') =+    objectWithType "release" $ case nameplate' of+                                 Nothing -> []+                                 Just n -> ["nameplate" .= n]+  toJSON (Open mailbox') = objectWithType "open" [ "mailbox" .= mailbox' ]+  toJSON (Add phase' body') = objectWithType "add"+    [ "phase" .= phase'+    , "body" .= body'+    ]+  toJSON (Close mailbox' mood') =+    objectWithType "close" $ catMaybes [ ("mailbox" .=) <$> mailbox'+                                       , ("mood" .=) <$> mood'+                                       ]+  toJSON (Ping n) = objectWithType "ping" [ "ping" .= n]++-- | Short string to identify the application. Clients must use the same+-- application ID if they wish to communicate with each other.+--+-- Recommendation is to use "$DNSNAME/$APPNAME", e.g.+-- the Python `wormhole` command-line tool uses+-- @lothar.com\/wormhole\/text-or-file-xfer@.+newtype AppID = AppID Text deriving (Eq, Show, FromJSON, ToJSON)++-- | Short string used to differentiate between echoes of our own messages and+-- real messages from other clients.+--+-- TODO: This needs to be cleanly encoded to ASCII, so update the type or+-- provide a smart constructor.+newtype Side = Side Text deriving (Eq, Show, FromJSON, ToJSON)++-- | Generate a random 'Side'+generateSide :: MonadRandom randomly => randomly Side+generateSide = do+  randomBytes <- getRandomBytes 5+  pure . Side . toS @ByteString . convertToBase Base16 $ (randomBytes :: ByteString)++-- | How the client feels. Reported by the client to the server at the end of+-- a wormhole session.+data Mood+  = -- | The client had a great session with its peer.+    Happy+    -- | The client never saw its peer.+  | Lonely+    -- | The client saw a peer it could not trust.+  | Scary+    -- | The client encountered some problem.+  | Errory deriving (Eq, Show)++instance ToJSON Mood where+  toJSON Happy = "happy"+  toJSON Lonely = "lonely"+  toJSON Scary = "scary"+  toJSON Errory = "errory"++instance FromJSON Mood where+  parseJSON (String s) =+    case s of+      "happy" -> pure Happy+      "lonely" -> pure Lonely+      "scary" -> pure Scary+      "errory" -> pure Errory+      _ -> fail $ "Unrecognized mood: " <> toS s+  parseJSON unknown = typeMismatch "Mood" unknown++-- | Identifier sent with every client message that is included in the+-- matching server responses.+newtype MessageID = MessageID Int16 deriving (Eq, Show, Hashable)++instance ToJSON MessageID where+  toJSON (MessageID n) = toJSON $ showHex n ""++instance FromJSON MessageID where+  parseJSON (String s) =+    case readHex (toS s) of+      [(n, _)] -> pure (MessageID n)+      _ -> fail $ "Could not parse MessageID: " <> toS s+  parseJSON unknown = typeMismatch "MessageID" unknown++-- XXX: It's possible we want another type that represents an *unsent*+-- message, which will not have a side and will not have message ID. We+-- currently do this using (Phase, Body) tuples.+-- | A message sent to a mailbox.+data MailboxMessage+  = MailboxMessage+    {+      -- | Which side sent the message. Might be our side.+      side :: Side+    , -- | Which phase of the client protocol we are in.+      phase :: Phase+      -- | An identifier for the message. Unused.+      --+      -- According to the protocol docs, this should always be set, but the+      -- Python server will happily mirror an absent 'id' field as 'null'.+    , messageID :: Maybe MessageID+    , -- | The body of the message. To be interpreted by the client protocol.+      body :: Body+    } deriving (Eq, Show)++-- | Message received on initial connection to the server.+data WelcomeMessage+  = WelcomeMessage+    { -- | A message to be displayed to users when they connect to the server+      motd :: Maybe Text+      -- | If present, the server does not want the client to proceed. Here's the reason why.+    , welcomeErrorMessage :: Maybe Text+    } deriving (Eq, Show)
+ src/MagicWormhole/Internal/Pake.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS_HADDOCK not-home #-}+-- |+-- Description : PAKE exchange for Magic Wormhole+--+-- Once a peer is found, and both sides have mailboxes open, the peers need to+-- generate a shared 'ClientProtocol.SessionKey' based on their shared password.+--+-- 'pakeExchange' has the logic for doing this.+module MagicWormhole.Internal.Pake+  ( pakeExchange+  , PakeError(..)+  -- * Exported for testing+  , spakeBytesToMessageBody+  , messageBodyToSpakeBytes+  ) where++import Protolude++import Control.Monad (fail)+import Crypto.Hash (SHA256(..))+import qualified Crypto.Spake2 as Spake2+import Crypto.Spake2.Group (Group(arbitraryElement))+import Crypto.Spake2.Groups (Ed25519(..))+import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON, ToJSON, (.=), object, Value(..), (.:))+import Data.Aeson.Types (typeMismatch)+import Data.ByteArray.Encoding (convertToBase, convertFromBase, Base(Base16))++import qualified MagicWormhole.Internal.Messages as Messages+import qualified MagicWormhole.Internal.ClientProtocol as ClientProtocol++-- | Exchange SPAKE2 keys with a Magic Wormhole peer.+--+-- Throws an 'Error' if we cannot parse the incoming message.+pakeExchange+  :: ClientProtocol.Connection -- ^ A connection to a peer+  -> Spake2.Password -- ^ The shared password. Construct with 'Spake2.makePassword'.+  -> IO ClientProtocol.SessionKey  -- ^ A key that can be used for the remainder of the session+pakeExchange conn password = do+  let protocol = wormholeSpakeProtocol (ClientProtocol.appID conn)+  result <- Spake2.spake2Exchange protocol password sendPakeMessage (atomically receivePakeMessage)+  case result of+    Left err -> throwIO (Error err)+    Right key -> pure (ClientProtocol.SessionKey key)+  where+    sendPakeMessage = ClientProtocol.send conn Messages.PakePhase . spakeBytesToMessageBody+    receivePakeMessage  = do+      -- This is kind of a fun approach, but it means that everyone else has+      -- to promise that they *don't* consume pake messages.+      msg <- ClientProtocol.receive conn+      unless (Messages.phase msg == Messages.PakePhase) retry+      pure $ messageBodyToSpakeBytes (Messages.body msg)++-- | The message we send to negotiate the shared session key.+newtype Spake2Message = Spake2Message { spake2Bytes :: ByteString } deriving (Eq, Show)++instance ToJSON Spake2Message where+  toJSON (Spake2Message msg) = object [ "pake_v1" .= toS @ByteString @Text (convertToBase Base16 msg) ]++instance FromJSON Spake2Message where+  parseJSON (Object msg) = do+    hexKey <- toS @Text @ByteString <$> msg .: "pake_v1"+    case convertFromBase Base16 hexKey of+      Left err -> fail err+      Right key -> pure $ Spake2Message key+  parseJSON unknown = typeMismatch "Spake2Message" unknown++-- | Encode the bytes generated by the SPAKE2 algorithm into a Magic Wormhole+-- message body.+spakeBytesToMessageBody :: ByteString -> Messages.Body+spakeBytesToMessageBody = Messages.Body . toS . Aeson.encode . Spake2Message++-- | Decode a Magic Wormhole message body into bytes that can be used as input+-- into the SPAKE2 algorithm.+messageBodyToSpakeBytes :: Messages.Body -> Either Text ByteString+messageBodyToSpakeBytes (Messages.Body bodyBytes) =+  bimap toS spake2Bytes . Aeson.eitherDecode . toS $ bodyBytes++-- | Construct a SPAKE2 protocol compatible with Magic Wormhole.+wormholeSpakeProtocol :: Messages.AppID -> Spake2Protocol+wormholeSpakeProtocol (Messages.AppID appID') =+  Spake2.makeSymmetricProtocol SHA256 Ed25519 blind sideID+  where+    blind = arbitraryElement Ed25519 ("symmetric" :: ByteString)+    sideID = Spake2.SideID (toS appID')++-- | The version of the SPAKE2 protocol used by Magic Wormhole.+type Spake2Protocol = Spake2.Protocol Ed25519 SHA256++-- | An error that occured during 'pakeExchange'.+newtype PakeError = Error (Spake2.MessageError Text) deriving (Eq, Show, Typeable)+instance Exception PakeError
+ src/MagicWormhole/Internal/Peer.hs view
@@ -0,0 +1,148 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | Interface for communicating with a Magic Wormhole peer.+--+-- Build on this to write an application that uses Magic Wormhole.+module MagicWormhole.Internal.Peer+  ( EncryptedConnection+  , withEncryptedConnection+  , sendMessage+  , receiveMessage+  ) where++import Protolude hiding (phase)++import Control.Concurrent.STM.TVar+  ( TVar+  , modifyTVar'+  , newTVar+  , readTVar+  )+import qualified Crypto.Spake2 as Spake2++import qualified MagicWormhole.Internal.ClientProtocol as ClientProtocol+import qualified MagicWormhole.Internal.Messages as Messages+import qualified MagicWormhole.Internal.Pake as Pake+import qualified MagicWormhole.Internal.Sequential as Sequential+import qualified MagicWormhole.Internal.Versions as Versions+++-- XXX: Lots of duplicated code sending JSON data. Either make a typeclass for+-- this sort of thing or at least sendJSON, receiveJSON.++-- TODO: I've been playing fast and loose with Text -> ByteString conversions+-- (grep for `toS`) for the details. The Python implementation occasionally+-- encodes as `ascii` rather than the expected `UTF-8`, so I need to be a bit+-- more careful.++-- | Establish an encrypted connection between peers.+--+-- Use this connection with 'withEncryptedConnection'.+establishEncryption :: ClientProtocol.Connection -> Spake2.Password -> IO EncryptedConnection+establishEncryption peer password = do+  key <- Pake.pakeExchange peer password+  void $ Versions.versionExchange peer key+  liftIO $ atomically $ newEncryptedConnection peer key++-- | Run an action that communicates with a Magic Wormhole peer through an+-- encrypted connection.+--+-- Does the "pake" and "version" exchanges necessary to negotiate an encrypted+-- connection and then runs the user-provided action. This action can then use+-- 'sendMessage' and 'receiveMessage' to send & receive messages from its peer.+--+-- Can throw:+--+--   * 'ClientProtocol.PeerError', when we receive nonsensical data from the other peer+--   * 'Pake.PakeError', when SPAKE2 cryptography fails+--   * 'Versions.VersionsError', when we cannot agree on shared capabilities (this can sometimes imply SPAKE2 cryptography failure)+withEncryptedConnection+  :: ClientProtocol.Connection  -- ^ Underlying to a peer. Get this with 'Rendezvous.open'.+  -> Spake2.Password  -- ^ The shared password that is the basis of the encryption. Construct with 'Spake2.makePassword'.+  -> (EncryptedConnection -> IO a)  -- ^ Action to perform with the encrypted connection.+  -> IO a  -- ^ The result of the action+withEncryptedConnection peer password action = do+  conn <- establishEncryption peer password+  runEncryptedConnection conn (action conn)+++-- | A Magic Wormhole peer-to-peer application session.+--+-- Construct one of these using 'withEncryptedConnection'.+--+-- You get one of these after you have found a peer, successfully negotatiated+-- a shared key, and verified that negotiation by exchanging versions. (Note+-- that this does not include the "verifying" step mentioned in+-- magic-wormhole's documentation, which is about a human being verifying the+-- correctness of the code).+--+-- All messages in this session, sent & received, are encrypted using keys+-- derived from this shared key.+data EncryptedConnection+  = EncryptedConnection+  { connection :: ClientProtocol.Connection+  , sharedKey :: ClientProtocol.SessionKey+  , inbound :: Sequential.Sequential Int (Messages.Phase, ClientProtocol.PlainText)+  , outbound :: TVar Int+  }++-- | Construct a new encrypted connection.+newEncryptedConnection :: ClientProtocol.Connection -> ClientProtocol.SessionKey -> STM EncryptedConnection+newEncryptedConnection conn sessionKey = EncryptedConnection conn sessionKey <$> Sequential.sequenceBy getAppRank firstPhase <*> newTVar firstPhase+  where+    getAppRank (phase, _) =+      case phase of+        Messages.PakePhase -> panic "Did not expect PakePhase. Expected application phase."+        Messages.VersionPhase -> panic "Did not expect VersionPhase. Expected application phase."+        (Messages.ApplicationPhase n) -> n++    -- | The rank of the first phase we expect to send, and the first phase we+    -- expect to receive. It is critically important that this number is+    -- agreed on between peers, otherwise, a peer will wait forever for, say,+    -- message 0, which the other side has cheerily sent as message 1.+    firstPhase = 0++-- | Take a successfully negotiated peer connection and run an action that+-- sends and receives encrypted messages.+--+-- Establish an encrypted connection using 'withEncryptedConnection'.+--+-- Use this to communicate with a Magic Wormhole peer.+--+-- Once you have the session, use 'sendMessage' to send encrypted messages to+-- the peer, and 'receiveMessage' to received decrypted messages.+runEncryptedConnection+  :: EncryptedConnection+  -> IO a+  -> IO a+runEncryptedConnection conn action = do+  result <- race readLoop action+  pure $ case result of+           Left _ -> panic "Cannot happen"+           Right r -> r+  where+    readLoop = forever $ do+      msg <- atomically $ ClientProtocol.receiveEncrypted (connection conn) (sharedKey conn)+      inserted <- atomically $ Sequential.insert (inbound conn) msg+      unless inserted $ throwIO (uncurry ClientProtocol.MessageOutOfOrder msg)++-- | Send an encrypted message to the peer.+--+-- Obtain an 'EncryptedConnection' with 'withEncryptedConnection'.+--+-- The message will be encrypted using a one-off key deriving from the shared+-- key.+sendMessage :: EncryptedConnection -> ClientProtocol.PlainText -> IO ()+sendMessage conn body = do+  i <- atomically bumpPhase+  ClientProtocol.sendEncrypted (connection conn) (sharedKey conn) (Messages.ApplicationPhase i) body+  where+    bumpPhase = do+      i <- readTVar (outbound conn)+      modifyTVar' (outbound conn) (+1)+      pure i++-- | Receive a decrypted message from the peer.+--+-- Obtain an 'EncryptedConnection' with 'withEncryptedConnection'.+receiveMessage :: EncryptedConnection -> STM ClientProtocol.PlainText+receiveMessage conn = snd <$> Sequential.next (inbound conn)
+ src/MagicWormhole/Internal/Rendezvous.hs view
@@ -0,0 +1,422 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}+-- | Interactions with a Magic Wormhole Rendezvous server.+--+-- Intended to be imported qualified, e.g.+-- ```+-- import qualified MagicWormhole.Internal.Rendezvous as Rendezvous+-- ```+module MagicWormhole.Internal.Rendezvous+  (+    -- * Specific RPCs+    ping+  , list+  , allocate+  , claim+  , release+  , open+  , close+    -- * Running a Rendezvous client+  , runClient+  , Session+    -- * Errors+  , ServerError(..)+  , ClientError(..)+  ) where++import Protolude hiding (list, phase)++import Control.Concurrent.STM+  ( TVar+  , newTVar+  , modifyTVar'+  , readTVar+  , writeTVar+  , TMVar+  , newEmptyTMVar+  , putTMVar+  , takeTMVar+  , tryPutTMVar+  , TQueue+  , newTQueue+  , readTQueue+  , writeTQueue+  )+import Data.Aeson (eitherDecode, encode)+import Data.Hashable (Hashable)+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import Data.String (String)+import qualified Network.Socket as Socket+import qualified Network.WebSockets as WS++import qualified MagicWormhole.Internal.ClientProtocol as ClientProtocol+import qualified MagicWormhole.Internal.Messages as Messages+import MagicWormhole.Internal.WebSockets (WebSocketEndpoint(..))++-- | Abstract type representing a Magic Wormhole session.+--+-- Use 'runClient' to get a 'Session' on the Magic Wormhole Rendezvous server.+-- Once you have a 'Session',+-- use 'ping', 'list', 'allocate', 'claim', 'release', 'open', and 'close'+-- to communicate with the Rendezvous server.+data Session+  = Session+  { connection :: WS.Connection+  , sessionAppID :: Messages.AppID -- ^ The 'AppID' of this running session+  , sessionSide :: Messages.Side -- ^ The 'Side' of this running session+  , pendingVar :: TVar (HashMap ResponseType (TMVar Messages.ServerMessage))+  , messageChan :: TQueue Messages.MailboxMessage+  , motd :: TMVar (Maybe Text)+  }++-- | Create a new 'Session'.+new :: WS.Connection -- ^ Active WebSocket connection to a Rendezvous Server.+    -> Messages.AppID+    -> Messages.Side+    -> STM Session  -- ^ Opaque 'Session' object.+new connection appID side+  = Session connection appID side+  <$> newTVar mempty+  <*> newTQueue+  <*> newEmptyTMVar++-- | Send a message to a Magic Wormhole Rendezvous server.+send :: Session -- ^ An active session. Get this using 'runClient'.+     -> Messages.ClientMessage -- ^ Message to send to the server.+     -> IO ()+send session msg = WS.sendBinaryData (connection session) (encode msg)++-- | Receive a message from a Magic Wormhole Rendezvous server.+-- Blocks until such a message exists.+receive :: Session -- ^ An active session. Get this using 'runClient'.+        -> IO Messages.ServerMessage -- ^ Next message from the server.+receive session = do+  msg <- WS.receiveData (connection session)+  either (throwIO . ParseError) pure (eitherDecode msg)++-- | Run a Magic Wormhole Rendezvous client. Use this to interact with a Magic Wormhole server.+--+-- Will throw a 'ServerError' if the server declares we are unwelcome.+runClient+  :: HasCallStack+  => WebSocketEndpoint -- ^ The websocket to connect to+  -> Messages.AppID -- ^ ID for your application (e.g. example.com/your-application)+  -> Messages.Side -- ^ Identifier for your side+  -> (Session -> IO a) -- ^ Action to perform inside the Magic Wormhole session+  -> IO a -- ^ The result of the action+runClient (WebSocketEndpoint host port path) appID side app =+  Socket.withSocketsDo . WS.runClient host port path $ \ws -> do+    session <- atomically $ new ws appID side+    (_, result) <- concurrently (readMessages session) (action ws session)+    pure result+  where+    action ws session = do+      bind session appID side+      app session `finally` WS.sendClose ws ("Connection closed connection" :: Text)++    -- | Read messages from the websocket forever, or until we fail to handle one.+    readMessages session = do+      -- We read the message from the channel and handle it (either by setting+      -- the RPC response or forwarding to the mailbox message queue) all in+      -- one transaction. This means that if an exception occurs, the message+      -- will remain in the channel.+      msg <- try $ receive session+      case msg of+        Left (WS.CloseRequest _ _) -> pass+        Left err -> throwIO err+        Right msg' -> do+          result <- atomically $ gotMessage session msg'+          case result of+            Just err -> throwIO err+            Nothing -> readMessages session++-- | Make a request to the rendezvous server.+--+-- Will throw a 'ClientError' if there's a problem.+rpc :: HasCallStack+    => Session -- ^ A Magic Wormhole session. Get one using 'runClient'.+    -> Messages.ClientMessage -- ^ The RPC to send. Will fail with an 'Error' if this is not a valid RPC.+    -> IO Messages.ServerMessage -- ^ The result of an RPC+rpc session req =+  case expectedResponse req of+    Nothing ->+      -- XXX: Pretty sure we can juggle things around at the type level+      -- to remove this check. (i.e. make a type for RPC requests).+      throwIO (NotAnRPC req)+    Just responseType -> do+      box <- atomically $ expectResponse responseType+      send session req+      response <- atomically $ waitForResponse session responseType box+      case response of+        Messages.Error reason original -> throwIO (BadRequest reason original)+        response' -> pure response'++  where+    -- | Tell the connection that we expect a response of the given type.+    --+    -- Will throw a 'ClientError' if we are already expecting a response of this type.+    expectResponse :: ResponseType -> STM (TMVar Messages.ServerMessage)+    expectResponse responseType = do+      pending <- readTVar (pendingVar session)+      case HashMap.lookup responseType pending of+        Nothing -> do+          box <- newEmptyTMVar+          writeTVar (pendingVar session) (HashMap.insert responseType box pending)+          pure box+        Just _ -> throwSTM (AlreadySent req)+++-- | Set the application ID and side for the rest of this connection.+--+-- The Rendezvous protocol doesn't have a response to @bind@, so there's no+-- way to tell if it has had its effect.+--+-- See https://github.com/warner/magic-wormhole/issues/261+bind :: HasCallStack => Session -> Messages.AppID -> Messages.Side -> IO ()+bind session appID side' = send session (Messages.Bind appID side')++-- | Ping the server.+--+-- This is an in-band ping, used mostly for testing. It is not necessary to+-- keep the connection alive.+--+-- Throws a 'ClientError' if the server rejects the message for any reason.+ping :: HasCallStack => Session -> Int -> IO Int+ping session n = do+  response <- rpc session (Messages.Ping n)+  case response of+    Messages.Pong n' -> pure n'+    unexpected -> unexpectedMessage (Messages.Ping n) unexpected++-- | List the nameplates on the server.+--+-- Throws a 'ClientError' if the server rejects the message for any reason.+list :: HasCallStack => Session -> IO [Messages.Nameplate]+list session = do+  response <- rpc session Messages.List+  case response of+    Messages.Nameplates nameplates -> pure nameplates+    unexpected -> unexpectedMessage Messages.List unexpected++-- | Allocate a nameplate on the server.+--+-- Throws a 'ClientError' if the server rejects the message for any reason.+allocate :: HasCallStack => Session -> IO Messages.Nameplate+allocate session = do+  response <- rpc session Messages.Allocate+  case response of+    Messages.Allocated nameplate -> pure nameplate+    unexpected -> unexpectedMessage Messages.Allocate unexpected++-- | Claim a nameplate on the server.+--+-- Throws a 'ClientError' if the server rejects the message for any reason.+claim :: HasCallStack => Session -> Messages.Nameplate -> IO Messages.Mailbox+claim session nameplate = do+  response <- rpc session (Messages.Claim nameplate)+  case response of+    Messages.Claimed mailbox -> pure mailbox+    unexpected -> unexpectedMessage (Messages.Claim nameplate) unexpected++-- | Release a nameplate on the server.+--+-- TODO: Document semantics around "optional" nameplate.+--+-- TODO: Make this impossible to call unless we have already claimed a+-- namespace.+--+-- Throws a 'ClientError' if the server rejects the message for any reason.+release :: HasCallStack => Session -> Maybe Messages.Nameplate -> IO ()+release session nameplate' = do+  response <- rpc session (Messages.Release nameplate')+  case response of+    Messages.Released -> pure ()+    unexpected -> unexpectedMessage (Messages.Release nameplate') unexpected++-- | Open a mailbox on the server.+--+-- If there's already a mailbox open, the server will send an error message.+-- In the current implementation, that error will arise in a strange and+-- unexpected place.+--+-- See https://github.com/warner/magic-wormhole/issues/261#issuecomment-343192449+open :: HasCallStack => Session -> Messages.Mailbox -> IO ClientProtocol.Connection+open session mailbox = do+  send session (Messages.Open mailbox)+  pure ClientProtocol.Connection { ClientProtocol.appID = sessionAppID session+                                 , ClientProtocol.ourSide = sessionSide session+                                 , ClientProtocol.send = add session+                                 , ClientProtocol.receive = readFromMailbox session+                                 }++-- | Close a mailbox on the server.+--+-- Throws a 'ClientError' if the server rejects the message for any reason.+close :: HasCallStack => Session -> Maybe Messages.Mailbox -> Maybe Messages.Mood -> IO ()+close session mailbox' mood' = do+  response <- rpc session (Messages.Close mailbox' mood')+  case response of+    Messages.Closed -> pure ()+    unexpected -> unexpectedMessage (Messages.Close mailbox' mood') unexpected++-- | Send a message to the open mailbox.+add :: HasCallStack => Session -> Messages.Phase -> Messages.Body -> IO ()+add session phase body = send session (Messages.Add phase body)++-- | Read a message from someone else from an open mailbox+--+-- Will block until we receive a message from someone who isn't us.+-- Specifically, a message with a different 'side' to us.+--+-- Will discard all messages that are from us.+readFromMailbox :: HasCallStack => Session -> STM Messages.MailboxMessage+readFromMailbox session = do+  msg <- readFromMailbox' session+  -- In the unlikely event that the other actual side has chosen the same side+  -- ID as us, this will loop forever.+  if Messages.side msg == sessionSide session+    then readFromMailbox session+    else pure msg++-- | Read a message from an open mailbox.+--+-- Will block if there's no message, or if we're in no state to receive+-- messages (e.g. no mailbox open).+readFromMailbox' :: HasCallStack => Session -> STM Messages.MailboxMessage+readFromMailbox' session = readTQueue (messageChan session)++-- | Called when an RPC receives a message as a response that does not match+-- the request.+--+-- As things are written, this should never happen, because @gotResponse@+-- makes sure we only ever populate the response placeholder with something+-- that matches.+--+-- TODO: Try to make this unnecessary.+unexpectedMessage :: HasCallStack => Messages.ClientMessage -> Messages.ServerMessage -> a+unexpectedMessage request response = panic $ "Unexpected message: " <> show response <> ", in response to: " <> show request++waitForResponse :: Session -> ResponseType -> TMVar Messages.ServerMessage -> STM Messages.ServerMessage+waitForResponse session responseType box = do+  response <- takeTMVar box+  modifyTVar' (pendingVar session) (HashMap.delete responseType)+  pure response++-- | Called when we have received a response from the server.+--+-- Tells anything waiting for the response that they can stop waiting now.+gotResponse :: Session -> ResponseType -> Messages.ServerMessage -> STM (Maybe ServerError)+gotResponse session responseType message = do+  pending <- readTVar (pendingVar session)+  case HashMap.lookup responseType pending of+    Nothing -> pure (Just (ResponseWithoutRequest message))+    Just box -> do+      -- TODO: This will block processing messages from the server (by+      -- retrying the transaction) if the box is already populated (i.e. if we+      -- are in the middle of processing another response of the same type--a+      -- rare circumstance). I don't think we want that, but I'm not sure what+      -- behavior we do want.+      putTMVar box message+      pure Nothing++-- | Called when we receive a message (possibly a response) from the server.+gotMessage :: Session -> Messages.ServerMessage -> STM (Maybe ServerError)+gotMessage session msg =+  case msg of+    Messages.Ack -> pure Nothing  -- Skip Ack, because there's no point in handling it.+    Messages.Welcome welcome -> handleWelcome welcome+    Messages.Error{Messages.errorMessage, Messages.original} ->+      case expectedResponse original of+        Nothing -> pure (Just (ErrorForNonRequest errorMessage original))+        Just responseType ->+          -- TODO: This not quite right, as messages that aren't requests+          -- (e.g. 'open') can generate errors.+          gotResponse session responseType msg+    Messages.Message mailboxMsg -> do+      writeTQueue (messageChan session) mailboxMsg+      pure Nothing+    Messages.Nameplates{} -> gotResponse session NameplatesResponse msg+    Messages.Allocated{} -> gotResponse session AllocatedResponse msg+    Messages.Claimed{} -> gotResponse session ClaimedResponse msg+    Messages.Released -> gotResponse session ReleasedResponse msg+    Messages.Closed -> gotResponse session ClosedResponse msg+    Messages.Pong{} -> gotResponse session PongResponse msg++  where+    handleWelcome welcome =+      case Messages.welcomeErrorMessage welcome of+        Just err -> pure (Just (Unwelcome err))+        Nothing -> do+          notYet <- tryPutTMVar (motd session) (Messages.motd welcome)+          if notYet+            then pure Nothing+            else pure (Just (UnexpectedMessage (Messages.Welcome welcome)))++-- | The type of a response.+--+-- This is used pretty much only to match responses with requests.+--+-- XXX: Duplication with ServerMessage?+data ResponseType+  = NameplatesResponse+  | AllocatedResponse+  | ClaimedResponse+  | ReleasedResponse+  | ClosedResponse+  | PongResponse+  deriving (Eq, Show, Generic, Hashable)++-- XXX: This expectResponse stuff feels off to me. I think we could do something better.+--+-- e.g.+-- - embed the response type in the ServerMessage value so we don't need to "specify" it twice+--   (once in the parser, once here)+-- - change the structure to have stricter types?+--   rather than a map of a type value to generic response box, have one box for each+--   request/response pair?++-- | Map 'ClientMessage' to a response. 'Nothing' means that we do not need a response.+expectedResponse :: Messages.ClientMessage -> Maybe ResponseType+expectedResponse Messages.Bind{} = Nothing+expectedResponse Messages.List = Just NameplatesResponse+expectedResponse Messages.Allocate = Just AllocatedResponse+expectedResponse Messages.Claim{} = Just ClaimedResponse+expectedResponse Messages.Release{} = Just ReleasedResponse+expectedResponse Messages.Open{} = Nothing+expectedResponse Messages.Add{} = Nothing+expectedResponse Messages.Close{} = Just ClosedResponse+expectedResponse Messages.Ping{} = Just PongResponse++-- | Error due to weirdness from the server.+data ServerError+  = -- | Server sent us a response for something that we hadn't requested.+    ResponseWithoutRequest Messages.ServerMessage+    -- | We were sent a message other than "Welcome" on connect, or a+    -- "Welcome" message at any other time.+  | UnexpectedMessage Messages.ServerMessage+    -- | We received an 'error' message for a message that's not expected to+    -- have a response.+  | ErrorForNonRequest Text Messages.ClientMessage+  -- | Clients are not welcome on the server right now.+  | Unwelcome Text+    -- | We couldn't understand the message from the server.+  | ParseError String+  deriving (Eq, Show, Typeable)++instance Exception ServerError++-- | Error caused by misusing the client.+data ClientError+  = -- | We tried to do an RPC while another RPC with the same response type+    -- was in flight. See warner/magic-wormhole#260 for details.+    AlreadySent Messages.ClientMessage+    -- | Tried to send a non-RPC as if it were an RPC (i.e. expecting a response).+  | NotAnRPC Messages.ClientMessage+    -- | We sent a message that the server could not understand.+  | BadRequest Text Messages.ClientMessage+  deriving (Eq, Show, Typeable)++instance Exception ClientError
+ src/MagicWormhole/Internal/Sequential.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | Helpers for processing messages in sequence.+module MagicWormhole.Internal.Sequential+  ( Sequential+  , sequenceBy+  , insert+  , next+  ) where++import Protolude++import Control.Concurrent.STM.TVar+  ( TVar+  , modifyTVar'+  , newTVar+  , readTVar+  )+import qualified Data.HashMap.Lazy as HashMap++-- | A thing that gets numbered items and then buffers them so you can read+-- them in order without gaps.+--+-- "counter" is an 'Enum' that is used to determine the ordering of the+-- elements, and "item" is the type of the items themselves.+data Sequential counter item+  = Sequential+  { -- | The current value of the counter. The next item must have this rank.+    current :: TVar counter+  , -- | Where we store the items that have arrived out of order. A priority+    -- queue might be a better choice.+    buffer :: TVar (HashMap.HashMap counter item)+  , -- | How to rank items. Each item has a "rank", which is an 'Enum'+    -- (specifically, a "counter"). Items are yielded in order, without gaps,+    -- by 'next'.+    rank :: item -> counter+  }++-- | Create a 'Sequential' value for a series of item.+sequenceBy+  :: (Hashable counter, Eq counter)+  => (a -> counter) -- ^ How to rank items+  -> counter -- ^ The expected rank of the first item+  -> STM (Sequential counter a)+sequenceBy rank' initial = Sequential <$> newTVar initial <*> newTVar mempty <*> pure rank'++-- | Insert an item into the sequence. It may only be drawn from the+-- sequence with 'next' when its counter is next one.+--+-- If the counter has already been past, don't insert it, since we'll never+-- reach it. Instead return 'False'.+insert+  :: (Ord counter, Enum counter, Hashable counter, Eq counter)+  => Sequential counter a+  -> a+  -> STM Bool+insert sequential msg = do+  cur <- readTVar (current sequential)+  let msgRank = rank sequential msg+  if msgRank < cur+    then pure False+    else do+    modifyTVar' (buffer sequential) (HashMap.insert (rank sequential msg) msg)+    pure True++-- | Get and remove the next item from the sequence. This will block until+-- there is an item with the exact rank we are expecting.+next+  :: (Enum counter, Eq counter, Hashable counter)+  => Sequential counter a  -- ^ How item are ordered in sequence+  -> STM a  -- ^ The next item+next thingy = do+  i <- readTVar (current thingy)+  q <- readTVar (buffer thingy)+  case HashMap.lookup i q of+    Nothing -> retry+    Just msg -> do+      modifyTVar' (current thingy) succ+      modifyTVar' (buffer thingy) (HashMap.delete i)+      pure msg
+ src/MagicWormhole/Internal/Versions.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_HADDOCK not-home #-}+-- |+-- Description : Peer version exchange+--+-- Once a shared 'ClientProtocol.SessionKey' has been negotiated, the peers+-- need to confirm that they have the same key. They do this with+-- 'versionExchange'.+module MagicWormhole.Internal.Versions+    ( versionExchange+    , Versions(..)+    , VersionsError(..)+    ) where++import Protolude hiding (phase)++import Data.Aeson (FromJSON, ToJSON, (.=), object, Value(..), (.:))+import Data.Aeson.Types (typeMismatch)+import qualified Data.Aeson as Aeson+import Data.String (String)++import qualified MagicWormhole.Internal.ClientProtocol as ClientProtocol+import qualified MagicWormhole.Internal.Messages as Messages++-- NOTE: Versions+-- ~~~~~~~~~~~~~~+--+-- Magic Wormhole Python implementation sends the following as the 'version' phase:+--     {"app_versions": {}}+--+-- The idea is that /some time in the future/ this will be used to indicate+-- capabilities of peers. At present, it is unused, save as a confirmation+-- that the SPAKE2 exchange worked.++-- | Exchange version information with a Magic Wormhole peer.+--+-- Can throw an 'Error' if something goes wrong.+versionExchange+  :: ClientProtocol.Connection -- ^ A connection to a peer+  -> ClientProtocol.SessionKey -- ^ A shared session key. Obtain this via 'MagicWormhole.Internal.Pake.pakeExchange'.+  -> IO Versions  -- ^ Shared version information+versionExchange conn key = do+  (_, theirVersions) <- concurrently sendVersion (atomically receiveVersion)+  if theirVersions /= Versions then throwIO VersionMismatch else pure Versions+  where+    sendVersion = ClientProtocol.sendEncrypted conn key Messages.VersionPhase (ClientProtocol.PlainText (toS (Aeson.encode Versions)))+    receiveVersion = do+      (phase, ClientProtocol.PlainText plaintext) <- ClientProtocol.receiveEncrypted conn key+      unless (phase == Messages.VersionPhase) retry+      either (throwSTM . ParseError) pure $ Aeson.eitherDecode (toS plaintext)++-- | Information about the versions supported by this Magic Wormhole client.+--+-- There are no extant Magic Wormhole implementations that send any meaningful+-- information in their versions message, so this is just a single-valued+-- type.+data Versions = Versions deriving (Eq, Show)++instance ToJSON Versions where+  toJSON _ = object ["app_versions" .= object []]++instance FromJSON Versions where+  parseJSON (Object v) = do+    -- Make sure there's an object in the "app_versions" key and abort if not.+    (Object _versions) <- v .: "app_versions"+    pure Versions+  parseJSON unknown = typeMismatch "Versions" unknown++-- | An error occurred during 'versionExchange'.+data VersionsError+  -- | We could not interpret the other side's version information+  = ParseError String+  -- | The other side sent us version information, but it does not match ours,+  -- so we cannot proceed.+  | VersionMismatch+  deriving (Eq, Show, Typeable)++instance Exception VersionsError
+ src/MagicWormhole/Internal/WebSockets.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_HADDOCK not-home #-}+-- | Help interaction with websockets.+module MagicWormhole.Internal.WebSockets+  ( WebSocketEndpoint(..)+  , parseWebSocketEndpoint+  , uriToWebSocketEndpoint+  , Hostname+  , Port+  , Path+  ) where++import Protolude++import Data.String (String)+import Network.URI (URI(..), URIAuth(..), parseURI)++-- | Endpoint for a websocket connection.+--+-- Construct directly or with 'parseWebSocketEndpoint'.+data WebSocketEndpoint = WebSocketEndpoint Hostname Port Path deriving (Eq, Show)++-- | Host name for a websocket endpoint. e.g. @example.com@.+type Hostname = String++-- | Port number for a websocket endpoint. e.g. @80@+type Port = Int++-- | Path to a websocket endpoint. e.g. @\/v1\/foo@+type Path = String++-- | Turn a 'URI' into a 'WebSocketEndpoint', if we can.+--+-- Requires that the URI has an authority (i.e. host & port).+-- Discards information from scheme, query, and fragment.+uriToWebSocketEndpoint :: URI -> Maybe WebSocketEndpoint+uriToWebSocketEndpoint uri = do+  authority <- uriAuthority uri+  port <- case uriPort authority of+            "" -> empty+            _:rest -> readMaybe rest+  pure $ WebSocketEndpoint (uriRegName authority) port (uriPath uri)++-- | Parse a 'WebSocketEndpoint'.+parseWebSocketEndpoint :: String -> Maybe WebSocketEndpoint+parseWebSocketEndpoint = uriToWebSocketEndpoint <=< parseURI
+ tests/ClientProtocol.hs view
@@ -0,0 +1,25 @@+-- | Tests for the "client protocol".+module ClientProtocol (tests) where++import Protolude++import Hedgehog (forAll, property, (===))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import qualified MagicWormhole.Internal.ClientProtocol as ClientProtocol+++tests :: IO TestTree+tests = pure $ testGroup "ClientProtocol"+  [ testProperty "SecretBox encryption roundtrips" $ property $ do+      purpose <- forAll $ Gen.bytes (Range.linear 0 10)+      secret <- forAll $ Gen.bytes (Range.linear 0 10)+      let key = ClientProtocol.deriveKey (ClientProtocol.SessionKey secret) purpose+      plaintext <- forAll $ Gen.bytes (Range.linear 1 256)+      ciphertext <- liftIO $ ClientProtocol.encrypt key (ClientProtocol.PlainText plaintext)+      let decrypted = ClientProtocol.decrypt key ciphertext+      decrypted === Right (ClientProtocol.PlainText plaintext)+  ]
+ tests/Generator.hs view
@@ -0,0 +1,99 @@+-- | Domain-specific Hedgehog generators.+--+-- These are used in multiple test modules, so broken out here for clearer re-use.+module Generator+  ( clientMessages+  , serverMessages+  , appIDs+  , phases+  , sides+  ) where++import Protolude++import Hedgehog (MonadGen(..))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import MagicWormhole.Internal.Messages+  ( ClientMessage(..)+  , ServerMessage(..)+  , MailboxMessage(..)+  , WelcomeMessage(..)+  , AppID(..)+  , Side(..)+  , MessageID(..)+  , Phase(..)+  , Body(..)+  , Nameplate(..)+  , Mailbox(..)+  , Mood(..)+  )++clientMessages :: MonadGen m => m ClientMessage+clientMessages = Gen.choice+  [ Bind <$> appIDs <*> sides+  , pure List+  , pure Allocate+  , Claim <$> genNameplates+  , Release <$> Gen.maybe genNameplates+  , Open <$> mailboxes+  , Add <$> phases <*> bodies+  , Close <$> Gen.maybe mailboxes <*> Gen.maybe moods+  , Ping <$> Gen.int Range.linearBounded+  ]++messageIDs :: MonadGen m => m MessageID+messageIDs = MessageID <$> Gen.int16 (Range.linear 0 maxBound)++appIDs :: MonadGen m => m AppID+appIDs = AppID <$> Gen.choice [ Gen.text (Range.linear 0 100) Gen.unicode+                              , Gen.element+                                [ "lothar.com/wormhole/text-or-file-xfer"+                                , "tahoe-lafs.org/tahoe-lafs/v1"+                                ]+                              ]++sides :: MonadGen m => m Side+sides = Side <$> Gen.text (Range.linear 0 10) Gen.hexit++phases :: MonadGen m => m Phase+phases = Gen.choice+  [ pure PakePhase+  , pure VersionPhase+  , ApplicationPhase <$> Gen.int (Range.linear 0 maxBound)+  ]++bodies :: MonadGen m => m Body+bodies = Body <$> Gen.bytes (Range.linear 0 1024)++genNameplates :: MonadGen m => m Nameplate+genNameplates = Nameplate <$> Gen.text (Range.linear 0 10) Gen.unicode++mailboxes :: MonadGen m => m Mailbox+mailboxes = Mailbox <$> Gen.text (Range.singleton 13) alphaNum+  where+    alphaNum = Gen.element "abcdefghijklmnopqrstuvwxyz09123456789"++moods :: MonadGen m => m Mood+moods = Gen.element [ Happy, Lonely, Scary, Errory ]++serverMessages :: MonadGen m => m ServerMessage+serverMessages = Gen.choice+  [ Welcome <$> welcomeMessages+  , Nameplates <$> Gen.list (Range.linear 0 10) genNameplates+  , Allocated <$> genNameplates+  , Claimed <$> mailboxes+  , pure Released+  , Message <$> mailboxMessages+  , pure Closed+  , pure Ack+  , Pong <$> Gen.int Range.linearBounded+  , Error <$> Gen.text (Range.linear 0 100) Gen.unicode <*> clientMessages+  ]++mailboxMessages :: MonadGen m => m MailboxMessage+mailboxMessages = MailboxMessage <$> sides <*> phases <*> Gen.maybe messageIDs <*> bodies++welcomeMessages :: MonadGen m => m WelcomeMessage+welcomeMessages = WelcomeMessage <$> Gen.maybe (Gen.text (Range.linear 0 1024) Gen.unicode) <*> Gen.maybe (Gen.text (Range.linear 0 1024) Gen.unicode)
+ tests/Integration.hs view
@@ -0,0 +1,172 @@+-- | Test our interoperability with Python Magic Wormhole.+--+-- Some notes:+-- * it is the developer's / CI server's responsibility to provide a Python installation and a magic-wormhole installation+-- * we currently make no attempt to handle different versions of magic-wormhole+-- * if Python is not present, these tests will pass+-- * if magic-wormhole is not present, these tests will pass+module Integration (tests) where++import Protolude hiding (phase, stdin, stdout)++import Control.Concurrent.STM.TChan+  ( newTChan+  , readTChan+  , writeTChan+  )+import qualified Crypto.Saltine.Class as Saltine+import qualified Crypto.Saltine.Core.SecretBox as SecretBox+import qualified Data.Aeson as Aeson+import Data.ByteArray.Encoding (convertFromBase, convertToBase, Base(Base16))+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import Data.String (String)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified System.IO as IO+import qualified System.Process as Process+import Test.Tasty (TestTree)+import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)++import qualified Crypto.Spake2 as Spake2+import qualified MagicWormhole.Internal.ClientProtocol as ClientProtocol+import qualified MagicWormhole.Internal.Messages as Messages+import qualified MagicWormhole.Internal.Pake as Pake+import qualified MagicWormhole.Internal.Versions as Versions++import qualified Paths_magic_wormhole++tests :: IO TestTree+tests = testSpec "Integration" $ do+  describe "SPAKE2 and version exchange" $ do+    it "Generates the same SPAKE2 session key as the python-spake2 library" $ do+      let appID = "jml.io/haskell-magic-wormhole-test"+      let password = "mellon"+      let password' = Spake2.makePassword password+      let ourSide = "treebeard"+      let theirSide = "saruman"+      interactWithPython "tests/python/spake2_exchange.py"+        [ "--app-id=" <> toS appID+        , "--code=" <> toS password+        , "--side=" <> theirSide+        ] $ \stdin stdout -> do+          ClientProtocol.SessionKey sessionKey <- withConnection (Messages.AppID appID) (Messages.Side ourSide) stdin stdout $ \conn ->+            Pake.pakeExchange conn password'+          -- Calculate the shared key+          theirSpakeKey <- ByteString.hGetLine stdout+          theirSpakeKey `shouldBe` convertToBase Base16 sessionKey++    it "Derives the same phase keys" $ do+      fakeSpakeKey <- Gen.sample $ Gen.bytes (Range.singleton 32)+      let side = "treebeard"+      let phase = Messages.VersionPhase+      let ourPhaseKey = ClientProtocol.deriveKey+                        (ClientProtocol.SessionKey fakeSpakeKey)+                        (ClientProtocol.phasePurpose (Messages.Side side) phase)+      interactWithPython "tests/python/derive_phase_key.py"+        [ "--spake-key=" <> toS (convertToBase Base16 fakeSpakeKey :: ByteString)+        , "--side=" <> toS side+        , "--phase=" <> toS (Messages.phaseName phase)+        ] $ \_stdin stdout -> do+          theirPhaseKey <- ByteString.hGetLine stdout+          theirPhaseKey `shouldBe` convertToBase Base16 (Saltine.encode ourPhaseKey)++    it "Works with our hacked-together Python implementation" $ do+      let appID = "jml.io/haskell-magic-wormhole-test"+      let ourSide = "treebeard" :: Text+      let otherSide = "saruman" :: Text+      let password = "mellon"+      let password' = Spake2.makePassword password+      interactWithPython "tests/python/version_exchange.py"+        [ "--app-id=" <> toS appID+        , "--side=" <> toS otherSide+        , "--code=" <> toS password+        ] $ \stdin stdout -> do+          versions <- withConnection (Messages.AppID appID) (Messages.Side ourSide) stdin stdout $ \conn -> do+            sessionKey <- Pake.pakeExchange conn password'+            Versions.versionExchange conn sessionKey+          versions `shouldBe` Versions.Versions++  describe "NaCL interoperability" $+    it "Swaps messages with Python" $ do+      key <- SecretBox.newKey+      nonce <- SecretBox.newNonce+      interactWithPython "tests/python/nacl_exchange.py"+        [ "--key=" <> toS (convertToBase Base16 (Saltine.encode key) :: ByteString)+        , "--nonce=" <> toS (convertToBase Base16 (Saltine.encode nonce) :: ByteString)+        ] $ \stdin stdout -> do+          let message = ClientProtocol.PlainText "Hello world!"+          ClientProtocol.CipherText encryptedByUs <- ClientProtocol.encrypt key message+          Char8.hPutStrLn stdin (convertToBase Base16 encryptedByUs :: ByteString)+          decryptedByPython <- ByteString.hGetLine stdout+          ClientProtocol.PlainText decryptedByPython `shouldBe` message+          encryptedByPython <- ByteString.hGetLine stdout+          let Right encryptedBytes = convertFromBase Base16 encryptedByPython+          let Right decryptedByUs = ClientProtocol.decrypt key (ClientProtocol.CipherText encryptedBytes)+          decryptedByUs `shouldBe` message+++-- | Run a Python script and interact with it by sending stuff to its stdin+-- and reading from its stdout using a line-based protocol.+--+-- The Python process's stderr will inherit from this one, so we get Python+-- stack traces in our test runner output. The interaction won't terminate+-- until the Python process does, so that we can get full output from it,+-- especially in the case of errors.+interactWithPython+  :: FilePath -- ^ Name of the script to run+  -> [String] -- ^ Arguments to the script+  -> (Handle -> Handle -> IO a)  -- ^ Interaction with the script, params are stdin & stdout.+  -> IO a  -- ^ Result of the interaction.+interactWithPython name args action = do+  scriptExe <- Paths_magic_wormhole.getDataFileName name+  let testScript = (Process.proc "python" (scriptExe:args))+                   { Process.std_in = Process.CreatePipe+                   , Process.std_out = Process.CreatePipe+                   , Process.std_err = Process.Inherit+                   }+  Process.withCreateProcess testScript $+    \(Just stdin) (Just stdout) _stderr ph -> do+      IO.hSetBuffering stdin IO.LineBuffering+      IO.hSetBuffering stdout IO.LineBuffering+      IO.hSetBuffering stderr IO.LineBuffering+      action stdin stdout `finally` Process.waitForProcess ph++withConnection :: Messages.AppID -> Messages.Side -> Handle -> Handle -> (ClientProtocol.Connection -> IO a) -> IO a+withConnection appID ourSide stdin stdout action = do+  inChan <- atomically newTChan+  let connection = ClientProtocol.Connection+                   { ClientProtocol.appID = appID+                   , ClientProtocol.ourSide = ourSide+                   , ClientProtocol.send = send+                   , ClientProtocol.receive = readTChan inChan+                   }+  result <- race (receiveForever inChan) (action connection)+  case result of+    Left err -> panic ("Couldn't read messages: " <> show @Text err)+    Right r -> pure r+  where+    send phase body =+      sendMailboxMessage stdin Messages.MailboxMessage { Messages.phase = phase+                                                       , Messages.side = ourSide+                                                       , Messages.body = body+                                                       , Messages.messageID = Nothing+                                                       }+    receiveForever inChan = forever $ do+      msg <- readMailboxMessage stdout+      atomically $ writeTChan inChan msg++readMailboxMessage :: HasCallStack => Handle -> IO Messages.MailboxMessage+readMailboxMessage h = do+  line <- ByteString.hGetLine h+  case Aeson.eitherDecode (toS line) of+    Left err -> do+      hPutStrLn stderr $ "Could not decode line: " <> line+      panic (toS err)+    Right (Messages.Message result) -> pure result+    Right other -> do+      hPutStrLn @Text stderr $ "Decoded line to non-MailboxMessage: " <> show other+      panic (show other)++sendMailboxMessage :: HasCallStack => Handle -> Messages.MailboxMessage -> IO ()+sendMailboxMessage h msg = hPutStrLn h (Aeson.encode (Messages.Message msg))
+ tests/Messages.hs view
@@ -0,0 +1,21 @@+-- | Tests for serializing and deserializing messages.+module Messages (tests) where++import Protolude++import Data.Aeson (encode, eitherDecode)+import Hedgehog (forAll, property, tripping)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import qualified Generator++tests :: IO TestTree+tests = pure $ testGroup "Messages"+  [ testProperty "client messages roundtrip" $ property $ do+      x <- forAll Generator.clientMessages+      tripping x encode eitherDecode+  , testProperty "server messages roundtrip" $ property $ do+      x <- forAll Generator.serverMessages+      tripping x encode eitherDecode+  ]
+ tests/Pake.hs view
@@ -0,0 +1,19 @@+module Pake (tests) where++import Protolude hiding (phase)++import Hedgehog (forAll, property, tripping)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import qualified MagicWormhole.Internal.Pake as Pake+++tests :: IO TestTree+tests = pure $ testGroup "Pake"+  [ testProperty "SPAKE2 messages roundtrip" $ property $ do+      element <- forAll $ Gen.bytes (Range.singleton 32)+      tripping element Pake.spakeBytesToMessageBody Pake.messageBodyToSpakeBytes+  ]
+ tests/Sequential.hs view
@@ -0,0 +1,32 @@+-- | Tests for sequential sort of messages.+module Sequential (tests) where++import Protolude++import Hedgehog (forAll, property, (===))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import qualified MagicWormhole.Internal.Sequential as Sequential++tests :: IO TestTree+tests = pure $ testGroup "Sequential"+  [ testProperty "exhausts items in order" $ property $ do+      -- Sequential with an arbitrary start point that gets the rank from the+      -- first element of a tuple.+      start <- forAll (Gen.integral (Range.linear 0 100))+      sequential <- liftIO (atomically (Sequential.sequenceBy fst start))+      -- An arbitrary list of messages...+      messages <- forAll (Gen.list (Range.linear 0 100)  (Gen.text (Range.linear 0 100) Gen.unicode))+      -- ... ranked from our arbitrary start...+      let allMessages = zip [start..start+length messages] messages+      -- ... in an arbitrary order.+      shuffled <- forAll $ Gen.shuffle allMessages+      -- Insert them all.+      traverse_ (liftIO . atomically . Sequential.insert sequential) shuffled+      -- Pull them all out.+      items <- replicateM (length messages) (liftIO . atomically $ Sequential.next sequential)+      items === allMessages+  ]
+ tests/Tasty.hs view
@@ -0,0 +1,23 @@+module Main (main) where++import Protolude++import Test.Tasty (defaultMain, testGroup)++import qualified ClientProtocol+import qualified Integration+import qualified Messages+import qualified Sequential+import qualified WebSockets++main :: IO ()+main = sequence tests >>= defaultMain . testGroup "MagicWormhole"+  where+    tests =+      [ ClientProtocol.tests+      , Messages.tests+      , Sequential.tests+      , WebSockets.tests+        -- Put these at the end because they are slowest.+      , Integration.tests+      ]
+ tests/WebSockets.hs view
@@ -0,0 +1,24 @@+module WebSockets (tests) where++import Protolude++import Test.Tasty (TestTree)+import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)++import MagicWormhole.Internal.WebSockets+  ( WebSocketEndpoint(..)+  , parseWebSocketEndpoint+  )++tests :: IO TestTree+tests = testSpec "WebSockets" $+  describe "parser" $ do+    it "parses normal URLs" $ do+      let example = "ws://foo:80/bar"+      parseWebSocketEndpoint example `shouldBe` Just (WebSocketEndpoint "foo" 80 "/bar")+    it "ignores scheme, query, and fragment" $ do+      let example = "http://foo:80/bar?s=what#qux"+      parseWebSocketEndpoint example `shouldBe` Just (WebSocketEndpoint "foo" 80 "/bar")+    it "fails without a port" $ do+      let example = "http://foo/bar"+      parseWebSocketEndpoint example `shouldBe` Nothing
+ tests/python/derive_phase_key.py view
@@ -0,0 +1,29 @@+#!/usr/bin/python+"""Derive a one-off key for NaCl given a SPAKE2 key."""++import argparse+import sys++from wormhole._key import derive_phase_key+from wormhole import util+++def main():+    parser = argparse.ArgumentParser(prog='version_exchange')+    parser.add_argument(+        '--spake-key', dest='spake_key', type=unicode,+        help='SPAKE2 key to generate the one-off key, hex-encoded')+    parser.add_argument(+        '--side', dest='side', type=unicode,+        help='Identifier for this side of the exchange')+    parser.add_argument(+        '--phase', dest='phase', type=unicode,+        help='The phase of the message we need a one-off key for')+    params = parser.parse_args(sys.argv[1:])+    key = derive_phase_key(+        util.hexstr_to_bytes(params.spake_key), params.side, params.phase)+    print util.bytes_to_hexstr(key)+++if __name__ == '__main__':+    main()
+ tests/python/nacl_exchange.py view
@@ -0,0 +1,50 @@+"""Decrypt and then re-encrypt a message using NaCl."""++import attr+import argparse+import sys++from nacl.secret import SecretBox+from wormhole import util+++def main():+    parser = argparse.ArgumentParser(prog='nacl')+    parser.add_argument(+        '--key', dest='key', type=unicode,+        help='NaCl key for secret box message, hex-encoded')+    parser.add_argument(+        '--nonce', dest='nonce', type=unicode,+        help='NaCl nonce for secret box message, hex-encoded')+    params = parser.parse_args(sys.argv[1:])+    run_exchange(+        Transport(input_stream=sys.stdin, output_stream=sys.stdout),+        util.hexstr_to_bytes(params.key), util.hexstr_to_bytes(params.nonce))+++def run_exchange(transport, key, nonce):+    box = SecretBox(key)+    line = transport.receive_line()+    decrypted = box.decrypt(util.hexstr_to_bytes(line))+    transport.send_line(decrypted)+    encrypted = util.bytes_to_hexstr(box.encrypt(decrypted, nonce))+    transport.send_line(encrypted)+++@attr.s+class Transport(object):+    # XXX: Duplicated with version_exchange.py+    input_stream = attr.ib()+    output_stream = attr.ib()++    def send_line(self, line):+        self.output_stream.write(line.rstrip().encode('utf8'))+        self.output_stream.write('\n')+        self.output_stream.flush()++    def receive_line(self):+        return self.input_stream.readline().strip().decode('utf8')+++if __name__ == '__main__':+    main()
+ tests/python/spake2_exchange.py view
@@ -0,0 +1,94 @@+#!/usr/bin/python+"""Exchange SPAKE2 keys and print out the session key.++This does the ``pake`` phase of the magic-wormhole client over stdin and+stdout. Once the SPAKE2 exchange is done, it prints the session key.++It sends its side of the exchange first and then expects the other side's.++The logic is a best-effort attempt to reproduce magic-wormhole's own. It might+be wrong.+"""+import argparse+import attr+import json+import sys++try:+    import wormhole+except ImportError as e:+    print "Could not find Magic Wormhole: %s" % (e,)+    sys.exit(0)++from wormhole import util+from spake2 import SPAKE2_Symmetric++wormhole  # Be still, pyflakes+++def main():+    parser = argparse.ArgumentParser(prog='spake2_exchange')+    parser.add_argument(+        '--code', dest='code', type=unicode,+        help='Password to use to connect to other side')+    parser.add_argument(+        '--side', dest='side', type=unicode,+        help='Identifier for this side of the exchange')+    parser.add_argument(+        '--app-id', dest='app_id', type=unicode,+        help='Identifier for the application')+    params = parser.parse_args(sys.argv[1:])+    transport = Transport(input_stream=sys.stdin, output_stream=sys.stdout)+    run_exchange(transport, params.code, params.app_id, params.side)+++def run_exchange(transport, code, app_id, side):+    # Send the SPAKE2 message+    spake = SPAKE2_Symmetric(+        util.to_bytes(code), idSymmetric=util.to_bytes(app_id))+    outbound = spake.start()+    transport.send_json({+        'phase': u'pake',+        'body': util.bytes_to_hexstr(+            util.dict_to_bytes({+                'pake_v1': util.bytes_to_hexstr(outbound),+            })+        ),+        'side': side,+        'type': 'message',+    })++    # Receive SPAKE2 message+    pake_msg = transport.receive_json()+    inbound = util.hexstr_to_bytes(+        util.bytes_to_dict(+            util.hexstr_to_bytes(pake_msg['body'])+        )['pake_v1']+    )+    spake_key = spake.finish(inbound)+    transport.send_line(util.bytes_to_hexstr(spake_key))+++@attr.s+class Transport(object):+    # XXX: Duplicated with version_exchange.py+    input_stream = attr.ib()+    output_stream = attr.ib()++    def send_line(self, line):+        self.output_stream.write(line.rstrip().encode('utf8'))+        self.output_stream.write('\n')+        self.output_stream.flush()++    def send_json(self, json_value):+        self.send_line(json.dumps(json_value))++    def receive_line(self):+        return self.input_stream.readline().strip().decode('utf8')++    def receive_json(self):+        return json.loads(self.receive_line())+++if __name__ == '__main__':+    main()
+ tests/python/version_exchange.py view
@@ -0,0 +1,119 @@+#!/usr/bin/python+"""Exchange SPAKE2 keys and versions.++This is a fake magic-wormhole client that receives messages from STDIN and+sends them on STDOUT. Each 'message' is a JSON value terminated by a newline.++It handles the following messages in order:++1. SEND `pake` - mailbox message containing our SPAKE2 info+2. RECEIVE `pake` - mailbox message with the other side's SPAKE2 info+3. SEND `version` - mailbox message containing our version information,+   encrypted with the negotiated SPAKE2 info+4. RECEIVE `version` - mailbox message containing their version information,+   encrypted with the negotiated SPAKE2 info+"""+import argparse+import attr+import json+import sys++try:+    import wormhole+except ImportError as e:+    print "Could not find Magic Wormhole: %s" % (e,)+    sys.exit(0)++from wormhole._key import decrypt_data, encrypt_data, derive_phase_key+from wormhole import util+from spake2 import SPAKE2_Symmetric++wormhole  # Be still, pyflakes+++def main():+    parser = argparse.ArgumentParser(prog='version_exchange')+    parser.add_argument(+        '--code', dest='code', type=unicode,+        help='Password to use to connect to other side')+    parser.add_argument(+        '--side', dest='side', type=unicode,+        help='Identifier for this side of the exchange')+    parser.add_argument(+        '--app-id', dest='app_id', type=unicode,+        help='Identifier for the application')+    params = parser.parse_args(sys.argv[1:])+    transport = Transport(input_stream=sys.stdin, output_stream=sys.stdout)+    run_exchange(transport, params.code, params.app_id, params.side)+++def run_exchange(transport, code, app_id, side):+    # Send the SPAKE2 message+    spake = SPAKE2_Symmetric(+        util.to_bytes(code), idSymmetric=util.to_bytes(app_id))+    outbound = spake.start()+    transport.send_json({+        'phase': u'pake',+        'body': util.bytes_to_hexstr(+            util.dict_to_bytes({+                'pake_v1': util.bytes_to_hexstr(outbound),+            })+        ),+        'side': side,+        'type': 'message',+    })++    # Receive SPAKE2 message+    pake_msg = transport.receive_json()+    inbound = util.hexstr_to_bytes(+        util.bytes_to_dict(+            util.hexstr_to_bytes(pake_msg['body'])+        )['pake_v1']+    )+    spake_key = spake.finish(inbound)++    # Send the versions message+    version_phase = u'version'+    transport.send_json({+        'phase': version_phase,+        'body': util.bytes_to_hexstr(+            encrypt_data(+                derive_phase_key(spake_key, side, version_phase),+                util.dict_to_bytes({'app_versions': {}})+            )+        ),+        'side': side,+        'type': 'message',+    })++    # Receive the versions message+    versions = transport.receive_json()+    their_versions = util.bytes_to_dict(+        decrypt_data(+            derive_phase_key(spake_key, versions['side'], versions['phase']),+            util.hexstr_to_bytes(+                versions['body']+            ),+        ),+    )+    return their_versions+++@attr.s+class Transport(object):+    # XXX: Duplicated with spake2_exchange.py+    input_stream = attr.ib()+    output_stream = attr.ib()++    def send_json(self, json_value):+        self.output_stream.write(json.dumps(json_value))+        self.output_stream.write('\n')+        self.output_stream.flush()++    def receive_json(self):+        line = self.input_stream.readline()+        return json.loads(line.strip())+++if __name__ == '__main__':+    main()