diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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, diff --git a/cmd/Main.hs b/cmd/Main.hs --- a/cmd/Main.hs +++ b/cmd/Main.hs @@ -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 diff --git a/hwormhole.cabal b/hwormhole.cabal --- a/hwormhole.cabal +++ b/hwormhole.cabal @@ -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 diff --git a/src/Transit.hs b/src/Transit.hs --- a/src/Transit.hs +++ b/src/Transit.hs @@ -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(..) diff --git a/src/Transit/Internal/App.hs b/src/Transit/Internal/App.hs --- a/src/Transit/Internal/App.hs +++ b/src/Transit/Internal/App.hs @@ -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 diff --git a/src/Transit/Internal/FileTransfer.hs b/src/Transit/Internal/FileTransfer.hs --- a/src/Transit/Internal/FileTransfer.hs +++ b/src/Transit/Internal/FileTransfer.hs @@ -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 diff --git a/src/Transit/Internal/Peer.hs b/src/Transit/Internal/Peer.hs --- a/src/Transit/Internal/Peer.hs +++ b/src/Transit/Internal/Peer.hs @@ -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 diff --git a/tests/Generator.hs b/tests/Generator.hs --- a/tests/Generator.hs +++ b/tests/Generator.hs @@ -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 diff --git a/wordlist.txt b/wordlist.txt deleted file mode 100644 --- a/wordlist.txt +++ /dev/null @@ -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