diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog + +## 0.1.0 (2018-01-17) + +Initial release + +* Exchange text messages with Magic Wormhole peers diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/cmd/HocusPocus.hs b/cmd/HocusPocus.hs new file mode 100644 --- /dev/null +++ b/cmd/HocusPocus.hs @@ -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" diff --git a/magic-wormhole.cabal b/magic-wormhole.cabal new file mode 100644 --- /dev/null +++ b/magic-wormhole.cabal @@ -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 +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 diff --git a/src/MagicWormhole.hs b/src/MagicWormhole.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole.hs @@ -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 diff --git a/src/MagicWormhole/Internal/ClientProtocol.hs b/src/MagicWormhole/Internal/ClientProtocol.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/ClientProtocol.hs @@ -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 diff --git a/src/MagicWormhole/Internal/FileTransfer.hs b/src/MagicWormhole/Internal/FileTransfer.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/FileTransfer.hs @@ -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" diff --git a/src/MagicWormhole/Internal/Messages.hs b/src/MagicWormhole/Internal/Messages.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/Messages.hs @@ -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) diff --git a/src/MagicWormhole/Internal/Pake.hs b/src/MagicWormhole/Internal/Pake.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/Pake.hs @@ -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 diff --git a/src/MagicWormhole/Internal/Peer.hs b/src/MagicWormhole/Internal/Peer.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/Peer.hs @@ -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) diff --git a/src/MagicWormhole/Internal/Rendezvous.hs b/src/MagicWormhole/Internal/Rendezvous.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/Rendezvous.hs @@ -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 diff --git a/src/MagicWormhole/Internal/Sequential.hs b/src/MagicWormhole/Internal/Sequential.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/Sequential.hs @@ -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 diff --git a/src/MagicWormhole/Internal/Versions.hs b/src/MagicWormhole/Internal/Versions.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/Versions.hs @@ -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 diff --git a/src/MagicWormhole/Internal/WebSockets.hs b/src/MagicWormhole/Internal/WebSockets.hs new file mode 100644 --- /dev/null +++ b/src/MagicWormhole/Internal/WebSockets.hs @@ -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 diff --git a/tests/ClientProtocol.hs b/tests/ClientProtocol.hs new file mode 100644 --- /dev/null +++ b/tests/ClientProtocol.hs @@ -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) + ] diff --git a/tests/Generator.hs b/tests/Generator.hs new file mode 100644 --- /dev/null +++ b/tests/Generator.hs @@ -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) diff --git a/tests/Integration.hs b/tests/Integration.hs new file mode 100644 --- /dev/null +++ b/tests/Integration.hs @@ -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)) diff --git a/tests/Messages.hs b/tests/Messages.hs new file mode 100644 --- /dev/null +++ b/tests/Messages.hs @@ -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 + ] diff --git a/tests/Pake.hs b/tests/Pake.hs new file mode 100644 --- /dev/null +++ b/tests/Pake.hs @@ -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 + ] diff --git a/tests/Sequential.hs b/tests/Sequential.hs new file mode 100644 --- /dev/null +++ b/tests/Sequential.hs @@ -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 + ] diff --git a/tests/Tasty.hs b/tests/Tasty.hs new file mode 100644 --- /dev/null +++ b/tests/Tasty.hs @@ -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 + ] diff --git a/tests/WebSockets.hs b/tests/WebSockets.hs new file mode 100644 --- /dev/null +++ b/tests/WebSockets.hs @@ -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 diff --git a/tests/python/derive_phase_key.py b/tests/python/derive_phase_key.py new file mode 100644 --- /dev/null +++ b/tests/python/derive_phase_key.py @@ -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() diff --git a/tests/python/nacl_exchange.py b/tests/python/nacl_exchange.py new file mode 100644 --- /dev/null +++ b/tests/python/nacl_exchange.py @@ -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() diff --git a/tests/python/spake2_exchange.py b/tests/python/spake2_exchange.py new file mode 100644 --- /dev/null +++ b/tests/python/spake2_exchange.py @@ -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() diff --git a/tests/python/version_exchange.py b/tests/python/version_exchange.py new file mode 100644 --- /dev/null +++ b/tests/python/version_exchange.py @@ -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()