diff --git a/apps/dog-food/ChatOptions.hs b/apps/dog-food/ChatOptions.hs index 0a7ff89f0..0940c34b8 100644 --- a/apps/dog-food/ChatOptions.hs +++ b/apps/dog-food/ChatOptions.hs @@ -2,10 +2,10 @@ module ChatOptions (getChatOpts, ChatOpts (..)) where -import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) +import Simplex.Messaging.Parsers (parseAll) import System.FilePath (combine) import System.Info (os) import Types @@ -58,7 +58,7 @@ chatOpts appDir = | otherwise = TermModeEditor parseSMPServer :: ReadM SMPServer -parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack +parseSMPServer = eitherReader $ parseAll smpServerP . B.pack parseTermMode :: ReadM TermMode parseTermMode = maybeReader $ \case diff --git a/apps/dog-food/Main.hs b/apps/dog-food/Main.hs index ac33b81e5..bc2c1c198 100644 --- a/apps/dog-food/Main.hs +++ b/apps/dog-food/Main.hs @@ -26,6 +26,7 @@ import Simplex.Messaging.Agent.Client (AgentClient (..)) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client (smpDefaultConfig) +import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Util (bshow, raceAny_) import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) @@ -124,7 +125,7 @@ main = do t <- getChatClient smpServer user ct <- newChatTerminal (tbqSize cfg) user termMode -- setLogLevel LogInfo -- LogError - -- withGlobalLogging logCfg $ + -- withGlobalLogging logCfg $ do env <- newSMPAgentEnv cfg {dbFile = dbFileName} dogFoodChat t ct env @@ -172,7 +173,7 @@ newChatClient qSize smpServer name = do receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO () receiveFromChatTerm t ct = forever $ do atomically (readTBQueue $ inputQ ct) - >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) + >>= processOrError . parseAll chatCommandP where processOrError = \case Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err diff --git a/rfcs/2021-01-26-crypto.md b/rfcs/2021-01-26-crypto.md index e9ea8aa49..c7f5f2c9d 100644 --- a/rfcs/2021-01-26-crypto.md +++ b/rfcs/2021-01-26-crypto.md @@ -16,49 +16,46 @@ For initial implementation I propose approach to be as simple as possible as lon One of the consideration is to use [noise protocol framework](https://noiseprotocol.org/noise.html), this section describes ad hoc protocol though. -During TCP session both client and server should use symmetric AES 256 bit encryption using the session key that will be established during the handshake. +During TCP session both client and server should use symmetric AES 256 bit encryption using two session keys and two base IVs that will be agreed during the handshake. Both client and the server should maintain two 32-bit word counters, one for sent and one for the received messages. The IV for each message should be computed by xor-ing the sequential message counter, starting from 0, with the first 32 bits of agreed base IV. TODO - explain it in a more formal way, also document how 32-bit word is encoded - with the most or least significant byte first (currently encodeWord32 from Network.Transport.Internal is used) -To establish the session key, the server should have an asymmetric key pair generated during server deployment and unknown to the clients. The users should know the key hash (256 bits) and additional server ID (256 bits) in advance in order to be able to establish connection. +To establish the session keys and base IVs, the server should have an asymmetric key pair generated during server deployment and unknown to the clients. The users should know the key hash (256 bits) in advance in order to be able to establish connection. -The handshake sequence could be the following: +The handshake sequence is the following: -1. Once the connection is established, the server sends its public key to the client -2. The client compares the hash of the received key with the hash it already has (e.g. received as part of connection invitation or server in NEW command). If the hash does not match, the client must terminate the connection. -3. If the hash is the same, the client should generate a random symmetric AES key and IV that will be used as a session key both by the client and the server. -4. The client then should encrypt this symmetric key with the public key that the server sent and send back to the server the result and the server ID also shared with the client in advance: `rsa-encrypt(aes-key, iv, server-id)`. -5. The server should decrypt the received key, IV and server id with its private key. -6. The server should compare the `server-id` sent by the client and if it does not match its ID terminate the connection. -7. In case of successful decryption and matching server ID, the server should send encrypted welcome header. +1. Once the connection is established, the server sends its public 2048 bit key to the client. TODO currently the key will be sent as a line terminated with CRLF, using ad-hoc key serialization we use. +2. The client compares the hash of the received key with the hash it already has (e.g. received as part of connection invitation or server in NEW command). If the hash does not match, the client must terminate the connection. TODO as the hash is optional in server syntax at the moment, hash comparison will be optional as well. Probably it should become required. +3. If the hash is the same, the client should generate random symmetric AES keys and base IVs that will be used as session keys/IVs by the client and the server. +4. The client then should encrypt these symmetric keys and base IVs with the public key that the server sent, and send to the server the result of the encryption: `rsa-encrypt(snd-aes-key, snd-base-iv, rcv-aes-key, rcv-base-iv)`. `snd-aes-key` and `snd-base-iv` will be used by the client to encrypt **sent** messages and by the server to decrypt them, `rcv-aes-key` and `rcv-base-iv` will be used by the client to decrypt **received** messages and by the server to encrypt them. +5. The server should decrypt the received keys and base IVs with its private key. +6. In case of successful decryption, the server should send encrypted welcome block (encrypted_welcome_block) that contains SMP protocol version. -```abnf -aes_welcome_header = aes_header_auth_tag aes_encrypted_header -welcome_header = smp_version ["," smp_mode] *SP ; decrypt(aes_encrypted_header) - 32 bytes -smp_version = %s"v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ["-" 1*ALPHA "." 1*DIGIT] ; in semver format - ; for example: v123.456.789-alpha.7 -smp_mode = smp_public / smp_authenticated -smp_public = %s"pub" ; public (default) - no auth to create and manage queues -smp_authenticated = %s"auth" ; server authentication with AUTH command (TBD) is required to create and manage queues -aes_header_auth_tag = aes_auth_tag -aes_auth_tag = 16*16(OCTET) -``` - -No payload should follow this header, it is only used to confirm successful handshake and send the SMP protocol version that the server supports. - -All the subsequent data both from the client and from the server should be sent encrypted using symmetric AES key and IV sent by the client during the handshake. +All the subsequent data both from the client and from the server should be sent encrypted using symmetric AES keys and base IVs (incremented by counters on both sides) sent by the client during the handshake. Each transport block sent by the client and the server has this syntax: ```abnf -transport_block = aes_header_auth_tag aes_encrypted_header aes_body_auth_tag aes_encrypted_body -aes_encrypted_header = 32*32(OCTET) -header = padded_body_size payload_size reserved ; decrypt(aes_encrypted_header) - 32 bytes +transport_block = aes_body_auth_tag aes_encrypted_body ; fixed at 8192 bits aes_encrypted_body = 1*OCTET -body = payload pad -padded_body_size = size ; body size in bytes -payload_size = size ; payload_size in bytes -size = 4*4(OCTET) -reserved = 24*24(OCTET) -aes_body_auth_tag = aes_auth_tag +aes_body_auth_tag = 16*16(OCTET) + +encrypted_welcome_block = transport_block +welcome_block = smp_version SP pad ; decrypt(encrypted_welcome_block) +smp_version = %s"v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ["-" 1*ALPHA "." 1*DIGIT] ; in semver format + ; for example: v123.456.789-alpha.7 +pad = 1*OCTET +``` + +## Possible future improvements/changes + +- server id (256 bits), so that only the users that have it can connect to the server. This ID will have to be passed to the server during the handshake +- block size agreed during handshake +- transport encryption protocol agreed during handshake +- welcome block containing SMP mode (smp_mode) + +```abnf +smp_mode = smp_public / smp_authenticated +smp_public = %s"pub" ; public (default) - no auth to create and manage queues +smp_authenticated = %s"auth" ; server authentication with AUTH command (TBD) is required to create and manage queues ``` ## Initial handshake diff --git a/rfcs/2021-03-18-groups.md b/rfcs/2021-03-18-groups.md new file mode 100644 index 000000000..6da1fba69 --- /dev/null +++ b/rfcs/2021-03-18-groups.md @@ -0,0 +1,25 @@ +# SMP agent groups + +## Problems + +- device/user profile synchronisation +- chat group communication + +Both problems would require message broadcast between a group of SMP agents. + +## Solution: basic symmetric groups via SMP agent protocol + +Additional commands and message envelopes to SMP agent protocol to provide an abstraction layer for device synchronisation and chat groups. + +The groups are fully symmetric, all agent who are members of the group have equal rights and can join and leave group at any time. + +All the information about the groups is stored only in agents, the commands are used to synchronise the group state between the agents. + +```abnf +group_command = create_group / add_to_group / remove_from_group / leave_group +group_response = group_created / added_to_group / removed_from_group +group_notification = added_to_group_by / removed_from_group_by / left_group +create_group = %s"GNEW " group_name ; cAlias must be empty +add_to_group = %s"GADD " group_name ; cAlias is the connection to add to the group +added_to_group = %s"GADDED " name ; cAlias is the connection added to the group +``` \ No newline at end of file diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index eb9330dd3..163166ca1 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -35,7 +35,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (CorrId (..), MsgBody, SenderPublicKey) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport (putLn, runTCPServer) -import Simplex.Messaging.Util (liftError) +import Simplex.Messaging.Util (bshow, liftError) import System.IO (Handle) import UnliftIO.Async (race_) import UnliftIO.Exception (SomeException) @@ -94,7 +94,7 @@ send h c@AgentClient {sndQ} = forever $ do logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m () logClient AgentClient {clientId} dir (CorrId corrId, cAlias, cmd) = do - logInfo . decodeUtf8 $ B.unwords [B.pack $ show clientId, dir, "A :", corrId, cAlias, B.takeWhile (/= ' ') $ serializeCommand cmd] + logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, cAlias, B.takeWhile (/= ' ') $ serializeCommand cmd] client :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> SQLiteStore -> m () client c@AgentClient {rcvQ, sndQ} st = forever $ do @@ -278,7 +278,7 @@ processSMPTransmission c@AgentClient {sndQ} st (srv, rId, cmd) = do removeSubscription c connAlias logServer "<--" c srv rId "END" notify connAlias END - _ -> logServer "<--" c srv rId $ "unexpected:" <> (B.pack . show) cmd + _ -> logServer "<--" c srv rId $ "unexpected:" <> bshow cmd where notify :: ConnAlias -> ACommand 'Agent -> m () notify connAlias msg = atomically $ writeTBQueue sndQ ("", connAlias, msg) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 1226c36be..a8dba40fa 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -47,7 +47,7 @@ import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey) -import Simplex.Messaging.Util (liftError) +import Simplex.Messaging.Util (bshow, liftError) import UnliftIO.Concurrent import UnliftIO.Exception (IOException) import qualified UnliftIO.Exception as E @@ -133,7 +133,7 @@ withSMP c srv action = logServerError :: AgentErrorType -> m a logServerError e = do - logServer "<--" c srv "" $ (B.pack . show) e + logServer "<--" c srv "" $ bshow e throwError e withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a @@ -196,7 +196,7 @@ removeSubscription AgentClient {subscrConns, subscrSrvrs} connAlias = atomically logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m () logServer dir AgentClient {clientId} srv qId cmdStr = - logInfo . decodeUtf8 $ B.unwords ["A", "(" <> (B.pack . show) clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr] + logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr] showServer :: SMPServer -> ByteString showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv) diff --git a/src/Simplex/Messaging/Agent/Transmission.hs b/src/Simplex/Messaging/Agent/Transmission.hs index 207809276..af4f7fba2 100644 --- a/src/Simplex/Messaging/Agent/Transmission.hs +++ b/src/Simplex/Messaging/Agent/Transmission.hs @@ -152,7 +152,7 @@ serializeSMPMessage = \case in smpMessage "" header body where messageHeader msgId ts prevMsgHash = - B.unwords [B.pack $ show msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash] + B.unwords [bshow msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash] smpMessage smpHeader aHeader aBody = B.intercalate "\n" [smpHeader, aHeader, aBody, ""] agentMessageP :: Parser AMessage @@ -173,11 +173,17 @@ smpQueueInfoP = "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.pubKeyP) smpServerP :: Parser SMPServer -smpServerP = SMPServer <$> server <*> port <*> msgHash +smpServerP = SMPServer <$> server <*> port <*> kHash where server = B.unpack <$> A.takeTill (A.inClass ":# ") - port = A.char ':' *> (Just . show <$> (A.decimal :: Parser Int)) <|> pure Nothing - msgHash = A.char '#' *> (Just <$> base64P) <|> pure Nothing + port = fromChar ':' $ show <$> (A.decimal :: Parser Int) + kHash = fromChar '#' C.keyHashP + fromChar :: Char -> Parser a -> Parser (Maybe a) + fromChar ch parser = do + c <- A.peekChar + if c == Just ch + then A.char ch *> (Just <$> parser) + else pure Nothing parseAgentMessage :: ByteString -> Either AgentErrorType AMessage parseAgentMessage = parse agentMessageP $ SYNTAX errBadMessage @@ -194,17 +200,15 @@ serializeSmpQueueInfo (SMPQueueInfo srv qId ek) = serializeServer :: SMPServer -> ByteString serializeServer SMPServer {host, port, keyHash} = - B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack) keyHash + B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . C.serializeKeyHash) keyHash data SMPServer = SMPServer { host :: HostName, port :: Maybe ServiceName, - keyHash :: Maybe KeyHash + keyHash :: Maybe C.KeyHash } deriving (Eq, Ord, Show) -type KeyHash = Encoded - type ConnAlias = ByteString type OtherPartyId = Encoded @@ -354,7 +358,7 @@ serializeCommand = \case OFF -> "OFF" DEL -> "DEL" CON -> "CON" - ERR e -> "ERR " <> B.pack (show e) + ERR e -> "ERR " <> bshow e OK -> "OK" where replyMode :: ReplyMode -> ByteString @@ -370,13 +374,13 @@ serializeCommand = \case MsgError e -> "ERR" <> case e of MsgSkipped fromMsgId toMsgId -> - B.unwords ["NO_ID", B.pack $ show fromMsgId, B.pack $ show toMsgId] - MsgBadId aMsgId -> "ID " <> B.pack (show aMsgId) + B.unwords ["NO_ID", bshow fromMsgId, bshow toMsgId] + MsgBadId aMsgId -> "ID " <> bshow aMsgId MsgBadHash -> "HASH" -- TODO - save function as in the server Transmission - re-use? serializeMsg :: ByteString -> ByteString -serializeMsg body = B.pack (show $ B.length body) <> "\n" <> body +serializeMsg body = bshow (B.length body) <> "\n" <> body tPutRaw :: Handle -> ARawTransmission -> IO () tPutRaw h (corrId, connAlias, command) = do diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index a4737e399..757b42305 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -35,7 +36,6 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except import qualified Crypto.PubKey.RSA.Types as RSA import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe @@ -46,7 +46,7 @@ import Simplex.Messaging.Agent.Transmission (SMPServer (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Transport -import Simplex.Messaging.Util (liftEitherError, raceAny_) +import Simplex.Messaging.Util (bshow, liftEitherError, raceAny_) import System.IO import System.IO.Error import System.Timeout @@ -91,7 +91,7 @@ data Request = Request getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO SMPClient getSMPClient - smpServer@SMPServer {host, port} + smpServer@SMPServer {host, port, keyHash} SMPClientConfig {qSize, defaultPort, tcpTimeout, smpPing} msgQ disconnected = do @@ -103,7 +103,7 @@ getSMPClient `finally` atomically (putTMVar started False) tcpTimeout `timeout` atomically (takeTMVar started) >>= \case Just True -> return c {action} - _ -> throwIO err + _ -> throwIO err -- TODO report handshake error too, not only connection timeout where err :: IOException err = mkIOError TimeExpired "connection timeout" Nothing Nothing @@ -128,18 +128,24 @@ getSMPClient } client :: SMPClient -> TMVar Bool -> Handle -> IO () - client c started h = do - _ <- getLn h -- "Welcome to SMP" + client c started h = + runExceptT (clientHandshake h keyHash) >>= \case + Right th -> clientTransport c started th + -- TODO report error instead of True/False + Left _ -> atomically $ putTMVar started False + + clientTransport :: SMPClient -> TMVar Bool -> THandle -> IO () + clientTransport c started th = do atomically $ do - modifyTVar (connected c) (const True) + writeTVar (connected c) True putTMVar started True - raceAny_ [send c h, process c, receive c h, ping c] + raceAny_ [send c th, process c, receive c th, ping c] `finally` disconnected - send :: SMPClient -> Handle -> IO () + send :: SMPClient -> THandle -> IO () send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h - receive :: SMPClient -> Handle -> IO () + receive :: SMPClient -> THandle -> IO () receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ ping :: SMPClient -> IO () @@ -241,7 +247,7 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId} pKey qId cmd = do getNextCorrId = do i <- (+ 1) <$> readTVar clientCorrId writeTVar clientCorrId i - return . CorrId . B.pack $ show i + return . CorrId $ bshow i signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission signTransmission t = case pKey of diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 719056eae..f2aeb216c 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -10,17 +10,33 @@ module Simplex.Messaging.Crypto PublicKey (..), Signature (..), CryptoError (..), + KeyPair, + Key (..), + IV (..), + KeyHash (..), generateKeyPair, + publicKeySize, sign, verify, encrypt, decrypt, + encryptOAEP, + decryptOAEP, + encryptAES, + decryptAES, serializePrivKey, serializePubKey, - parsePrivKey, - parsePubKey, + serializeKeyHash, privKeyP, pubKeyP, + keyHashP, + authTagSize, + authTagToBS, + bsToAuthTag, + randomAesKey, + randomIV, + aesKeyP, + ivP, ) where @@ -30,7 +46,7 @@ import Control.Monad.Trans.Except import Crypto.Cipher.AES (AES256) import qualified Crypto.Cipher.Types as AES import qualified Crypto.Error as CE -import Crypto.Hash.Algorithms (SHA256 (..)) +import Crypto.Hash (Digest, SHA256 (..), digestFromByteString) import Crypto.Number.Generate (generateMax) import Crypto.Number.Prime (findPrimeFrom) import Crypto.Number.Serialize (i2osp, os2ip) @@ -53,7 +69,7 @@ import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok (Ok (Ok)) import Database.SQLite.Simple.ToField (ToField (..)) import Network.Transport.Internal (decodeWord32, encodeWord32) -import Simplex.Messaging.Parsers (base64P) +import Simplex.Messaging.Parsers (base64P, parseAll) import Simplex.Messaging.Util (bshow, liftEitherError, (<$$>)) newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show) @@ -71,14 +87,14 @@ instance ToField PublicKey where toField = toField . serializePubKey instance FromField PrivateKey where fromField f@(Field (SQLBlob b) _) = - case parsePrivKey b of + case parseAll privKeyP b of Right k -> Ok k Left e -> returnError ConversionFailed f ("couldn't parse PrivateKey field: " ++ e) fromField f = returnError ConversionFailed f "expecting SQLBlob column type" instance FromField PublicKey where fromField f@(Field (SQLBlob b) _) = - case parsePubKey b of + case parseAll pubKeyP b of Right k -> Ok k Left e -> returnError ConversionFailed f ("couldn't parse PublicKey field: " ++ e) fromField f = returnError ConversionFailed f "expecting SQLBlob column type" @@ -124,6 +140,9 @@ generateKeyPair size = loop then loop else return (PublicKey pub, privateKey s n d) +publicKeySize :: PublicKey -> Int +publicKeySize = R.public_size . rsaPublicKey + data Header = Header { aesKey :: Key, ivBytes :: IV, @@ -135,52 +154,83 @@ newtype Key = Key {unKey :: ByteString} newtype IV = IV {unIV :: ByteString} +newtype KeyHash = KeyHash {unKeyHash :: Digest SHA256} deriving (Eq, Ord, Show) + +instance IsString KeyHash where + fromString = either error id . parseAll keyHashP . fromString + +instance ToField KeyHash where toField = toField . serializeKeyHash + +instance FromField KeyHash where + fromField f@(Field (SQLBlob b) _) = + case parseAll keyHashP b of + Right k -> Ok k + Left e -> returnError ConversionFailed f ("couldn't parse KeyHash field: " ++ e) + fromField f = returnError ConversionFailed f "expecting SQLBlob column type" + +serializeKeyHash :: KeyHash -> ByteString +serializeKeyHash = encode . BA.convert . unKeyHash + +keyHashP :: Parser KeyHash +keyHashP = do + bs <- base64P + case digestFromByteString bs of + Just d -> pure $ KeyHash d + _ -> fail "invalid digest" + serializeHeader :: Header -> ByteString serializeHeader Header {aesKey, ivBytes, authTag, msgSize} = unKey aesKey <> unIV ivBytes <> authTagToBS authTag <> (encodeWord32 . fromIntegral) msgSize headerP :: Parser Header headerP = do - aesKey <- Key <$> A.take aesKeySize - ivBytes <- IV <$> A.take (ivSize @AES256) + aesKey <- aesKeyP + ivBytes <- ivP authTag <- bsToAuthTag <$> A.take authTagSize msgSize <- fromIntegral . decodeWord32 <$> A.take 4 return Header {aesKey, ivBytes, authTag, msgSize} +aesKeyP :: Parser Key +aesKeyP = Key <$> A.take aesKeySize + +ivP :: Parser IV +ivP = IV <$> A.take (ivSize @AES256) + parseHeader :: ByteString -> Either CryptoError Header -parseHeader = first CryptoHeaderError . A.parseOnly (headerP <* A.endOfInput) +parseHeader = first CryptoHeaderError . parseAll headerP encrypt :: PublicKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString encrypt k paddedSize msg = do - aesKey <- Key <$> randomBytes aesKeySize - ivBytes <- IV <$> randomBytes (ivSize @AES256) + aesKey <- liftIO randomAesKey + ivBytes <- liftIO randomIV + (authTag, msg') <- encryptAES aesKey ivBytes paddedSize msg + let header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg} + encHeader <- encryptOAEP k $ serializeHeader header + return $ encHeader <> msg' + +decrypt :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString +decrypt pk msg'' = do + let (encHeader, msg') = B.splitAt (private_size pk) msg'' + header <- decryptOAEP pk encHeader + Header {aesKey, ivBytes, authTag, msgSize} <- except $ parseHeader header + msg <- decryptAES aesKey ivBytes msg' authTag + return $ B.take msgSize msg + +encryptAES :: Key -> IV -> Int -> ByteString -> ExceptT CryptoError IO (AES.AuthTag, ByteString) +encryptAES aesKey ivBytes paddedSize msg = do aead <- initAEAD @AES256 aesKey ivBytes msg' <- paddedMsg - let (authTag, msg'') = encryptAES aead msg' - header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg} - encHeader <- encryptOAEP k $ serializeHeader header - return $ encHeader <> msg'' + return $ AES.aeadSimpleEncrypt aead B.empty msg' authTagSize where len = B.length msg paddedMsg | len >= paddedSize = throwE CryptoLargeMsgError | otherwise = return (msg <> B.replicate (paddedSize - len) '#') -decrypt :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString -decrypt pk msg'' = do - let (encHeader, msg') = B.splitAt (private_size pk) msg'' - header <- decryptOAEP pk encHeader - Header {aesKey, ivBytes, authTag, msgSize} <- ExceptT . return $ parseHeader header +decryptAES :: Key -> IV -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString +decryptAES aesKey ivBytes msg authTag = do aead <- initAEAD @AES256 aesKey ivBytes - msg <- decryptAES aead msg' authTag - return $ B.take msgSize msg - -encryptAES :: AES.AEAD AES256 -> ByteString -> (AES.AuthTag, ByteString) -encryptAES aead plaintext = AES.aeadSimpleEncrypt aead B.empty plaintext authTagSize - -decryptAES :: AES.AEAD AES256 -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString -decryptAES aead ciphertext authTag = - maybeError CryptoDecryptError $ AES.aeadSimpleDecrypt aead B.empty ciphertext authTag + maybeError CryptoDecryptError $ AES.aeadSimpleDecrypt aead B.empty msg authTag initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c) initAEAD (Key aesKey) (IV ivBytes) = do @@ -189,15 +239,18 @@ initAEAD (Key aesKey) (IV ivBytes) = do cipher <- AES.cipherInit aesKey AES.aeadInit AES.AEAD_GCM cipher iv +randomAesKey :: IO Key +randomAesKey = Key <$> getRandomBytes aesKeySize + +randomIV :: IO IV +randomIV = IV <$> getRandomBytes (ivSize @AES256) + ivSize :: forall c. AES.BlockCipher c => Int ivSize = AES.blockSize (undefined :: c) makeIV :: AES.BlockCipher c => ByteString -> ExceptT CryptoError IO (AES.IV c) makeIV bs = maybeError CryptoIVError $ AES.makeIV bs -randomBytes :: Int -> ExceptT CryptoError IO ByteString -randomBytes n = ExceptT $ Right <$> getRandomBytes n - maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a maybeError e = maybe (throwE e) return @@ -253,12 +306,6 @@ privKeyP = do (private_size, private_n, private_d) <- keyParser_ return PrivateKey {private_size, private_n, private_d} -parsePubKey :: ByteString -> Either String PublicKey -parsePubKey = A.parseOnly (pubKeyP <* A.endOfInput) - -parsePrivKey :: ByteString -> Either String PrivateKey -parsePrivKey = A.parseOnly (privKeyP <* A.endOfInput) - keyParser_ :: Parser (Int, Integer, Integer) keyParser_ = (,,) <$> (A.decimal <* ",") <*> (intP <* ",") <*> intP where diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index 461c38c5e..85cb2f3a6 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -20,4 +20,7 @@ tsISO8601P :: Parser UTCTime tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill (== ' ') parse :: Parser a -> e -> (ByteString -> Either e a) -parse parser err = first (const err) . A.parseOnly (parser <* A.endOfInput) +parse parser err = first (const err) . parseAll parser + +parseAll :: Parser a -> (ByteString -> Either String a) +parseAll parser = A.parseOnly (parser <* A.endOfInput) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 94f49e24e..ad73e751a 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -13,7 +13,7 @@ module Simplex.Messaging.Protocol where import Control.Applicative ((<|>)) import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.Except import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Base64 @@ -28,8 +28,6 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Parsers import Simplex.Messaging.Transport import Simplex.Messaging.Util -import System.IO -import Text.Read data Party = Broker | Recipient | Sender deriving (Show) @@ -108,7 +106,7 @@ type MsgId = Encoded type MsgBody = ByteString -data ErrorType = PROHIBITED | SYNTAX Int | SIZE | AUTH | INTERNAL | DUPLICATE deriving (Show, Eq) +data ErrorType = PROHIBITED | SYNTAX Int | AUTH | INTERNAL | DUPLICATE deriving (Show, Eq) errBadTransmission :: Int errBadTransmission = 1 @@ -128,6 +126,16 @@ errNoQueueId = 5 errMessageBody :: Int errMessageBody = 6 +transmissionP :: Parser RawTransmission +transmissionP = do + signature <- segment + corrId <- segment + queueId <- segment + command <- A.takeByteString + return (signature, corrId, queueId, command) + where + segment = A.takeTill (== ' ') <* " " + commandP :: Parser Cmd commandP = "NEW " *> newCmd @@ -148,60 +156,47 @@ commandP = newCmd = Cmd SRecipient . NEW <$> C.pubKeyP idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P) keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP - sendCmd = Cmd SSender . SEND <$> A.takeWhile A.isDigit + sendCmd = do + size <- A.decimal <* A.space + Cmd SSender . SEND <$> A.take size <* A.space message = do msgId <- base64P <* A.space ts <- tsISO8601P <* A.space - Cmd SBroker . MSG msgId ts <$> A.takeWhile A.isDigit + size <- A.decimal <* A.space + Cmd SBroker . MSG msgId ts <$> A.take size <* A.space serverError = Cmd SBroker . ERR <$> errorType errorType = "PROHIBITED" $> PROHIBITED <|> "SYNTAX " *> (SYNTAX <$> A.decimal) - <|> "SIZE" $> SIZE <|> "AUTH" $> AUTH <|> "INTERNAL" $> INTERNAL +-- TODO ignore the end of block, no need to parse it parseCommand :: ByteString -> Either ErrorType Cmd -parseCommand = parse commandP $ SYNTAX errBadSMPCommand +parseCommand = parse (commandP <* " " <* A.takeByteString) $ SYNTAX errBadSMPCommand serializeCommand :: Cmd -> ByteString serializeCommand = \case Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializePubKey rKey Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializePubKey sKey - Cmd SRecipient cmd -> B.pack $ show cmd - Cmd SSender (SEND msgBody) -> "SEND" <> serializeMsg msgBody + Cmd SRecipient cmd -> bshow cmd + Cmd SSender (SEND msgBody) -> "SEND " <> serializeMsg msgBody Cmd SSender PING -> "PING" Cmd SBroker (MSG msgId ts msgBody) -> - B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts] <> serializeMsg msgBody + B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, serializeMsg msgBody] Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId] - Cmd SBroker (ERR err) -> "ERR " <> B.pack (show err) - Cmd SBroker resp -> B.pack $ show resp + Cmd SBroker (ERR err) -> "ERR " <> bshow err + Cmd SBroker resp -> bshow resp where - serializeMsg msgBody = " " <> B.pack (show $ B.length msgBody) <> "\r\n" <> msgBody + serializeMsg msgBody = bshow (B.length msgBody) <> " " <> msgBody <> " " -tPutRaw :: Handle -> RawTransmission -> IO () -tPutRaw h (signature, corrId, queueId, command) = do - putLn h signature - putLn h corrId - putLn h queueId - putLn h command - -tGetRaw :: Handle -> IO RawTransmission -tGetRaw h = do - signature <- getLn h - corrId <- getLn h - queueId <- getLn h - command <- getLn h - return (signature, corrId, queueId, command) - -tPut :: Handle -> SignedRawTransmission -> IO () -tPut h (C.Signature sig, t) = do - putLn h $ encode sig - putLn h t +tPut :: THandle -> SignedRawTransmission -> IO (Either TransportError ()) +tPut th (C.Signature sig, t) = + tPutEncrypted th $ encode sig <> " " <> t <> " " serializeTransmission :: Transmission -> ByteString serializeTransmission (CorrId corrId, queueId, command) = - B.intercalate "\r\n" [corrId, encode queueId, serializeCommand command] + B.intercalate " " [corrId, encode queueId, serializeCommand command] fromClient :: Cmd -> Either ErrorType Cmd fromClient = \case @@ -213,22 +208,28 @@ fromServer = \case cmd@(Cmd SBroker _) -> Right cmd _ -> Left PROHIBITED +tGetParse :: THandle -> IO (Either TransportError RawTransmission) +tGetParse th = (>>= parse transmissionP TransportParsingError) <$> tGetEncrypted th + -- | get client and server transmissions -- `fromParty` is used to limit allowed senders - `fromClient` or `fromServer` should be used -tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> Handle -> m SignedTransmissionOrError -tGet fromParty h = do - (signature, corrId, queueId, command) <- liftIO $ tGetRaw h - let decodedTransmission = liftM2 (,corrId,,command) (decode signature) (decode queueId) - either (const $ tError corrId) tParseLoadBody decodedTransmission +tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> THandle -> m SignedTransmissionOrError +tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate where + decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError + decodeParseValidate = \case + Right (signature, corrId, queueId, command) -> + let decodedTransmission = liftM2 (,corrId,,command) (decode signature) (decode queueId) + in either (const $ tError corrId) tParseValidate decodedTransmission + Left _ -> tError "" + tError :: ByteString -> m SignedTransmissionOrError tError corrId = return (C.Signature B.empty, (CorrId corrId, B.empty, Left $ SYNTAX errBadTransmission)) - tParseLoadBody :: RawTransmission -> m SignedTransmissionOrError - tParseLoadBody t@(sig, corrId, queueId, command) = do + tParseValidate :: RawTransmission -> m SignedTransmissionOrError + tParseValidate t@(sig, corrId, queueId, command) = do let cmd = parseCommand command >>= fromParty >>= tCredentials t - fullCmd <- either (return . Left) cmdWithMsgBody cmd - return (C.Signature sig, (CorrId corrId, queueId, fullCmd)) + return (C.Signature sig, (CorrId corrId, queueId, cmd)) tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd tCredentials (signature, _, queueId, _) cmd = case cmd of @@ -261,19 +262,3 @@ tGet fromParty h = do Cmd SRecipient _ | B.null signature || B.null queueId -> Left $ SYNTAX errNoCredentials | otherwise -> Right cmd - - cmdWithMsgBody :: Cmd -> m (Either ErrorType Cmd) - cmdWithMsgBody = \case - Cmd SSender (SEND sizeStr) -> - Cmd SSender . SEND <$$> getMsgBody sizeStr - Cmd SBroker (MSG msgId ts sizeStr) -> - Cmd SBroker . MSG msgId ts <$$> getMsgBody sizeStr - cmd -> return $ Right cmd - - getMsgBody :: MsgBody -> m (Either ErrorType MsgBody) - getMsgBody sizeStr = case readMaybe (B.unpack sizeStr) :: Maybe Int of - Just size -> liftIO $ do - body <- B.hGet h size - s <- getLn h - return $ if B.null s then Right body else Left SIZE - Nothing -> return $ Left INTERNAL diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index a76a916e9..130ff2190 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -15,6 +15,7 @@ module Simplex.Messaging.Server (runSMPServer, randomBytes) where import Control.Concurrent.STM (stateTVar) import Control.Monad +import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random @@ -59,11 +60,17 @@ runSMPServer cfg@ServerConfig {tcpPort} = do runClient :: (MonadUnliftIO m, MonadReader Env m) => Handle -> m () runClient h = do - liftIO $ putLn h "Welcome to SMP v0.2.0" + keyPair <- asks serverKeyPair + liftIO (runExceptT $ serverHandshake h keyPair) >>= \case + Right th -> runClientTransport th + Left _ -> pure () + +runClientTransport :: (MonadUnliftIO m, MonadReader Env m) => THandle -> m () +runClientTransport th = do q <- asks $ tbqSize . config c <- atomically $ newClient q s <- asks server - raceAny_ [send h c, client c s, receive h c] + raceAny_ [send th c, client c s, receive th c] `finally` cancelSubscribers c cancelSubscribers :: MonadUnliftIO m => Client -> m () @@ -75,7 +82,7 @@ cancelSub = \case Sub {subThread = SubThread t} -> killThread t _ -> return () -receive :: (MonadUnliftIO m, MonadReader Env m) => Handle -> Client -> m () +receive :: (MonadUnliftIO m, MonadReader Env m) => THandle -> Client -> m () receive h Client {rcvQ} = forever $ do (signature, (corrId, queueId, cmdOrError)) <- tGet fromClient h t <- case cmdOrError of @@ -83,7 +90,7 @@ receive h Client {rcvQ} = forever $ do Right cmd -> verifyTransmission (signature, (corrId, queueId, cmd)) atomically $ writeTBQueue rcvQ t -send :: MonadUnliftIO m => Handle -> Client -> m () +send :: MonadUnliftIO m => THandle -> Client -> m () send h Client {sndQ} = forever $ do t <- atomically $ readTBQueue sndQ liftIO $ tPut h ("", serializeTransmission t) diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index c2d170e05..126f00238 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -5,11 +5,13 @@ module Simplex.Messaging.Server.Env.STM where import Control.Concurrent (ThreadId) import Control.Monad.IO.Unlift +import qualified Crypto.PubKey.RSA as R import Crypto.Random import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Network.Socket (ServiceName) import Numeric.Natural +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.QueueStore.STM @@ -27,7 +29,9 @@ data Env = Env server :: Server, queueStore :: QueueStore, msgStore :: STMMsgStore, - idsDrg :: TVar ChaChaDRG + idsDrg :: TVar ChaChaDRG, + serverKeyPair :: C.KeyPair + -- serverId :: ByteString } data Server = Server @@ -72,4 +76,24 @@ newEnv config = do queueStore <- atomically newQueueStore msgStore <- atomically newMsgStore idsDrg <- drgNew >>= newTVarIO - return Env {config, server, queueStore, msgStore, idsDrg} + -- TODO these keys should be set in the environment, not in the code + return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair} + where + serverKeyPair = + ( C.PublicKey + { rsaPublicKey = + R.PublicKey + { public_size = 256, + public_n = 24491401566218566997383105010202223087300892576089255259580984651333137614713737618097624532507176450266480395052797332730303098565954279378701980313049999952643146946493842983667770915603693980339519205455913124235423278419181501399080069195664300809453039371169996023512911587381435574254546266774756319955237750224266282550919563293672568339958353047135257914364920805066749904289452712976534358633568668875150094910205741579097517675339029147403213185924413178887675432745168542469043448659751499651038006514754218441022754807971535895895877162103157702709155894482782232155817331812261258282431796597840952464257, + public_e = 8750208418393523480444709183090020123776537336553019181250117771363000810675051423462439348759073000328325050011503730211252469588880505946970399702607609166796825215104414212088697348613726705621594590369250976359268097976909710311654938358716518878047036682173044667792903503207106314854901036618348367397 + } + }, + C.PrivateKey + { private_size = 256, + private_n = 24491401566218566997383105010202223087300892576089255259580984651333137614713737618097624532507176450266480395052797332730303098565954279378701980313049999952643146946493842983667770915603693980339519205455913124235423278419181501399080069195664300809453039371169996023512911587381435574254546266774756319955237750224266282550919563293672568339958353047135257914364920805066749904289452712976534358633568668875150094910205741579097517675339029147403213185924413178887675432745168542469043448659751499651038006514754218441022754807971535895895877162103157702709155894482782232155817331812261258282431796597840952464257, + private_d = 7597313014691047671352664508683652467940113991200105893460705315744177757772923044415828427601194535604492873282390112577565179730319668643740113323630387082584239892956534048712048059175569855278723311295064858148623887611800385925820852572241607131360121661598015161261779381845187797044113149447495567589968956065009916550602209418325870594974390014927949966324558614396231902374868077411836997835082564279358230227298823445650053370542685308691044175390251929540772677009245507450972026595993054141350350385685400540681305852935721245601287301749047921282924410369389293829570448007237832101875085500166095784749 + } + ) + +-- public key hash: +-- "8Cvd+AYVxLpSsB/glEhVxkKuEzMNBFdAL5yr7p9DGGk=" diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index d0e2aa0e9..994366b02 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -1,21 +1,37 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Simplex.Messaging.Transport where -import Control.Monad.IO.Class +import Control.Monad.Except import Control.Monad.IO.Unlift -import Control.Monad.Reader +import Control.Monad.Trans.Except (throwE) +import Crypto.Cipher.Types (AuthTag) +import Crypto.Hash (hash) +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) +import Data.ByteArray (xor) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Set (Set) import qualified Data.Set as S +import Data.Word (Word32) import GHC.IO.Exception (IOErrorType (..)) +import GHC.IO.Handle.Internals (ioe_EOF) import Network.Socket +import Network.Transport.Internal (encodeWord32) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Parsers (parse, parseAll) +import Simplex.Messaging.Util (bshow, liftError) import System.IO import System.IO.Error import UnliftIO.Concurrent @@ -24,6 +40,8 @@ import qualified UnliftIO.Exception as E import qualified UnliftIO.IO as IO import UnliftIO.STM +-- * TCP transport + runTCPServer :: MonadUnliftIO m => ServiceName -> (Handle -> m ()) -> m () runTCPServer port server = do clients <- newTVarIO S.empty @@ -96,3 +114,177 @@ getLn h = trim_cr <$> B.hGetLine h where trim_cr "" = "" trim_cr s = if B.last s == '\r' then B.init s else s + +-- * Encrypted transport + +data SMPVersion = SMPVersion Int Int Int Int + deriving (Eq, Ord) + +major :: SMPVersion -> (Int, Int) +major (SMPVersion a b _ _) = (a, b) + +currentSMPVersion :: SMPVersion +currentSMPVersion = SMPVersion 0 2 0 0 + +serializeSMPVersion :: SMPVersion -> ByteString +serializeSMPVersion (SMPVersion a b c d) = B.intercalate "." [bshow a, bshow b, bshow c, bshow d] + +smpVersionP :: Parser SMPVersion +smpVersionP = + let ver = A.decimal <* A.char '.' + in SMPVersion <$> ver <*> ver <*> ver <*> A.decimal + +data THandle = THandle + { handle :: Handle, + sndKey :: SessionKey, + rcvKey :: SessionKey, + blockSize :: Int + } + +data SessionKey = SessionKey + { aesKey :: C.Key, + baseIV :: C.IV, + counter :: TVar Word32 + } + +data HandshakeKeys = HandshakeKeys + { sndKey :: SessionKey, + rcvKey :: SessionKey + } + +data TransportError + = TransportCryptoError C.CryptoError + | TransportParsingError + | TransportHandshakeError String + deriving (Eq, Show, Exception) + +tPutEncrypted :: THandle -> ByteString -> IO (Either TransportError ()) +tPutEncrypted THandle {handle = h, sndKey, blockSize} block = + encryptBlock sndKey (blockSize - C.authTagSize) block >>= \case + Left e -> return . Left $ TransportCryptoError e + Right (authTag, msg) -> Right <$> B.hPut h (C.authTagToBS authTag <> msg) + +tGetEncrypted :: THandle -> IO (Either TransportError ByteString) +tGetEncrypted THandle {handle = h, rcvKey, blockSize} = + B.hGet h blockSize >>= decryptBlock rcvKey >>= \case + Left e -> pure . Left $ TransportCryptoError e + Right "" -> ioe_EOF + Right msg -> pure $ Right msg + +encryptBlock :: SessionKey -> Int -> ByteString -> IO (Either C.CryptoError (AuthTag, ByteString)) +encryptBlock k@SessionKey {aesKey} size block = do + ivBytes <- makeNextIV k + runExceptT $ C.encryptAES aesKey ivBytes size block + +decryptBlock :: SessionKey -> ByteString -> IO (Either C.CryptoError ByteString) +decryptBlock k@SessionKey {aesKey} block = do + let (authTag, msg') = B.splitAt C.authTagSize block + ivBytes <- makeNextIV k + runExceptT $ C.decryptAES aesKey ivBytes msg' (C.bsToAuthTag authTag) + +makeNextIV :: SessionKey -> IO C.IV +makeNextIV SessionKey {baseIV, counter} = atomically $ do + c <- readTVar counter + writeTVar counter $ c + 1 + pure $ iv c + where + (start, rest) = B.splitAt 4 $ C.unIV baseIV + iv c = C.IV $ (start `xor` encodeWord32 c) <> rest + +-- | implements server transport handshake as per /rfcs/2021-01-26-crypto.md#transport-encryption +-- The numbers in function names refer to the steps in the document +serverHandshake :: Handle -> C.KeyPair -> ExceptT TransportError IO THandle +serverHandshake h (k, pk) = do + liftIO sendPublicKey_1 + encryptedKeys <- receiveEncryptedKeys_4 + HandshakeKeys {sndKey, rcvKey} <- decryptParseKeys_5 encryptedKeys + th <- liftIO $ transportHandle h rcvKey sndKey -- keys are swapped here + sendWelcome_6 th + pure th + where + sendPublicKey_1 :: IO () + sendPublicKey_1 = putLn h $ C.serializePubKey k + receiveEncryptedKeys_4 :: ExceptT TransportError IO ByteString + receiveEncryptedKeys_4 = + liftIO (B.hGet h $ C.publicKeySize k) >>= \case + "" -> throwE $ TransportHandshakeError "EOF" + ks -> pure ks + decryptParseKeys_5 :: ByteString -> ExceptT TransportError IO HandshakeKeys + decryptParseKeys_5 encKeys = + liftError TransportCryptoError (C.decryptOAEP pk encKeys) + >>= liftEither . parseHandshakeKeys + sendWelcome_6 :: THandle -> ExceptT TransportError IO () + sendWelcome_6 th = ExceptT . tPutEncrypted th $ serializeSMPVersion currentSMPVersion <> " " + +-- | implements client transport handshake as per /rfcs/2021-01-26-crypto.md#transport-encryption +-- The numbers in function names refer to the steps in the document +clientHandshake :: Handle -> Maybe C.KeyHash -> ExceptT TransportError IO THandle +clientHandshake h keyHash = do + k <- getPublicKey_1_2 + keys@HandshakeKeys {sndKey, rcvKey} <- liftIO generateKeys_3 + sendEncryptedKeys_4 k keys + th <- liftIO $ transportHandle h sndKey rcvKey + getWelcome_6 th >>= checkVersion + pure th + where + getPublicKey_1_2 :: ExceptT TransportError IO C.PublicKey + getPublicKey_1_2 = do + s <- liftIO $ getLn h + maybe (pure ()) (validateKeyHash_2 s) keyHash + liftEither $ parseKey s + parseKey :: ByteString -> Either TransportError C.PublicKey + parseKey = first TransportHandshakeError . parseAll C.pubKeyP + validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO () + validateKeyHash_2 k (C.KeyHash kHash) + | hash k == kHash = pure () + | otherwise = throwE $ TransportHandshakeError "wrong key hash" + generateKeys_3 :: IO HandshakeKeys + generateKeys_3 = HandshakeKeys <$> generateKey <*> generateKey + generateKey :: IO SessionKey + generateKey = do + aesKey <- C.randomAesKey + baseIV <- C.randomIV + pure SessionKey {aesKey, baseIV, counter = undefined} + sendEncryptedKeys_4 :: C.PublicKey -> HandshakeKeys -> ExceptT TransportError IO () + sendEncryptedKeys_4 k keys = + liftError TransportCryptoError (C.encryptOAEP k $ serializeHandshakeKeys keys) + >>= liftIO . B.hPut h + getWelcome_6 :: THandle -> ExceptT TransportError IO SMPVersion + getWelcome_6 th = ExceptT $ (>>= parseSMPVersion) <$> tGetEncrypted th + parseSMPVersion :: ByteString -> Either TransportError SMPVersion + parseSMPVersion = first TransportHandshakeError . A.parseOnly (smpVersionP <* A.space) + checkVersion :: SMPVersion -> ExceptT TransportError IO () + checkVersion smpVersion = + when (major smpVersion > major currentSMPVersion) . throwE $ + TransportHandshakeError "SMP server version" + +serializeHandshakeKeys :: HandshakeKeys -> ByteString +serializeHandshakeKeys HandshakeKeys {sndKey, rcvKey} = + serializeKey sndKey <> serializeKey rcvKey + where + serializeKey :: SessionKey -> ByteString + serializeKey SessionKey {aesKey, baseIV} = C.unKey aesKey <> C.unIV baseIV + +handshakeKeysP :: Parser HandshakeKeys +handshakeKeysP = HandshakeKeys <$> keyP <*> keyP + where + keyP :: Parser SessionKey + keyP = do + aesKey <- C.aesKeyP + baseIV <- C.ivP + pure SessionKey {aesKey, baseIV, counter = undefined} + +parseHandshakeKeys :: ByteString -> Either TransportError HandshakeKeys +parseHandshakeKeys = parse handshakeKeysP $ TransportHandshakeError "parsing keys" + +transportHandle :: Handle -> SessionKey -> SessionKey -> IO THandle +transportHandle h sk rk = do + sndCounter <- newTVarIO 0 + rcvCounter <- newTVarIO 0 + pure + THandle + { handle = h, + sndKey = sk {counter = sndCounter}, + rcvKey = rk {counter = rcvCounter}, + blockSize = 8192 + } diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index c3b7b0a5c..21fa7c063 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -13,6 +13,7 @@ import Control.Concurrent import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import SMPAgentClient +import SMPClient (teshKeyHashStr) import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import System.IO (Handle) @@ -139,8 +140,8 @@ syntaxTests = do -- TODO: add tests with defined connection alias xit "only server" $ ("211", "", "NEW localhost") >#>= \case ("211", "", "INV" : _) -> True; _ -> False it "with port" $ ("212", "", "NEW localhost:5000") >#>= \case ("212", "", "INV" : _) -> True; _ -> False - xit "with keyHash" $ ("213", "", "NEW localhost#1234") >#>= \case ("213", "", "INV" : _) -> True; _ -> False - it "with port and keyHash" $ ("214", "", "NEW localhost:5000#1234") >#>= \case ("214", "", "INV" : _) -> True; _ -> False + xit "with keyHash" $ ("213", "", "NEW localhost#" <> teshKeyHashStr) >#>= \case ("213", "", "INV" : _) -> True; _ -> False + it "with port and keyHash" $ ("214", "", "NEW localhost:5000#" <> teshKeyHashStr) >#>= \case ("214", "", "INV" : _) -> True; _ -> False describe "invalid" do -- TODO: add tests with defined connection alias it "no parameters" $ ("221", "", "NEW") >#> ("221", "", "ERR SYNTAX 11") diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index fe6593c88..38b759112 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -13,6 +13,7 @@ import Data.Time import Data.Word (Word32) import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) +import SMPClient (teshKeyHash) import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite import Simplex.Messaging.Agent.Transmission @@ -96,7 +97,7 @@ testForeignKeysEnabled = do rcvQueue1 :: RcvQueue rcvQueue1 = RcvQueue - { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + { server = SMPServer "smp.simplex.im" (Just "5223") teshKeyHash, rcvId = "1234", connAlias = "conn1", rcvPrivateKey = C.PrivateKey 1 2 3, @@ -110,7 +111,7 @@ rcvQueue1 = sndQueue1 :: SndQueue sndQueue1 = SndQueue - { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + { server = SMPServer "smp.simplex.im" (Just "5223") teshKeyHash, sndId = "3456", connAlias = "conn1", sndPrivateKey = C.PrivateKey 1 2 3, @@ -156,7 +157,7 @@ testGetAllConnAliases = do testGetRcvQueue :: SpecWith SQLiteStore testGetRcvQueue = do it "should get RcvQueue" $ \store -> do - let smpServer = SMPServer "smp.simplex.im" (Just "5223") (Just "1234") + let smpServer = SMPServer "smp.simplex.im" (Just "5223") teshKeyHash let recipientId = "1234" createRcvConn store rcvQueue1 `returnsResult` () @@ -211,7 +212,7 @@ testUpgradeRcvConnToDuplex = do `returnsResult` () let anotherSndQueue = SndQueue - { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + { server = SMPServer "smp.simplex.im" (Just "5223") teshKeyHash, sndId = "2345", connAlias = "conn1", sndPrivateKey = C.PrivateKey 1 2 3, @@ -233,7 +234,7 @@ testUpgradeSndConnToDuplex = do `returnsResult` () let anotherRcvQueue = RcvQueue - { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"), + { server = SMPServer "smp.simplex.im" (Just "5223") teshKeyHash, rcvId = "3456", connAlias = "conn1", rcvPrivateKey = C.PrivateKey 1 2 3, diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 0cde0e740..4c36c2db9 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,13 +1,19 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module SMPClient where +import Control.Monad (void) +import Control.Monad.Except (runExceptT) import Control.Monad.IO.Unlift import Crypto.Random +import Data.ByteString.Base64 (encode) +import qualified Data.ByteString.Char8 as B import Network.Socket +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Server import Simplex.Messaging.Server.Env.STM @@ -15,7 +21,6 @@ import Simplex.Messaging.Transport import Test.Hspec import UnliftIO.Concurrent import qualified UnliftIO.Exception as E -import UnliftIO.IO testHost :: HostName testHost = "localhost" @@ -23,14 +28,19 @@ testHost = "localhost" testPort :: ServiceName testPort = "5000" -testSMPClient :: MonadUnliftIO m => (Handle -> m a) -> m a +teshKeyHashStr :: B.ByteString +teshKeyHashStr = "8Cvd+AYVxLpSsB/glEhVxkKuEzMNBFdAL5yr7p9DGGk=" + +teshKeyHash :: Maybe C.KeyHash +teshKeyHash = Just "8Cvd+AYVxLpSsB/glEhVxkKuEzMNBFdAL5yr7p9DGGk=" + +testSMPClient :: MonadUnliftIO m => (THandle -> m a) -> m a testSMPClient client = do threadDelay 250_000 -- TODO hack: thread delay for SMP server to start - runTCPClient testHost testPort $ \h -> do - line <- liftIO $ getLn h - if line == "Welcome to SMP v0.2.0" - then client h - else error "not connected" + runTCPClient testHost testPort $ \h -> + liftIO (runExceptT $ clientHandshake h teshKeyHash) >>= \case + Right th -> client th + Left e -> error $ show e cfg :: ServerConfig cfg = @@ -53,33 +63,43 @@ withSmpServerOn port = withSmpServerThreadOn port . const withSmpServer :: (MonadUnliftIO m, MonadRandom m) => m a -> m a withSmpServer = withSmpServerOn testPort -runSmpTest :: (MonadUnliftIO m, MonadRandom m) => (Handle -> m a) -> m a +runSmpTest :: (MonadUnliftIO m, MonadRandom m) => (THandle -> m a) -> m a runSmpTest test = withSmpServer $ testSMPClient test -runSmpTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => Int -> ([Handle] -> m a) -> m a +runSmpTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => Int -> ([THandle] -> m a) -> m a runSmpTestN nClients test = withSmpServer $ run nClients [] where - run :: Int -> [Handle] -> m a + run :: Int -> [THandle] -> m a run 0 hs = test hs run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) smpServerTest :: RawTransmission -> IO RawTransmission smpServerTest cmd = runSmpTest $ \h -> tPutRaw h cmd >> tGetRaw h -smpTest :: (Handle -> IO ()) -> Expectation +smpTest :: (THandle -> IO ()) -> Expectation smpTest test' = runSmpTest test' `shouldReturn` () -smpTestN :: Int -> ([Handle] -> IO ()) -> Expectation +smpTestN :: Int -> ([THandle] -> IO ()) -> Expectation smpTestN n test' = runSmpTestN n test' `shouldReturn` () -smpTest2 :: (Handle -> Handle -> IO ()) -> Expectation +smpTest2 :: (THandle -> THandle -> IO ()) -> Expectation smpTest2 test' = smpTestN 2 _test where _test [h1, h2] = test' h1 h2 _test _ = error "expected 2 handles" -smpTest3 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation +smpTest3 :: (THandle -> THandle -> THandle -> IO ()) -> Expectation smpTest3 test' = smpTestN 3 _test where _test [h1, h2, h3] = test' h1 h2 h3 _test _ = error "expected 3 handles" + +tPutRaw :: THandle -> RawTransmission -> IO () +tPutRaw h (sig, corrId, queueId, command) = do + let t = B.intercalate " " [corrId, queueId, command] + void $ tPut h (C.Signature sig, t) + +tGetRaw :: THandle -> IO RawTransmission +tGetRaw h = do + ("", (CorrId corrId, qId, Right cmd)) <- tGet fromServer h + pure ("", corrId, encode qId, serializeCommand cmd) diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 4a8c8766c..341bdbdf3 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -13,7 +13,7 @@ import qualified Data.ByteString.Char8 as B import SMPClient import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol -import System.IO (Handle) +import Simplex.Messaging.Transport import System.Timeout import Test.HUnit import Test.Hspec @@ -34,14 +34,14 @@ serverTests = do pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmissionOrError pattern Resp corrId queueId command <- ("", (corrId, queueId, Right (Cmd SBroker command))) -sendRecv :: Handle -> (ByteString, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +sendRecv :: THandle -> (ByteString, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError sendRecv h (sgn, corrId, qId, cmd) = tPutRaw h (sgn, corrId, encode qId, cmd) >> tGet fromServer h -signSendRecv :: Handle -> C.PrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +signSendRecv :: THandle -> C.PrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError signSendRecv h pk (corrId, qId, cmd) = do - let t = B.intercalate "\r\n" [corrId, encode qId, cmd] + let t = B.intercalate " " [corrId, encode qId, cmd] Right sig <- C.sign pk t - tPut h (sig, t) + _ <- tPut h (sig, t) tGet fromServer h cmdSEND :: ByteString -> ByteString @@ -61,7 +61,7 @@ testCreateSecure = Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) (rId1, "") #== "creates queue" - Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5\r\nhello") + Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ") (ok1, OK) #== "accepts unsigned SEND" (sId1, sId) #== "same queue ID in response 1" @@ -75,7 +75,7 @@ testCreateSecure = (err6, ERR PROHIBITED) #== "replies ERR when message acknowledged without messages" (sPub, sKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5\r\nhello") + Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" @@ -93,7 +93,7 @@ testCreateSecure = Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, keyCmd) (err4, ERR AUTH) #== "rejects KEY if already secured" - Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11\r\nhello again") + Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11 hello again ") (ok3, OK) #== "accepts signed SEND" Resp "" _ (MSG _ _ msg) <- tGet fromServer h @@ -102,7 +102,7 @@ testCreateSecure = Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, "ACK") (ok5, OK) #== "replies OK when message acknowledged 2" - Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, "SEND 5\r\nhello") + Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, "SEND 5 hello ") (err5, ERR AUTH) #== "rejects unsigned SEND" testCreateDelete :: Spec @@ -117,10 +117,10 @@ testCreateDelete = Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub) (ok1, OK) #== "secures queue" - Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5\r\nhello") + Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ") (ok2, OK) #== "accepts signed SEND" - Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND 7\r\nhello 2") + Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND 7 hello 2 ") (ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed" Resp "" _ (MSG _ _ msg1) <- tGet fromServer rh @@ -136,10 +136,10 @@ testCreateDelete = (ok3, OK) #== "suspends queue" (rId2, rId) #== "same queue ID in response 2" - Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND 5\r\nhello") + Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND 5 hello ") (err3, ERR AUTH) #== "rejects signed SEND" - Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, "SEND 5\r\nhello") + Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, "SEND 5 hello ") (err4, ERR AUTH) #== "reject unsigned SEND too" Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, "OFF") @@ -158,10 +158,10 @@ testCreateDelete = (ok6, OK) #== "deletes queue" (rId3, rId) #== "same queue ID in response 3" - Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND 5\r\nhello") + Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ") (err7, ERR AUTH) #== "rejects signed SEND when deleted" - Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, "SEND 5\r\nhello") + Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, "SEND 5 hello ") (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted" Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, "ACK") @@ -211,7 +211,7 @@ testDuplex = (aliceKey, C.serializePubKey asPub) #== "key received from Alice" Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey) - Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8\r\nhi alice") + Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8 hi alice ") Resp "" _ (MSG _ _ msg4) <- tGet fromServer alice Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "ACK") @@ -229,7 +229,7 @@ testSwitchSub = smpTest3 \rh1 rh2 sh -> do (rPub, rKey) <- C.generateKeyPair rsaKeySize Resp "abcd" _ (IDS rId sId) <- signSendRecv rh1 rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) - Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND 5\r\ntest1") + Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND 5 test1 ") (ok1, OK) #== "sent test message 1" Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK") (ok2, OK) #== "sent test message 2" @@ -246,7 +246,7 @@ testSwitchSub = Resp "" _ end <- tGet fromServer rh1 (end, END) #== "unsubscribed the 1st TCP connection" - Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5\r\ntest3") + Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5 test3 ") Resp "" _ (MSG _ _ msg3) <- tGet fromServer rh2 (msg3, "test3") #== "delivered to the 2nd TCP connection" @@ -280,13 +280,13 @@ syntaxTests = do noParamsSyntaxTest "OFF" noParamsSyntaxTest "DEL" describe "SEND" do - it "valid syntax 1" $ ("1234", "cdab", "12345678", "SEND 5\r\nhello") >#> ("", "cdab", "12345678", "ERR AUTH") - it "valid syntax 2" $ ("1234", "dabc", "12345678", "SEND 11\r\nhello there") >#> ("", "dabc", "12345678", "ERR AUTH") + it "valid syntax 1" $ ("1234", "cdab", "12345678", "SEND 5 hello ") >#> ("", "cdab", "12345678", "ERR AUTH") + it "valid syntax 2" $ ("1234", "dabc", "12345678", "SEND 11 hello there ") >#> ("", "dabc", "12345678", "ERR AUTH") it "no parameters" $ ("1234", "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR SYNTAX 2") - it "no queue ID" $ ("1234", "bcda", "", "SEND 5\r\nhello") >#> ("", "bcda", "", "ERR SYNTAX 5") - it "bad message body 1" $ ("1234", "cdab", "12345678", "SEND 11 hello") >#> ("", "cdab", "12345678", "ERR SYNTAX 2") - it "bad message body 2" $ ("1234", "dabc", "12345678", "SEND hello") >#> ("", "dabc", "12345678", "ERR SYNTAX 2") - it "bigger body" $ ("1234", "abcd", "12345678", "SEND 4\r\nhello") >#> ("", "abcd", "12345678", "ERR SIZE") + it "no queue ID" $ ("1234", "bcda", "", "SEND 5 hello ") >#> ("", "bcda", "", "ERR SYNTAX 5") + it "bad message body 1" $ ("1234", "cdab", "12345678", "SEND 11 hello ") >#> ("", "cdab", "12345678", "ERR SYNTAX 2") + it "bad message body 2" $ ("1234", "dabc", "12345678", "SEND hello ") >#> ("", "dabc", "12345678", "ERR SYNTAX 2") + it "bigger body" $ ("1234", "abcd", "12345678", "SEND 4 hello ") >#> ("", "abcd", "12345678", "ERR SYNTAX 2") describe "PING" do it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG") describe "broker response not allowed" do @@ -295,6 +295,6 @@ syntaxTests = do noParamsSyntaxTest :: ByteString -> Spec noParamsSyntaxTest cmd = describe (B.unpack cmd) do it "valid syntax" $ ("1234", "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH") - it "parameters" $ ("1234", "bcda", "12345678", cmd <> " 1") >#> ("", "bcda", "12345678", "ERR SYNTAX 2") + it "wrong terminator" $ ("1234", "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR SYNTAX 2") it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR SYNTAX 3") it "no queue ID" $ ("1234", "dabc", "", cmd) >#> ("", "dabc", "", "ERR SYNTAX 3")