hwormhole 0.2.0.0 → 0.2.0.1

raw patch · 9 files changed

+198/−470 lines, 9 filesdep +pgp-wordlistdep −hexPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pgp-wordlist

Dependencies removed: hex

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• cmd/Main.hs +1/−1
• hwormhole.cabal +2/−4
• src/Transit.hs +13/−4
• src/Transit/Internal/App.hs +83/−73
• src/Transit/Internal/FileTransfer.hs +52/−83
• src/Transit/Internal/Peer.hs +40/−47
• tests/Generator.hs +0/−2
• wordlist.txt +0/−256

@@ -1,5 +1,12 @@ # Revision history for haskell-magic-wormhole-client +## 0.2.0.1  -- 2019-03-29++* Get rid of the dependency on the 'hex' library.+* PGP wordlist is an external dependency now, the wordlist has been+  removed. 'Env' does not carry the wordlist around anymore.+* Expose 'App.send' and 'App.receive' functions.+ ## 0.2.0.0  -- 2018-12-12  * Fix a bug which shows up as a failed hwormhole to hwormhole transfer,

@@ -26,7 +26,7 @@  main :: IO () main = do-  env <- Transit.prepareAppEnv appid "wordlist.txt" =<< commandlineParser+  env <- Transit.prepareAppEnv appid =<< commandlineParser   result <- Transit.runApp Transit.app env   either (TIO.putStrLn . show) return result     where

@@ -2,7 +2,7 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/  name:                hwormhole-version:             0.2.0.0+version:             0.2.0.1 synopsis:            magic-wormhole client description:         A secure way to send files over the Internet using the magic-wormhole protocol license:             GPL-3@@ -14,7 +14,6 @@ build-type:          Simple extra-source-files:  ChangeLog.md cabal-version:       1.24-data-files:          wordlist.txt  source-repository head   type: git@@ -44,13 +43,13 @@                      , directory       >= 1.3     && < 2.0                      , filepath        >= 1.4.0   && < 2.0                      , haskeline       >= 0.7.4   && < 1.0-                     , hex             >= 0.1.2   && < 1.0                      , magic-wormhole  >= 0.2.1   && < 1.0                      , memory          >= 0.14.15 && < 1.0                      , mtl             >= 2.2.2   && < 3.0                      , network         >= 2.7     && < 3                      , network-info    >= 0.2.0   && < 1.0                      , pathwalk        >= 0.3.1.2 && < 1.0+                     , pgp-wordlist    >= 0.1.0.2 && < 1.0                      , protolude       >= 0.2.1   && < 1.0                      , random          >= 1.1     && < 2.0                      , saltine         == 0.1.0.1 && < 1.0@@ -60,7 +59,6 @@                      , transformers    >= 0.5.5   && < 1.0                      , unix-compat     >= 0.5.0   && < 1.0                      , zip             >= 1.2.0   && < 2.0-  other-modules:       Paths_hwormhole   default-language:    Haskell2010   default-extensions:  NoImplicitPrelude OverloadedStrings TypeApplications   ghc-options: -Wall -Werror=incomplete-patterns

@@ -3,15 +3,22 @@ -- -- Magic Wormhole is a technology for getting things from one computer to another, safely. ----- To use it, you must use the MagicWormhole library to first establish an encrypted connection:+-- In order to use the library in an application, you need to create an "application ID"+-- which is a unique application specific ascii string, a random 5-byte bytestring called+-- "side" and a few application configuration options defined in 'Options' type in the+-- 'Conf' module which sets up the transit server url, relay server url and the mode (send+-- or receive). --+-- Once the environment and the configurations are set, the 'app' can be run via 'App.runApp'.++-- The 'app' takes care of the following:+--+--   0. Prompt the user for a passcode (or can also be passed via command line) in the case of receiving or generate a passcode in the case of sending. --   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 'Transit.send' and 'Transit.receive'.--- Once can send and receive either Text messages or Files.+--   5. Establish a TCP connection directly if they are reachable on the same network or via a relay server (if the peers are behind NAT and cannot talk to each other directly) and send the encrypted file or a directory over the connection. -- -- The password is never sent over the wire. -- Rather, it is used to negotiate a session key using SPAKE2,@@ -23,6 +30,8 @@   , App.prepareAppEnv   , App.app   , App.runApp+  , App.send+  , App.receive   , Conf.Options(..)   , Conf.Command(..)   , Errors.Error(..)

@@ -1,10 +1,13 @@--- | Description: a file transfer monad transformer+-- | Description: a file-transfer monad transformer {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Transit.Internal.App   ( Env(..)+  , App   , prepareAppEnv   , app   , runApp+  , send+  , receive   ) where @@ -22,15 +25,14 @@ import Data.String (String) import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Except (liftEither)+import Data.Text.PgpWordlist.Internal.Words (wordList)+import Data.Text.PgpWordlist.Internal.Types (EvenWord(..), OddWord(..))  import Transit.Internal.Conf (Options(..), Command(..)) import Transit.Internal.Errors (Error(..), CommunicationError(..)) import Transit.Internal.FileTransfer(MessageType(..), sendFile, receiveFile) import Transit.Internal.Peer (sendOffer, receiveOffer, receiveMessageAck, sendMessageAck, decodeTransitMsg)-import Paths_hwormhole -type Password = ByteString- -- | Magic Wormhole transit app environment data Env   = Env { appID :: MagicWormhole.AppID@@ -39,53 +41,23 @@         -- ^ random 5-byte bytestring         , config :: Options         -- ^ configuration like relay and transit url-        , wordList :: [(Text, Text)]-        -- ^ pass code word list (list of pair of words)         } --- | genWordlist would produce a list of the form---   [ ("aardwark", "adroitness"),---     ("absurd", "adviser"),---     ....---     ("zulu", "yucatan") ]-genWordList :: FilePath -> IO [(Text, Text)]-genWordList wordlistFile = do-  file <- TIO.readFile wordlistFile-  let contents = map toWordPair $ Text.lines file-  return contents-    where-      toWordPair :: Text -> (Text, Text)-      toWordPair line =-        let ws = map Text.toLower $ Text.words line-            Just firstWord = atMay ws 1-            Just sndWord = atMay ws 2-        in (firstWord, sndWord)----- | Create an 'Env', given the AppID, wordlist file and 'Options'-prepareAppEnv :: Text -> FilePath -> Options -> IO Env-prepareAppEnv appid wordlistPath options = do+-- | Create an 'Env', given the AppID and 'Options'+prepareAppEnv :: Text -> Options -> IO Env+prepareAppEnv appid options = do   side' <- MagicWormhole.generateSide-  wordlist <- genWordList =<< getDataFileName wordlistPath   let appID' = MagicWormhole.AppID appid-  return $ Env appID' side' options wordlist+  return $ Env appID' side' options -allocatePassword :: [(Text, Text)] -> IO Text-allocatePassword wordlist = do+allocateCode :: [(Word8, EvenWord, OddWord)] -> IO Text+allocateCode wordlist = do   g <- getStdGen   let (r1, g') = randomR (0, 255) g       (r2, _) = randomR (0, 255) g'-      Just evenW = fst <$> atMay wordlist r2-      Just oddW = snd <$> atMay wordlist r1-  return $ Text.concat [oddW, "-", evenW]--genPasscodes :: [Text] -> [(Text, Text)] -> [Text]-genPasscodes nameplates wordpairs =-  let evens = map fst wordpairs-      odds = map snd wordpairs-      wordCombos = [ o <> "-" <> e | o <- odds, e <- evens ]-  in-    [ n <> "-" <> hiphenWord | n <- nameplates, hiphenWord <- wordCombos ]+      Just (_, evenW, _) = atMay wordlist r2+      Just (_, _, oddW) = atMay wordlist r1+  return $ Text.concat [unOddWord oddW, "-", unEvenWord evenW]  printSendHelpText :: Text -> IO () printSendHelpText passcode = do@@ -94,29 +66,63 @@   TIO.putStrLn ""   TIO.putStrLn $ "wormhole receive " <> passcode -completeWord :: MonadIO m => [Text] -> HC.CompletionFunc m-completeWord wordlist = HC.completeWord Nothing "" completionFunc+data CompletionConfig+  = CompletionConfig {+       nameplates :: [Text]+    -- ^ List of nameplates identifiers on the server+     , oddWords :: [Text]+    -- ^ PGP Odd words+     , evenWords :: [Text]+    -- ^ PGP Even words+     , numWords :: Int+    -- ^ Number of PGP words used in wormhole code+     }++simpleCompletion :: Text -> HC.Completion+simpleCompletion text = (HC.simpleCompletion (toS text)) { HC.isFinished = False }++completeWord :: MonadIO m => CompletionConfig -> HC.CompletionFunc m+completeWord completionConfig = HC.completeWord Nothing "" completionFunc   where     completionFunc :: Monad m => String -> m [HC.Completion]     completionFunc word = do-      let completions = filter (toS word `Text.isPrefixOf`) wordlist-      return $ map (HC.simpleCompletion . toS) completions+      let (completed, partial) = Text.breakOnEnd "-" (toS word)+          hypenCount = Text.count "-" completed+          wordlist = if hypenCount == 0+                        then nameplates completionConfig+                        else if odd hypenCount+                                then oddWords completionConfig+                                else evenWords completionConfig+          suffix = if hypenCount < numWords completionConfig+                      then "-"+                      else ""+          completions = map (\w -> completed `Text.append` (w `Text.append` suffix)) .+                        filter (Text.isPrefixOf partial) $ wordlist+      return $ map simpleCompletion completions  -- | Take an input code from the user with code completion. -- In order for the code completion to work, we need to find -- the possible open nameplates, the possible words and then -- do the completion as the user types the code. -- TODO: This function does too much. Perfect target for refactoring.-getCode :: MagicWormhole.Session -> [(Text, Text)] -> IO Text+getCode :: MagicWormhole.Session -> [(Word8, EvenWord, OddWord)] -> IO Text getCode session wordlist = do-  nameplates <- MagicWormhole.list session-  let ns = [ n | MagicWormhole.Nameplate n <- nameplates ]+  nameplates' <- MagicWormhole.list session+  let ns = [ n | MagicWormhole.Nameplate n <- nameplates' ]+      evens = [ unEvenWord n | (_, n, _) <- wordlist]+      odds  = [ unOddWord m | (_, _, m) <- wordlist]+      completionConfig = CompletionConfig {+                            nameplates = ns,+                            oddWords = odds,+                            evenWords = evens,+                            numWords = 2+                         }   putText "Enter the receive wormhole code: "-  H.runInputT (settings (genPasscodes ns wordlist)) getInput+  H.runInputT (settings completionConfig) getInput   where-    settings :: MonadIO m => [Text] -> H.Settings m-    settings possibleWords = H.Settings-      { H.complete = completeWord possibleWords+    settings :: MonadIO m => CompletionConfig -> H.Settings m+    settings completionConfig = H.Settings+      { H.complete = completeWord completionConfig       , H.historyFile = Nothing       , H.autoAddHistory = False       }@@ -137,14 +143,17 @@ runApp :: App a -> Env -> IO (Either Error a) runApp appM env = runExceptT (runReaderT (getApp appM) env) --- | Given the magic-wormhole session, appid, password, a function to print a helpful message+transitPurpose :: MagicWormhole.AppID -> ByteString+transitPurpose (MagicWormhole.AppID appid) = toS appid <> "/transit-key"++-- | Given the magic-wormhole session, appid, pass code, a function to print a helpful message -- on the command the receiver needs to type (simplest would be just a `putStrLn`) and the -- path on the disk of the sender of the file that needs to be sent, `sendFile` sends it via -- the wormhole securely. The receiver, on successfully receiving the file, would compute -- a sha256 sum of the encrypted file and sends it across to the sender, along with an -- acknowledgement, which the sender can verify.-send :: MagicWormhole.Session -> Password -> MessageType -> App ()-send session password tfd = do+send :: MagicWormhole.Session -> Text -> MessageType -> App ()+send session code tfd = do   env <- ask   -- first establish a wormhole session with the receiver and   -- then talk the filetransfer protocol over it as follows.@@ -155,8 +164,9 @@   mailbox <- liftIO $ MagicWormhole.claim session nameplate   peer <- liftIO $ MagicWormhole.open session mailbox  -- XXX: We should run `close` in the case of exceptions?   let (MagicWormhole.Nameplate n) = nameplate-  liftIO $ printSendHelpText $ toS n <> "-" <> toS password-  result <- liftIO $ MagicWormhole.withEncryptedConnection peer (Spake2.makePassword (toS n <> "-" <> password))+  let passcode = toS n <> "-" <> toS code+  liftIO $ printSendHelpText passcode+  result <- liftIO $ MagicWormhole.withEncryptedConnection peer (Spake2.makePassword (toS passcode))     (\conn ->         case tfd of           TMsg msg -> do@@ -164,8 +174,9 @@             sendOffer conn offer             -- wait for "answer" message with "message_ack" key             first NetworkError <$> receiveMessageAck conn-          TFile filepath ->-            sendFile conn transitserver appid filepath+          TFile filepath -> do+            let transitKey = MagicWormhole.deriveKey conn (transitPurpose appid)+            sendFile conn transitserver transitKey filepath     )   liftEither result @@ -204,8 +215,9 @@           Left received ->             case decodeTransitMsg (toS received) of               Left e -> return $ Left (NetworkError e)-              Right transitMsg ->-                receiveFile conn transitserver appid transitMsg+              Right transitMsg -> do+                let transitKey = MagicWormhole.deriveKey conn (transitPurpose appid)+                receiveFile conn transitserver transitKey transitMsg     )   liftEither result @@ -225,14 +237,12 @@       liftIO (MagicWormhole.runClient endpoint (appID env) (side env) $ \session ->           runApp (receiveSession maybeCode session) env) >>= liftEither   where-    getWormholeCode :: MagicWormhole.Session -> [(Text, Text)] -> Maybe Text -> IO Text-    getWormholeCode session wordlist Nothing = getCode session wordlist-    getWormholeCode _ _ (Just code) = return code+    getWormholeCode :: MagicWormhole.Session -> Maybe Text -> IO Text+    getWormholeCode session Nothing = getCode session wordList+    getWormholeCode _ (Just code) = return code     sendSession offerMsg session = do-      env <- ask-      password <- liftIO $ allocatePassword (wordList env)-      send session (toS password) offerMsg-    receiveSession code session = do-      env <- ask-      maybeCode <- liftIO $ getWormholeCode session (wordList env) code-      receive session maybeCode+      code <- liftIO $ allocateCode wordList+      send session (toS code) offerMsg+    receiveSession maybeCode session = do+      code <- liftIO $ getWormholeCode session maybeCode+      receive session code

@@ -14,6 +14,7 @@ import qualified Conduit as C import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BL+import qualified Crypto.Saltine.Core.SecretBox as SecretBox  import Network.Socket (socketPort, Socket) import System.FilePath ((</>))@@ -37,18 +38,18 @@  import Transit.Internal.Peer   ( makeRecordKeys-  , senderHandshakeExchange+  , handshakeExchange   , senderTransitExchange   , senderOfferExchange   , receiveWormholeMessage   , sendTransitMsg   , sendWormholeMessage-  , receiverHandshakeExchange   , makeAckMessage   , generateTransitSide   , sendRecord   , receiveRecord-  , unzipInto)+  , unzipInto+  , Mode(..))  import Transit.Internal.Messages   ( TransitMsg( Transit, Answer )@@ -69,9 +70,6 @@     -- ^ File or Directory transfer   deriving (Show, Eq) -transitPurpose :: MagicWormhole.AppID -> ByteString-transitPurpose (MagicWormhole.AppID appID) = toS appID <> "/transit-key"- sendAckMessage :: TransitEndpoint -> ByteString -> IO (Either Error ()) sendAckMessage (TransitEndpoint ep _ key) sha256Sum = do   let ackMessage = makeAckMessage key sha256Sum@@ -92,73 +90,31 @@                                         | otherwise -> return $ Left (NetworkError (TransitError "transit ack failure"))         Left s -> return $ Left (NetworkError (TransitError (toS ("transit ack failure: " <> s)))) -establishSenderTransit :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> FilePath -> IO (Either Error TransitEndpoint)-establishSenderTransit conn transitserver appid filepath = do-  -- exchange abilities-  sock' <- tcpListener-  portnum <- socketPort sock'-  side <- generateTransitSide-  ourHints <- buildHints portnum transitserver-  let ourRelayHints = buildRelayHints transitserver-  transitResp <- senderTransitExchange conn (Set.toList ourHints)-  case transitResp of-    Left s -> return $ Left (NetworkError s)-    Right (Transit _peerAbilities peerHints) -> do-      -- send offer for the file-      offerResp <- senderOfferExchange conn filepath-      case offerResp of-        Left s -> return (Left (NetworkError (OfferError s)))-        Right _ -> do-          -- combine our relay hints with peer's direct and relay hints-          let allHints = Set.toList $ ourRelayHints <> peerHints-          -- concurrently start client and server-          transitEndpoint <- race (startServer sock') (startClient allHints)-          let ep = either identity identity transitEndpoint-          case ep of-            Left e -> return (Left (NetworkError e))-            Right endpoint -> do-              -- 0. derive transit key-              let transitKey = MagicWormhole.deriveKey conn (transitPurpose appid)-                  -- 1. create record keys-                  recordKeys = makeRecordKeys transitKey-              case recordKeys of-                Left e -> return (Left (CipherError e))-                Right (sRecordKey, rRecordKey) -> do-                  -- 2. handshakeExchange-                  handshake <- senderHandshakeExchange endpoint transitKey side-                  -- if handshakeExchange is successful, return the TCPEndpoint-                  -- as, we now have a "secure" socket to communicate.-                  case handshake of-                    Left e -> return (Left (HandshakeError e))-                    Right _ -> return $ Right (TransitEndpoint endpoint sRecordKey rRecordKey)-    Right _ -> return $ Left (NetworkError (UnknownPeerMessage "Could not decode message"))--establishReceiverTransit :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> TransitMsg -> Socket -> IO (Either Error TransitEndpoint)-establishReceiverTransit conn transitserver appid (Transit _peerAbilities peerHints) socket = do+establishTransit :: Mode -> RelayEndpoint -> SecretBox.Key -> TransitMsg -> Socket -> IO (Either Error TransitEndpoint)+establishTransit mode transitserver transitKey (Transit _peerAbilities peerHints) socket = do   let ourRelayHints = buildRelayHints transitserver   side <- generateTransitSide   -- combine our relay hints with peer's direct and relay hints   let allHints = Set.toList (peerHints <> ourRelayHints)-  -- derive transit key-  let transitKey = MagicWormhole.deriveKey conn (transitPurpose appid)+  -- concurrently start client and server   transitEndpoint <- race (startServer socket) (startClient allHints)   let ep = either identity identity transitEndpoint   case ep of     Left e -> return (Left (NetworkError e))     Right endpoint -> do-      -- create sender/receiver record key, sender record key-      --    for decrypting incoming records, receiver record key-      --    for sending the file_ack back at the end.+      -- 1. create record keys       let recordKeys = makeRecordKeys transitKey       case recordKeys of-        Left e -> return $ Left (CipherError e)+        Left e -> return (Left (CipherError e))         Right (sRecordKey, rRecordKey) -> do-          -- handshakeExchange-          handshake <- receiverHandshakeExchange endpoint transitKey side+          -- 2. handshakeExchange+          handshake <- handshakeExchange mode endpoint transitKey side+          -- if handshakeExchange is successful, return the TCPEndpoint+          -- as, we now have a "secure" socket to communicate.           case handshake of             Left e -> return (Left (HandshakeError e))             Right _ -> return $ Right (TransitEndpoint endpoint sRecordKey rRecordKey)-establishReceiverTransit _ _ _ _ _ = return $ Left (NetworkError (UnknownPeerMessage "Could not recognize the message"))+establishTransit _ _ _ _ _ = return $ Left (NetworkError (UnknownPeerMessage "Could not decode message"))  -- | Given the magic-wormhole session, appid, password, a function to print a helpful message -- on the command the receiver needs to type (simplest would be just a `putStrLn`) and the@@ -166,32 +122,45 @@ -- the wormhole securely. The receiver, on successfully receiving the file, would compute -- a sha256 sum of the encrypted file and sends it across to the sender, along with an -- acknowledgement, which the sender can verify.-sendFile :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> FilePath -> IO (Either Error ())-sendFile conn transitserver appid filepath = do-  -- establish a transit connection-  endpoint <- establishSenderTransit conn transitserver appid filepath-  case endpoint of-    Left e -> return $ Left e-    Right ep -> do-      (rxAckMsg, txSha256Hash) <--        finally-        (do -- send encrypted records to the peer-            (txSha256Hash, _) <- C.runConduitRes (sendPipeline filepath ep)-            -- read a record that should contain the transit Ack.-            -- If ack is not ok or the sha256sum is incorrect, flag an error.-            rxAckMsg <- receiveAckMessage ep-            return (rxAckMsg, txSha256Hash))-        (closeConnection ep)-      case rxAckMsg of-        Right rxSha256Hash ->-          if txSha256Hash /= rxSha256Hash-          then return $ Left (NetworkError (Sha256SumError "sha256 mismatch"))-          else return (Right ())-        Left e -> return $ Left e+sendFile :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> SecretBox.Key -> FilePath -> IO (Either Error ())+sendFile conn transitserver transitKey filepath = do+    -- exchange abilities+  sock' <- tcpListener+  portnum <- socketPort sock'+  ourHints <- buildHints portnum transitserver+  transitResp <- senderTransitExchange conn (Set.toList ourHints)+  case transitResp of+    Left s -> return $ Left (NetworkError s)+    Right transit -> do+      -- send offer for the file+      offerResp <- senderOfferExchange conn filepath+      case offerResp of+        Left s -> return (Left (NetworkError (OfferError s)))+        Right _ -> do+          -- establish a transit connection+          endpoint <- establishTransit Send transitserver transitKey transit sock'+          case endpoint of+            Left e -> return $ Left e+            Right ep -> do+              (rxAckMsg, txSha256Hash) <-+                finally+                (do -- send encrypted records to the peer+                    (txSha256Hash, _) <- C.runConduitRes (sendPipeline filepath ep)+                    -- read a record that should contain the transit Ack.+                    -- If ack is not ok or the sha256sum is incorrect, flag an error.+                    rxAckMsg <- receiveAckMessage ep+                    return (rxAckMsg, txSha256Hash))+                (closeConnection ep)+              case rxAckMsg of+                Right rxSha256Hash ->+                  if txSha256Hash /= rxSha256Hash+                  then return $ Left (NetworkError (Sha256SumError "sha256 mismatch"))+                  else return (Right ())+                Left e -> return $ Left e  -- | Receive a file or directory via the established MagicWormhole connection-receiveFile :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> MagicWormhole.AppID -> TransitMsg -> IO (Either Error ())-receiveFile conn transitserver appid transit = do+receiveFile :: MagicWormhole.EncryptedConnection -> RelayEndpoint -> SecretBox.Key -> TransitMsg -> IO (Either Error ())+receiveFile conn transitserver transitKey transit = do   let abilities' = [Ability DirectTcpV1, Ability RelayV1]   s <- tcpListener   portnum <- socketPort s@@ -219,7 +188,7 @@         let ans = Answer (FileAck "ok")         sendWormholeMessage conn (Aeson.encode ans)         -- establish receive transit endpoint-        endpoint <- establishReceiverTransit conn transitserver appid transit socket+        endpoint <- establishTransit Receive transitserver transitKey transit socket         case endpoint of           Left e -> return $ Left e           Right ep -> do

@@ -1,18 +1,14 @@ -- | Description: Module that exchanges messages with the Peer {-# LANGUAGE OverloadedStrings #-} module Transit.Internal.Peer-  ( makeSenderHandshake-  , makeReceiverHandshake-  , makeRecordKeys-  , makeRelayHandshake+  ( makeRecordKeys   , senderTransitExchange   , senderOfferExchange   , sendOffer   , receiveOffer   , sendMessageAck   , receiveMessageAck-  , senderHandshakeExchange-  , receiverHandshakeExchange+  , handshakeExchange   , sendTransitMsg   , decodeTransitMsg   , makeAckMessage@@ -23,6 +19,11 @@   , sendRecord   , receiveRecord   , unzipInto+  , Mode(..)+  -- * for tests+  , makeSenderHandshake+  , makeReceiverHandshake+  , makeRelayHandshake   ) where @@ -39,7 +40,6 @@ import Data.Binary.Get (getWord32be, runGet) import Data.ByteString.Builder(toLazyByteString, word32BE, byteString) import Data.Bits (shiftL)-import Data.Hex (hex) import Data.Text (toLower) import System.Posix.Types (FileOffset, FileMode) import System.PosixCompat.Files (getFileStatus, fileSize, fileMode, isDirectory)@@ -92,7 +92,7 @@   (toS @Text @ByteString "transit sender ") <> hexid <> (toS @Text @ByteString " ready\n\n")   where     subkey = deriveKeyFromPurpose SenderHandshake key-    hexid = toS (toLower (toS @ByteString @Text (hex subkey)))+    hexid = toS (toLower (toS @ByteString @Text (convertToBase Base16 subkey)))  -- | Make a bytestring for the handshake message sent by the receiver -- which is of the form "transit receiver XXXX...XX ready\n\n" where@@ -102,7 +102,7 @@   (toS @Text @ByteString "transit receiver ") <> hexid <> (toS @Text @ByteString " ready\n\n")   where     subkey = deriveKeyFromPurpose ReceiverHandshake key-    hexid = toS (toLower (toS @ByteString @Text (hex subkey)))+    hexid = toS (toLower (toS @ByteString @Text (convertToBase Base16 subkey)))  -- | create relay handshake bytestring -- "please relay HEXHEX for side XXXXX\n"@@ -111,7 +111,7 @@   (toS @Text @ByteString "please relay ") <> token <> (toS @Text @ByteString " for side ") <> sideBytes <> "\n"   where     subkey = deriveKeyFromPurpose RelayHandshake key-    token = toS (toLower (toS @ByteString @Text (hex subkey)))+    token = toS (toLower (toS @ByteString @Text (convertToBase Base16 subkey)))     sideBytes = toS @Text @ByteString side  -- | Make sender and receiver symmetric keys for the records transmission.@@ -267,52 +267,45 @@     rHandshakeMsg = "ok\n"     recvByteString n = recvBuffer ep n --- | Sender side exchange of the handshake messages. Sender sends send-side handshake--- message created by 'makeSenderHandshake' and concurrently receives the handshake--- message from the receive side and compares it with the bytestring created by--- 'makeReceiverHandshake'. If it matches, then it sends "go\n" to the receiver, else--- it sends "nevermind\n" to the receiver and returns an 'InvalidHandshake'.-senderHandshakeExchange :: TCPEndpoint -> SecretBox.Key -> MagicWormhole.Side -> IO (Either InvalidHandshake ())-senderHandshakeExchange ep key side = do+-- | Client mode+data Mode = Send | Receive+  deriving (Eq, Show)++-- | Exchange transit handshake message+handshakeExchange :: Mode -> TCPEndpoint -> SecretBox.Key -> MagicWormhole.Side -> IO (Either InvalidHandshake ())+handshakeExchange mode ep key side = do   when (conntype ep == Just RelayV1) $ do     relayHandshakeExchange ep key side   (_, r) <- concurrently sendHandshake rxHandshake-  if r == rHandshakeMsg-    then do-    _ <- sendGo-    return $ Right ()-    else do-    _ <- sendNeverMind-    return $ Left InvalidHandshake+  case mode of+    Send -> do+      -- compare received handshake with locally computed rx handshake+      -- and if it matches, send go+      if r == rHandshakeMsg+        then do+        _ <- sendGo+        return $ Right ()+        else do+        _ <- sendNeverMind+        return $ Left InvalidHandshake+    Receive -> do+      -- compare the received handshake with the locally computed tx handshake+      -- and also receive "go\n" from the sender. if they are not matching,+      -- send InvalidHandshake, else do nothing.+      r' <- recvByteString (BS.length "go\n")+      if (r <> r') == sHandshakeMsg <> "go\n"+        then return $ Right ()+        else return $ Left InvalidHandshake   where-    sendHandshake = sendBuffer ep sHandshakeMsg-    rxHandshake = recvByteString (BS.length rHandshakeMsg)+    sendHandshake | mode == Send = sendBuffer ep sHandshakeMsg+                  | otherwise    = sendBuffer ep rHandshakeMsg+    rxHandshake | mode == Send = recvByteString (BS.length rHandshakeMsg)+                | otherwise    = recvByteString (BS.length sHandshakeMsg)     sendGo = sendBuffer ep (toS @Text @ByteString "go\n")     sendNeverMind = sendBuffer ep (toS @Text @ByteString "nevermind\n")     sHandshakeMsg = makeSenderHandshake key     rHandshakeMsg = makeReceiverHandshake key     recvByteString n = recvBuffer ep n---- | Receiver side exchange of handshake messages. Receiver sends the receive-side--- handshake message appended with "go\n" and receives the handshake message from--- the sender. It then compares the message received from the sender with the locally--- computed sender handshake bytestring appended with "go\n". If they don't match, it--- returns an 'InvalidHandshake'.-receiverHandshakeExchange :: TCPEndpoint -> SecretBox.Key -> MagicWormhole.Side -> IO (Either InvalidHandshake ())-receiverHandshakeExchange ep key side = do-  when (conntype ep == Just RelayV1) $ do-    relayHandshakeExchange ep key side-  (_, r') <- concurrently sendHandshake rxHandshake-  r'' <- recvByteString (BS.length "go\n")-  if (r' <> r'') == sHandshakeMsg <> "go\n"-    then return $ Right ()-    else return $ Left InvalidHandshake-    where-        sendHandshake = sendBuffer ep rHandshakeMsg-        rxHandshake = recvByteString (BS.length sHandshakeMsg)-        sHandshakeMsg = makeSenderHandshake key-        rHandshakeMsg = makeReceiverHandshake key-        recvByteString n = recvBuffer ep n  -- | Create an encrypted Transit Ack message makeAckMessage :: SecretBox.Key -> ByteString -> Either CryptoError CipherText

@@ -15,8 +15,6 @@ import Protolude  import Hedgehog (MonadGen(..))-import qualified Crypto.Saltine.Class as Saltine-import qualified Crypto.Saltine.Core.SecretBox as SecretBox import Crypto.Saltine.Internal.ByteSizes (boxNonce) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range

@@ -1,256 +0,0 @@-00	aardvark	adroitness-01	absurd		adviser-02	accrue		aftermath-03	acme		aggregate-04	adrift		alkali-05	adult		almighty-06	afflict		amulet-07	ahead		amusement-08	aimless		antenna-09	Algol		applicant-0A	allow		Apollo-0B	alone		armistice-0C	ammo		article-0D	ancient		asteroid-0E	apple		Atlantic-0F	artist		atmosphere-10	assume		autopsy-11	Athens		Babylon-12	atlas		backwater-13	Aztec		barbecue-14	baboon		belowground-15	backfield	bifocals-16	backward	bodyguard-17	banjo		bookseller-18	beaming		borderline-19	bedlamp		bottomless-1A	beehive		Bradbury-1B	beeswax		bravado-1C	befriend	Brazilian-1D	Belfast		breakaway-1E	berserk		Burlington-1F	billiard	businessman-20	bison		butterfat-21	blackjack	Camelot-22	blockade	candidate-23	blowtorch	cannonball-24	bluebird	Capricorn-25	bombast		caravan-26	bookshelf	caretaker-27	brackish	celebrate-28	breadline	cellulose-29	breakup		certify-2A	brickyard	chambermaid-2B	briefcase	Cherokee-2C	Burbank		Chicago-2D	button		clergyman-2E	buzzard		coherence-2F	cement		combustion-30	chairlift	commando-31	chatter		company-32	checkup		component-33	chisel		concurrent-34	choking		confidence-35	chopper		conformist-36	Christmas	congregate-37	clamshell	consensus-38	classic		consulting-39	classroom	corporate-3A	cleanup		corrosion-3B	clockwork	councilman-3C	cobra		crossover-3D	commence	crucifix-3E	concert		cumbersome-3F	cowbell		customer-40	crackdown	Dakota-41	cranky		decadence-42	crowfoot	December-43	crucial		decimal-44	crumpled	designing-45	crusade		detector-46	cubic		detergent-47	dashboard	determine-48	deadbolt	dictator-49	deckhand	dinosaur-4A	dogsled		direction-4B	dragnet		disable-4C	drainage	disbelief-4D	dreadful	disruptive-4E	drifter		distortion-4F	dropper		document-50	drumbeat	embezzle-51	drunken		enchanting-52	Dupont		enrollment-53	dwelling	enterprise-54	eating		equation-55	edict		equipment-56	egghead		escapade-57	eightball	Eskimo-58	endorse		everyday-59	endow		examine-5A	enlist		existence-5B	erase		exodus-5C	escape		fascinate-5D	exceed		filament-5E	eyeglass	finicky-5F	eyetooth	forever-60	facial		fortitude-61	fallout		frequency-62	flagpole	gadgetry-63	flatfoot	Galveston-64	flytrap		getaway-65	fracture	glossary-66	framework	gossamer-67	freedom		graduate-68	frighten	gravity-69	gazelle		guitarist-6A	Geiger		hamburger-6B	glitter		Hamilton-6C	glucose		handiwork-6D	goggles		hazardous-6E	goldfish	headwaters-6F	gremlin		hemisphere-70	guidance	hesitate-71	hamlet		hideaway-72	highchair	holiness-73	hockey		hurricane-74	indoors		hydraulic-75	indulge		impartial-76	inverse		impetus-77	involve		inception-78	island		indigo-79	jawbone		inertia-7A	keyboard	infancy-7B	kickoff		inferno-7C	kiwi		informant-7D	klaxon		insincere-7E	locale		insurgent-7F	lockup		integrate-80	merit		intention-81	minnow		inventive-82	miser		Istanbul-83	Mohawk		Jamaica-84	mural		Jupiter-85	music		leprosy-86	necklace	letterhead-87	Neptune		liberty-88	newborn		maritime-89	nightbird	matchmaker-8A	Oakland		maverick-8B	obtuse		Medusa-8C	offload		megaton-8D	optic		microscope-8E	orca		microwave-8F	payday		midsummer-90	peachy		millionaire-91	pheasant	miracle-92	physique	misnomer-93	playhouse	molasses-94	Pluto		molecule-95	preclude	Montana-96	prefer		monument-97	preshrunk	mosquito-98	printer		narrative-99	prowler		nebula-9A	pupil		newsletter-9B	puppy		Norwegian-9C	python		October-9D	quadrant	Ohio-9E	quiver		onlooker-9F	quota		opulent-A0	ragtime		Orlando-A1	ratchet		outfielder-A2	rebirth		Pacific-A3	reform		pandemic-A4	regain		Pandora-A5	reindeer	paperweight-A6	rematch		paragon-A7	repay		paragraph-A8	retouch		paramount-A9	revenge		passenger-AA	reward		pedigree-AB	rhythm		Pegasus-AC	ribcage		penetrate-AD	ringbolt	perceptive-AE	robust		performance-AF	rocker		pharmacy-B0	ruffled		phonetic-B1	sailboat	photograph-B2	sawdust		pioneer-B3	scallion	pocketful-B4	scenic		politeness-B5	scorecard	positive-B6	Scotland	potato-B7	seabird		processor-B8	select		provincial-B9	sentence	proximate-BA	shadow		puberty-BB	shamrock	publisher-BC	showgirl	pyramid-BD	skullcap	quantity-BE	skydive		racketeer-BF	slingshot	rebellion-C0	slowdown	recipe-C1	snapline	recover-C2	snapshot	repellent-C3	snowcap		replica-C4	snowslide	reproduce-C5	solo		resistor-C6	southward	responsive-C7	soybean		retraction-C8	spaniel		retrieval-C9	spearhead	retrospect-CA	spellbind	revenue-CB	spheroid	revival-CC	spigot		revolver-CD	spindle		sandalwood-CE	spyglass	sardonic-CF	stagehand	Saturday-D0	stagnate	savagery-D1	stairway	scavenger-D2	standard	sensation-D3	stapler		sociable-D4	steamship	souvenir-D5	sterling	specialist-D6	stockman	speculate-D7	stopwatch	stethoscope-D8	stormy		stupendous-D9	sugar		supportive-DA	surmount	surrender-DB	suspense	suspicious-DC	sweatband	sympathy-DD	swelter		tambourine-DE	tactics		telephone-DF	talon		therapist-E0	tapeworm	tobacco-E1	tempest		tolerance-E2	tiger		tomorrow-E3	tissue		torpedo-E4	tonic		tradition-E5	topmost		travesty-E6	tracker		trombonist-E7	transit		truncated-E8	trauma		typewriter-E9	treadmill	ultimate-EA	Trojan		undaunted-EB	trouble		underfoot-EC	tumor		unicorn-ED	tunnel		unify-EE	tycoon		universe-EF	uncut		unravel-F0	unearth		upcoming-F1	unwind		vacancy-F2	uproot		vagabond-F3	upset		vertigo-F4	upshot		Virginia-F5	vapor		visitor-F6	village		vocalist-F7	virus		voyager-F8	Vulcan		warranty-F9	waffle		Waterloo-FA	wallet		whimsical-FB	watchword	Wichita-FC	wayside		Wilmington-FD	willow		Wyoming-FE	woodlark	yesteryear-FF	Zulu		Yucatan