packages feed

simplexmq 0.5.2 → 1.0.0

raw patch · 47 files changed

+5749/−3357 lines, 47 filesdep +aesondep +data-defaultdep +process

Dependencies added: aeson, data-default, process, tls, x509-store, x509-validation

Files

CHANGELOG.md view
@@ -1,3 +1,28 @@+# 1.0.0++Security and privacy improvements:+- Faster and more secure 2-layer E2E encryption with additional encryption layer between servers and recipients:+  - application messages in each duplex connection (managed by SMP agents - see [overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md)) are encrypted using [double-ratchet algorithm](https://www.signal.org/docs/specifications/doubleratchet/), providing forward secrecy and break-in recovery. This layer uses two Curve448 keys per client for [X3DH key agreement](https://www.signal.org/docs/specifications/x3dh/), SHA512 based HKDFs and AES-GCM AEAD encryption.+  - SMP client messages are additionally E2E encrypted in each SMP queue to avoid cipher-text correlation of messages sent via multiple redundant queues (that will be supported soon). This and the next layer use [NaCl crypto_box algorithm](https://nacl.cr.yp.to/index.html) with XSalsa20Poly1305 cipher and Curve25519 keys for DH key agreement.+  - Messages delivered from the servers to the recipients are additionally encrypted to avoid cipher-text correlation between sent and received messages.+- To prevent any traffic correlation by content size, SimpleX uses fixed transport block size of 16kb (16384 bytes) with padding on all encryption layers:+  - application messages are padded to 15788 bytes before E2E double-ratchet encryption.+  - messages between SMP clients are padded to 16032 bytes before E2E encryption in each SMP queue.+  - messages from the server to the recipient are padded to padded to 16088 bytes before the additional encryption layer (see above).+- TLS 1.2+ with tls-unique channel binding in each command to prevent replay attacks.+- Server identity verification via server offline certificate fingerprints included in SMP server addresses.++New functionality:+- Support for notification servers with new SMP commands: `NKEY`/`NID`, `NSUB`/`NMSG`.++Efficiency improvements:+- Binary protocol encodings to reduce overhead from circa 15% to approximately 3.7% of transmitted application message size, with only 2.2% overhead for SMP protocol messages.+- More performant cryptographic algorithms.++For more information about SimpleX:+- [SimpleX overview](https://github.com/simplex-chat/simplexmq/blob/master/protocol/overview-tjr.md).+- [SimpleX chat v1 announcement](https://github.com/simplex-chat/simplex-chat/blob/master/blog/20220112-simplex-chat-v1-released.md).+ # 0.5.2  - Fix message delivery logic that blocked delivery of all server messages when server per-queue quota exceeded, making it concurrent per SMP queue, not per server.
README.md view
@@ -3,40 +3,57 @@ [![GitHub build](https://github.com/simplex-chat/simplexmq/workflows/build/badge.svg)](https://github.com/simplex-chat/simplexmq/actions?query=workflow%3Abuild) [![GitHub release](https://img.shields.io/github/v/release/simplex-chat/simplexmq)](https://github.com/simplex-chat/simplexmq/releases) -📢 **v0.5.1 brings a hotfix to the server's subscription management logic, to apply it log in to your server via SSH and run the following command. If you have store log enabled for your server, information about already established queues will be preserved.** If you're doing a custom installation instead of Linode or DigitalOcean you may have to change the path for binary download.+📢 SimpleXMQ v1 is released - with many security, privacy and efficiency improvements, new functionality - see [release notes](https://github.com/simplex-chat/simplexmq/releases/tag/v1.0.0). -```sh-systemctl stop smp-server-curl -L -o /opt/simplex/bin/smp-server https://github.com/simplex-chat/simplexmq/releases/download/v0.5.1/smp-server-ubuntu-20_04-x86-64-systemctl start smp-server-```+**Please note**: v1 is not backwards compatible, but it has the version negotiation built into all protocol layers for forwards compatibility of this version and backwards compatibility of the future versions, that will be backwards compatible for at least two versions back. +If you have a server deployed please deploy a new server to a new host and retire the previous version once it is no longer used.+ ## Message broker for unidirectional (simplex) queues  SimpleXMQ is a message broker for managing message queues and sending messages over public network. It consists of SMP server, SMP client library and SMP agent that implement [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md) for client-server communication and [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) to manage duplex connections via simplex queues on multiple SMP servers. -SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 8 client commands and 6 server responses.+SMP protocol is inspired by [Redis serialization protocol](https://redis.io/topics/protocol), but it is much simpler - it currently has only 10 client commands and 8 server responses.  SimpleXMQ is implemented in Haskell - it benefits from robust software transactional memory (STM) and concurrency primitives that Haskell provides.  ## SimpleXMQ roadmap -- SMP queue redundancy and rotation in SMP agent duplex connections.+- SimpleX service protocol and application template - to enable users building services and chat bots that work over SimpleX protocol stack. The first such service will be a notification service for a mobile app.+- SMP queue redundancy and rotation in SMP agent connections. - SMP agents synchronization to share connections and messages between multiple agents (it would allow using multiple devices for [simplex-chat](https://github.com/simplex-chat/simplex-chat)).-- Streams - high performance message queues. See [Streams RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-02-28-streams.md) for details.  ## Components  ### SMP server -[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution without any dependencies. It uses in-memory persistence with an optional append-only log of created queues that allows to re-start the server without losing the connections. This log is compacted on every server restart, permanently removing suspended and removed queues.+[SMP server](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs) can be run on any Linux distribution without any dependencies, including low power/low memory devices. It uses in-memory persistence with an optional append-only log of created queues that allows to re-start the server without losing the connections. This log is compacted on every server restart, permanently removing suspended and removed queues.  To enable the queue logging, uncomment `enable: on` option in `smp-server.ini` configuration file that is created the first time the server is started. -On the first start the server generates an RSA key pair for encrypted transport handshake and outputs hash of the public key every time it runs - this hash should be used as part of the server address: `<hostname>:5223#<key hash>`.+To initialize the server use `smp-server init` command - it will generate keys and certificates for TLS transport. The fingerprint of offline certificate is used as part of the server address to protect client/server connection against man-in-the-middle attacks: `smp://<fingerprint>@<hostname>:5223`.  SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md). +#### Running SMP server on MacOS++SMP server requires OpenSSL library for initialization. On MacOS OpenSSL library may be replaced with LibreSSL, which doesn't support required algorithms. Before initializing SMP server verify you have OpenSSL installed:++```sh+openssl version+```++If it says "LibreSSL", please install original OpenSSL:++```sh+brew update+brew install openssl+echo 'PATH="/opt/homebrew/opt/openssl@3/bin:$PATH"' >> ~/.zprofile # or follow whatever instructions brew suggests+. ~/.zprofile # or restart your terminal to start a new session+```++Now `openssl version` should be saying "OpenSSL". You can now run `smp-server init` to initialize your SMP server.+ ### SMP client library  [SMP client](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Client.hs) is a Haskell library to connect to SMP servers that allows to:@@ -56,32 +73,35 @@  ## Using SMP server and SMP agent -You can either run your own SMP server locally or deploy using [Linode StackScript](#deploy-smp-server-on-linode), or try local SMP agent with the deployed servers:+You can either run your own SMP server locally or deploy using [Linode StackScript](https://cloud.linode.com/stackscripts/748014), or try local SMP agent with the deployed servers: -`smp2.simplex.im#z5W2QLQ1Br3Yd6CoWg7bIq1bHdwK7Y8bEiEXBs/WfAg=` (London, UK)-`smp3.simplex.im#nxc7HnrnM8dOKgkMp008ub/9o9LXJlxlMrMpR+mfMQw=` (Fremont, CA)+<!-- TODO update --> +`smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im`+`smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im`+`smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im`+ It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.  [<img alt="Linode" src="https://raw.githubusercontent.com/simplex-chat/simplexmq/master/img/linode.svg" align="right" width="200">](https://cloud.linode.com/stackscripts/748014)  ## Deploy SMP server on Linode -You can get Linode [free credits](https://www.linode.com/lp/affiliate-referral/?irclickid=02-QkdTEpxyLW0W0EOSREQreUkB2DtzGE2lGTE0&irgwc=1&utm_source=impact) to deploy SMP server.+\* You can use free credit Linode offers when [creating a new account](https://www.linode.com/) to deploy an SMP server. -Deployment on [Linode](https://www.linode.com/) is performed via StackScripts, which serve as recipes for Linode instances, also called Linodes. To deploy SMP server on Linode:+Deployment on Linode is performed via StackScripts, which serve as recipes for Linode instances, also called Linodes. To deploy SMP server on Linode:  - Create a Linode account or login with an already existing one. - Open [SMP server StackScript](https://cloud.linode.com/stackscripts/748014) and click "Deploy New Linode". - You can optionally configure the following parameters:     - [SMP Server store log](#SMP-server) flag for queue persistence on server restart (recommended).-    - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) for attaching server info as tags to Linode (server address, public key hash, version) and adding A record to your 2nd level domain (Note: 2nd level e.g. `example.com` domain should be [created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scope should be read/write access to "linodes" (to update linode tags - you need them), and "domains" (to add A record for the 3rd level domain, e.g. `smp`).+    - [Linode API token](https://www.linode.com/docs/guides/getting-started-with-the-linode-api#get-an-access-token) for attaching server info as tags to Linode (server address, fingerprint, version) and adding A record to your 2nd level domain (Note: 2nd level e.g. `example.com` domain should be [created](https://cloud.linode.com/domains/create) in your account prior to deployment). The API token access scope should be read/write access to "linodes" (to create tags), and "domains" (to add A record for the 3rd level domain, e.g. `smp`).     - Domain name to use instead of Linode ip address, e.g. `smp.example.com`. - Choose the region and plan according to your requirements (for regular use Shared CPU Nanode should be sufficient).-- Provide ssh key to be able to connect to your Linode via ssh. This step is required if you haven't provided a Linode API token, because you will need to login to your Linode and get a public key hash either from the welcome message or from the file `/etc/opt/simplex/pub_key_hash` on your Linode after SMP server starts.+- Provide ssh key to be able to connect to your Linode via ssh. If you haven't provided a Linode API token this step is required to login to your Linode and get the server's fingerprint either from the welcome message or from the file `/etc/opt/simplex/fingerprint` after server starts. See [Linode's guide on ssh](https://www.linode.com/docs/guides/use-public-key-authentication-with-ssh/) . - Deploy your Linode. After it starts wait for SMP server to start and for tags to appear (if a Linode API token was provided). It may take up to 5 minutes depending on the connection speed on the Linode. Connecting Linode IP address to provided domain name may take some additional time.-- Get `hostname` and `hash` either from Linode tags (click on a tag and copy it's value from the browser search panel) or via ssh. Linode has a good [guide](https://www.linode.com/docs/guides/use-public-key-authentication-with-ssh/) about ssh.-- Great, your own SMP server is ready! Use `address#hash` as SMP server address in the client.+- Get `address` and `fingerprint` either from Linode tags (click on a tag and copy it's value from the browser search panel) or via ssh.+- Great, your own SMP server is ready! If you provided FQDN use `smp://<fingerprint>@<fqdn>` as SMP server address in the client, otherwise use `smp://<fingerprint>@<ip_address>`.  Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur. @@ -89,14 +109,16 @@  ## Deploy SMP server on DigitalOcean -You can deploy SMP server using [SimpleX Server 1-click app](https://marketplace.digitalocean.com/apps/simplex-server) from DigitalOcean marketplace:+\* When creating a DigitalOcean account you can use [this link](https://try.digitalocean.com/freetrialoffer/) to get free credit. (You would still be required either to provide your credit card details or make a confirmation pre-payment with PayPal) +To deploy SMP server use [SimpleX Server 1-click app](https://marketplace.digitalocean.com/apps/simplex-server) from DigitalOcean marketplace:+ - Create a DigitalOcean account or login with an already existing one. - Click 'Create SimpleX server Droplet' button.-- Choose the region and plan according to your requirements (cheapest Regular plan should be sufficient).-- Provide ssh key and confirm Droplet creation. -- SSH to created Droplet (`ssh root@<droplet_ip_address>`) to get SMP server public key hash - either from the welcome message or from `/etc/opt/simplex/pub_key_hash`. DigitalOcean has a good guide on [how to login to Droplet via ssh](https://docs.digitalocean.com/products/droplets/how-to/connect-with-ssh/).-- Great, your own SMP server is ready! Use `ip_address#hash` as SMP server address in the client.+- Choose the region and plan according to your requirements (Basic plan should be sufficient).+- Finalize Droplet creation.+- Open "Console" on your Droplet management page to get SMP server fingerprint - either from the welcome message or from `/etc/opt/simplex/fingerprint`. Alternatively you can manually SSH to created Droplet, see [instruction](https://docs.digitalocean.com/products/droplets/how-to/connect-with-ssh/).+- Great, your own SMP server is ready! Use `smp://<fingerprint>@<ip_address>` as SMP server address in the client.  Please submit an [issue](https://github.com/simplex-chat/simplexmq/issues) if any problems occur.
apps/smp-agent/Main.hs view
@@ -8,10 +8,10 @@ import qualified Data.List.NonEmpty as L import Simplex.Messaging.Agent (runSMPAgent) import Simplex.Messaging.Agent.Env.SQLite-import Simplex.Messaging.Transport (TCP, Transport (..))+import Simplex.Messaging.Transport (TLS, Transport (..))  cfg :: AgentConfig-cfg = defaultAgentConfig {smpServers = L.fromList ["localhost:5223#bU0K+bRg24xWW//lS0umO1Zdw/SXqpJNtm1/RrPLViE="]}+cfg = defaultAgentConfig {smpServers = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"]}  logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}@@ -20,4 +20,4 @@ main = do   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)   setLogLevel LogInfo -- LogError-  withGlobalLogging logCfg $ runSMPAgent (transport @TCP) cfg+  withGlobalLogging logCfg $ runSMPAgent (transport @TLS) cfg
apps/smp-server/Main.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -8,52 +9,27 @@ module Main where  import Control.Monad.Except-import Control.Monad.Trans.Except-import qualified Crypto.Store.PKCS8 as S-import Data.ByteString.Base64 (encode)+import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B-import Data.Char (toLower)+import Data.Either (fromRight) import Data.Ini (Ini, lookupValue, readIniFile)-import Data.Text (Text)+import Data.Maybe (fromMaybe) import qualified Data.Text as T-import Data.X509 (PrivKey (PrivKeyRSA))-import Network.Socket (ServiceName)+import Data.X509.Validation (Fingerprint (..))+import Network.Socket (HostName, ServiceName) import Options.Applicative-import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Encoding.String import Simplex.Messaging.Server (runSMPServer) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog, storeLogFilePath)-import Simplex.Messaging.Transport (ATransport (..), TCP, Transport (..))+import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..), loadFingerprint, simplexMQVersion) import Simplex.Messaging.Transport.WebSockets (WS)-import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive) import System.Exit (exitFailure) import System.FilePath (combine)-import System.IO (IOMode (..), hFlush, stdout)-import Text.Read (readEither)--defaultServerPort :: ServiceName-defaultServerPort = "5223"--defaultBlockSize :: Int-defaultBlockSize = 4096--serverConfig :: ServerConfig-serverConfig =-  ServerConfig-    { tbqSize = 16,-      serverTbqSize = 128,-      msgQueueQuota = 256,-      queueIdBytes = 12,-      msgIdBytes = 6,-      -- below parameters are set based on ini file /etc/opt/simplex/smp-server.ini-      transports = undefined,-      storeLog = undefined,-      blockSize = undefined,-      serverPrivateKey = undefined-    }--newKeySize :: Int-newKeySize = 2048 `div` 8+import System.IO (IOMode (..), hGetLine, withFile)+import System.Process (readCreateProcess, shell)+import Text.Read (readMaybe)  cfgDir :: FilePath cfgDir = "/etc/opt/simplex"@@ -61,217 +37,280 @@ logDir :: FilePath logDir = "/var/opt/simplex" -defaultStoreLogFile :: FilePath-defaultStoreLogFile = combine logDir "smp-server-store.log"- iniFile :: FilePath iniFile = combine cfgDir "smp-server.ini" -defaultKeyFile :: FilePath-defaultKeyFile = combine cfgDir "server_key"+storeLogFile :: FilePath+storeLogFile = combine logDir "smp-server-store.log" -main :: IO ()-main = do-  opts <- getServerOpts-  case serverCommand opts of-    ServerInit ->-      runExceptT (getConfig opts) >>= \case-        Right cfg -> do-          putStrLn "Error: server is already initialized. Start it with `smp-server start` command"-          printConfig cfg-          exitFailure-        Left _ -> do-          cfg <- initializeServer opts-          putStrLn "Server was initialized. Start it with `smp-server start` command"-          printConfig cfg-    ServerStart ->-      runExceptT (getConfig opts) >>= \case-        Right cfg -> runServer cfg-        Left e -> do-          putStrLn $ "Server is not initialized: " <> e-          putStrLn "Initialize server with `smp-server init` command"-          exitFailure-    ServerDelete -> do-      deleteServer-      putStrLn "Server key, config file and store log deleted"+caKeyFile :: FilePath+caKeyFile = combine cfgDir "ca.key" -getConfig :: ServerOpts -> ExceptT String IO ServerConfig-getConfig opts = do-  ini <- readIni-  pk <- readKey ini-  storeLog <- liftIO $ openStoreLog opts ini-  pure $ makeConfig ini pk storeLog+caCrtFile :: FilePath+caCrtFile = combine cfgDir "ca.crt" -makeConfig :: IniOpts -> C.FullPrivateKey -> Maybe (StoreLog 'ReadMode) -> ServerConfig-makeConfig IniOpts {serverPort, blockSize, enableWebsockets} pk storeLog =-  let transports = (serverPort, transport @TCP) : [("80", transport @WS) | enableWebsockets]-   in serverConfig {serverPrivateKey = pk, storeLog, blockSize, transports}+serverKeyFile :: FilePath+serverKeyFile = combine cfgDir "server.key" -printConfig :: ServerConfig -> IO ()-printConfig ServerConfig {serverPrivateKey, storeLog} = do-  B.putStrLn $ "transport key hash: " <> serverKeyHash serverPrivateKey-  putStrLn $ case storeLog of-    Just s -> "store log: " <> storeLogFilePath s-    Nothing -> "store log disabled"+serverCrtFile :: FilePath+serverCrtFile = combine cfgDir "server.crt" -initializeServer :: ServerOpts -> IO ServerConfig-initializeServer opts = do-  createDirectoryIfMissing False cfgDir-  ini <- createIni opts-  pk <- createKey ini-  storeLog <- openStoreLog opts ini-  pure $ makeConfig ini pk storeLog+fingerprintFile :: FilePath+fingerprintFile = combine cfgDir "fingerprint" -runServer :: ServerConfig -> IO ()-runServer cfg = do-  printConfig cfg-  forM_ (transports cfg) $ \(port, ATransport t) ->-    putStrLn $ "listening on port " <> port <> " (" <> transportName t <> ")"-  runSMPServer cfg+main :: IO ()+main = do+  getCliCommand >>= \case+    Init opts ->+      doesFileExist iniFile >>= \case+        True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `smp-server start`."+        _ -> initializeServer opts+    Start ->+      doesFileExist iniFile >>= \case+        True -> readIniFile iniFile >>= either exitError (runServer . mkIniOptions)+        _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `smp-server init`."+    Delete -> cleanup >> putStrLn "Deleted configuration and log files" -deleteServer :: IO ()-deleteServer = do-  ini <- runExceptT readIni-  deleteIfExists iniFile-  case ini of-    Right IniOpts {storeLogFile, serverKeyFile} -> do-      deleteIfExists storeLogFile-      deleteIfExists serverKeyFile-    Left _ -> do-      deleteIfExists defaultKeyFile-      deleteIfExists defaultStoreLogFile+exitError :: String -> IO ()+exitError msg = putStrLn msg >> exitFailure -data IniOpts = IniOpts+data CliCommand+  = Init InitOptions+  | Start+  | Delete++data InitOptions = InitOptions   { enableStoreLog :: Bool,-    storeLogFile :: FilePath,-    serverKeyFile :: FilePath,-    serverPort :: ServiceName,-    blockSize :: Int,-    enableWebsockets :: Bool+    signAlgorithm :: SignAlgorithm,+    ip :: HostName,+    fqdn :: Maybe HostName   }+  deriving (Show) -readIni :: ExceptT String IO IniOpts-readIni = do-  fileExists iniFile-  ini <- ExceptT $ readIniFile iniFile-  let enableStoreLog = (== Right "on") $ lookupValue "STORE_LOG" "enable" ini-      storeLogFile = opt defaultStoreLogFile "STORE_LOG" "file" ini-      serverKeyFile = opt defaultKeyFile "TRANSPORT" "key_file" ini-      serverPort = opt defaultServerPort "TRANSPORT" "port" ini-      enableWebsockets = (== Right "on") $ lookupValue "TRANSPORT" "websockets" ini-  blockSize <- liftEither . readEither $ opt (show defaultBlockSize) "TRANSPORT" "block_size" ini-  pure IniOpts {enableStoreLog, storeLogFile, serverKeyFile, serverPort, blockSize, enableWebsockets}+data SignAlgorithm = ED448 | ED25519+  deriving (Read, Show)++getCliCommand :: IO CliCommand+getCliCommand =+  customExecParser+    (prefs showHelpOnEmpty)+    ( info+        (helper <*> versionOption <*> cliCommandP)+        (header version <> fullDesc)+    )   where-    opt :: String -> Text -> Text -> Ini -> String-    opt def section key ini = either (const def) T.unpack $ lookupValue section key ini+    versionOption = infoOption version (long "version" <> short 'v' <> help "Show version") -createIni :: ServerOpts -> IO IniOpts-createIni ServerOpts {enableStoreLog} = do-  writeFile iniFile $-    "[STORE_LOG]\n\-    \# The server uses STM memory to store SMP queues and messages,\n\-    \# that will be lost on restart (e.g., as with redis).\n\-    \# This option enables saving SMP queues to append only log,\n\-    \# and restoring them when the server is started.\n\-    \# Log is compacted on start (deleted queues are removed).\n\-    \# The messages in the queues are not logged.\n\n"-      <> (if enableStoreLog then "" else "# ")-      <> "enable: on\n\-         \# file: "-      <> defaultStoreLogFile-      <> "\n\n\-         \[TRANSPORT]\n\n\-         \# key_file: "-      <> defaultKeyFile-      <> "\n\-         \# port: "-      <> defaultServerPort-      <> "\n\-         \# block_size: "-      <> show defaultBlockSize-      <> "\n\-         \websockets: on\n"-  pure-    IniOpts-      { enableStoreLog,-        storeLogFile = defaultStoreLogFile,-        serverKeyFile = defaultKeyFile,-        serverPort = defaultServerPort,-        blockSize = defaultBlockSize,-        enableWebsockets = True-      }+cliCommandP :: Parser CliCommand+cliCommandP =+  hsubparser+    ( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files"))+        <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))+        <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))+    )+  where+    initP :: Parser CliCommand+    initP =+      Init+        <$> ( InitOptions+                <$> switch+                  ( long "store-log"+                      <> short 'l'+                      <> help "Enable store log for SMP queues persistence"+                  )+                <*> option+                  (maybeReader readMaybe)+                  ( long "sign-algorithm"+                      <> short 'a'+                      <> help "Signature algorithm used for TLS certificates: ED25519, ED448"+                      <> value ED448+                      <> showDefault+                      <> metavar "ALG"+                  )+                <*> strOption+                  ( long "ip"+                      <> help+                        "Server IP address used as Subject Alternative Name for TLS online certificate, \+                        \also used as Common Name if FQDN is not supplied"+                      <> value "127.0.0.1"+                      <> showDefault+                      <> metavar "IP"+                  )+                <*> (optional . strOption)+                  ( long "fqdn"+                      <> short 'n'+                      <> help "Server FQDN used as Common Name and Subject Alternative Name for TLS online certificate"+                      <> showDefault+                      <> metavar "FQDN"+                  )+            ) -readKey :: IniOpts -> ExceptT String IO C.FullPrivateKey-readKey IniOpts {serverKeyFile} = do-  fileExists serverKeyFile-  liftIO (S.readKeyFile serverKeyFile) >>= \case-    [S.Unprotected (PrivKeyRSA pk)] -> pure $ C.FullPrivateKey pk-    [_] -> err "not RSA key"-    [] -> err "invalid key file format"-    _ -> err "more than one key"+initializeServer :: InitOptions -> IO ()+initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do+  cleanup+  createDirectoryIfMissing True cfgDir+  createDirectoryIfMissing True logDir+  createX509+  fp <- saveFingerprint+  createIni+  putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `smp-server start` to start server."+  printServiceInfo fp+  warnCAPrivateKeyFile   where-    err :: String -> ExceptT String IO b-    err e = throwE $ e <> ": " <> serverKeyFile+    createX509 = do+      createOpensslCaConf+      createOpensslServerConf+      -- CA certificate (identity/offline)+      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile+      run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile+      -- server certificate (online)+      run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile+      run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile+      run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile+      where+        run cmd = void $ readCreateProcess (shell cmd) ""+        opensslCaConfFile = combine cfgDir "openssl_ca.conf"+        opensslServerConfFile = combine cfgDir "openssl_server.conf"+        serverCsrFile = combine cfgDir "server.csr"+        createOpensslCaConf =+          writeFile+            opensslCaConfFile+            "[req]\n\+            \distinguished_name = req_distinguished_name\n\+            \prompt = no\n\n\+            \[req_distinguished_name]\n\+            \CN = SMP server CA\n\+            \O = SimpleX\n\n\+            \[v3]\n\+            \subjectKeyIdentifier = hash\n\+            \authorityKeyIdentifier = keyid:always\n\+            \basicConstraints = critical,CA:true\n"+        -- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5+        -- IP and FQDN can't both be used as server address interchangeably even if IP is added+        -- as Subject Alternative Name, unless the following validation hook is disabled:+        -- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName+        createOpensslServerConf =+          writeFile+            opensslServerConfFile+            ( "[req]\n\+              \distinguished_name = req_distinguished_name\n\+              \prompt = no\n\n\+              \[req_distinguished_name]\n"+                <> ("CN = " <> cn <> "\n\n")+                <> "[v3]\n\+                   \basicConstraints = CA:FALSE\n\+                   \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\+                   \extendedKeyUsage = serverAuth\n"+            )+          where+            cn = fromMaybe ip fqdn -createKey :: IniOpts -> IO C.FullPrivateKey-createKey IniOpts {serverKeyFile} = do-  (_, pk) <- C.generateKeyPair newKeySize-  S.writeKeyFile S.TraditionalFormat serverKeyFile [PrivKeyRSA $ C.rsaPrivateKey pk]-  pure pk+    saveFingerprint = do+      Fingerprint fp <- loadFingerprint caCrtFile+      withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)+      pure fp -fileExists :: FilePath -> ExceptT String IO ()-fileExists path = do-  exists <- liftIO $ doesFileExist path-  unless exists . throwE $ "file " <> path <> " not found"+    createIni = do+      writeFile iniFile $+        "[STORE_LOG]\n\+        \# The server uses STM memory to store SMP queues and messages,\n\+        \# that will be lost on restart (e.g., as with redis).\n\+        \# This option enables saving SMP queues to append only log,\n\+        \# and restoring them when the server is started.\n\+        \# Log is compacted on start (deleted queues are removed).\n\+        \# The messages in the queues are not logged.\n"+          <> ("enable: " <> (if enableStoreLog then "on" else "off  # on") <> "\n\n")+          <> "[TRANSPORT]\n\+             \port: 5223\n\+             \websockets: off\n" -deleteIfExists :: FilePath -> IO ()-deleteIfExists path = doesFileExist path >>= (`when` removeFile path)+    warnCAPrivateKeyFile =+      putStrLn $+        "----------\n\+        \You should store CA private key securely and delete it from the server.\n\+        \If server TLS credential is compromised this key can be used to sign a new one, \+        \keeping the same server identity and established connections.\n\+        \CA private key location:\n"+          <> caKeyFile+          <> "\n----------" -confirm :: String -> IO ()-confirm msg = do-  putStr $ msg <> " (y/N): "-  hFlush stdout-  ok <- getLine-  when (map toLower ok /= "y") exitFailure+data IniOptions = IniOptions+  { enableStoreLog :: Bool,+    port :: ServiceName,+    enableWebsockets :: Bool+  } -serverKeyHash :: C.FullPrivateKey -> B.ByteString-serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey'+-- TODO ? properly parse ini as a whole+mkIniOptions :: Ini -> IniOptions+mkIniOptions ini =+  IniOptions+    { enableStoreLog = (== "on") $ strict "STORE_LOG" "enable",+      port = T.unpack $ strict "TRANSPORT" "port",+      enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets"+    }+  where+    strict :: String -> String -> T.Text+    strict section key =+      fromRight (error ("no key " <> key <> " in section " <> section)) $+        lookupValue (T.pack section) (T.pack key) ini -openStoreLog :: ServerOpts -> IniOpts -> IO (Maybe (StoreLog 'ReadMode))-openStoreLog ServerOpts {enableStoreLog = l} IniOpts {enableStoreLog = l', storeLogFile = f}-  | l || l' = do-    createDirectoryIfMissing True logDir-    Just <$> openReadStoreLog f-  | otherwise = pure Nothing+runServer :: IniOptions -> IO ()+runServer IniOptions {enableStoreLog, port, enableWebsockets} = do+  fp <- checkSavedFingerprint+  printServiceInfo fp+  storeLog <- openStoreLog+  let cfg = mkServerConfig storeLog+  printServerConfig cfg+  runSMPServer cfg+  where+    checkSavedFingerprint = do+      savedFingerprint <- loadSavedFingerprint+      Fingerprint fp <- loadFingerprint caCrtFile+      when (B.pack savedFingerprint /= strEncode fp) $+        exitError "Stored fingerprint is invalid."+      pure fp -data ServerOpts = ServerOpts-  { serverCommand :: ServerCommand,-    enableStoreLog :: Bool-  }+    mkServerConfig storeLog =+      ServerConfig+        { transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets],+          tbqSize = 16,+          serverTbqSize = 128,+          msgQueueQuota = 256,+          queueIdBytes = 24,+          msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20+          caCertificateFile = caCrtFile,+          privateKeyFile = serverKeyFile,+          certificateFile = serverCrtFile,+          storeLog+        } -data ServerCommand = ServerInit | ServerStart | ServerDelete+    openStoreLog :: IO (Maybe (StoreLog 'ReadMode))+    openStoreLog =+      if enableStoreLog+        then Just <$> openReadStoreLog storeLogFile+        else pure Nothing -serverOpts :: Parser ServerOpts-serverOpts =-  ServerOpts-    <$> subparser-      ( command "init" (info (pure ServerInit) (progDesc "Initialize server: generate server key and ini file"))-          <> command "start" (info (pure ServerStart) (progDesc "Start server (ini: /etc/opt/simplex/smp-server.ini)"))-          <> command "delete" (info (pure ServerDelete) (progDesc "Delete server key, ini file and store log"))-      )-    <*> switch-      ( long "store-log"-          <> short 'l'-          <> help "enable store log for SMP queues persistence"-      )+    printServerConfig ServerConfig {storeLog, transports} = do+      putStrLn $ case storeLog of+        Just s -> "Store log: " <> storeLogFilePath s+        Nothing -> "Store log disabled."+      forM_ transports $ \(p, ATransport t) ->+        putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..." -getServerOpts :: IO ServerOpts-getServerOpts = customExecParser p opts+cleanup :: IO ()+cleanup = do+  deleteDirIfExists cfgDir+  deleteDirIfExists logDir   where-    p = prefs showHelpOnEmpty-    opts =-      info-        (serverOpts <**> helper)-        ( fullDesc-            <> header "Simplex Messaging Protocol (SMP) Server"-        )+    deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path)++printServiceInfo :: ByteString -> IO ()+printServiceInfo fpStr = do+  putStrLn version+  B.putStrLn $ "Fingerprint: " <> strEncode fpStr++version :: String+version = "SMP server v" <> simplexMQVersion++loadSavedFingerprint :: IO String+loadSavedFingerprint = withFile fingerprintFile ReadMode hGetLine
− migrations/20210101_initial.sql 
@@ -1,117 +0,0 @@-CREATE TABLE IF NOT EXISTS servers(-  host TEXT NOT NULL,-  port TEXT NOT NULL,-  key_hash BLOB,-  PRIMARY KEY (host, port)-) WITHOUT ROWID;--CREATE TABLE IF NOT EXISTS rcv_queues(-  host TEXT NOT NULL,-  port TEXT NOT NULL,-  rcv_id BLOB NOT NULL,-  conn_alias BLOB NOT NULL,-  rcv_private_key BLOB NOT NULL,-  snd_id BLOB,-  snd_key BLOB,-  decrypt_key BLOB NOT NULL,-  verify_key BLOB,-  status TEXT NOT NULL,-  PRIMARY KEY (host, port, rcv_id),-  FOREIGN KEY (host, port) REFERENCES servers (host, port),-  FOREIGN KEY (conn_alias)-    REFERENCES connections (conn_alias)-    ON DELETE CASCADE-    DEFERRABLE INITIALLY DEFERRED,-  UNIQUE (host, port, snd_id)-) WITHOUT ROWID;--CREATE TABLE IF NOT EXISTS snd_queues(-  host TEXT NOT NULL,-  port TEXT NOT NULL,-  snd_id BLOB NOT NULL,-  conn_alias BLOB NOT NULL,-  snd_private_key BLOB NOT NULL,-  encrypt_key BLOB NOT NULL,-  sign_key BLOB NOT NULL,-  status TEXT NOT NULL,-  PRIMARY KEY (host, port, snd_id),-  FOREIGN KEY (host, port) REFERENCES servers (host, port),-  FOREIGN KEY (conn_alias)-    REFERENCES connections (conn_alias)-    ON DELETE CASCADE-    DEFERRABLE INITIALLY DEFERRED-) WITHOUT ROWID;--CREATE TABLE IF NOT EXISTS connections(-  conn_alias BLOB NOT NULL,-  rcv_host TEXT,-  rcv_port TEXT,-  rcv_id BLOB,-  snd_host TEXT,-  snd_port TEXT,-  snd_id BLOB,-  last_internal_msg_id INTEGER NOT NULL, -- TODO add defauls here and below in the new schema-  last_internal_rcv_msg_id INTEGER NOT NULL,-  last_internal_snd_msg_id INTEGER NOT NULL,-  last_external_snd_msg_id INTEGER NOT NULL,-  last_rcv_msg_hash BLOB NOT NULL,-  last_snd_msg_hash BLOB NOT NULL,-  PRIMARY KEY (conn_alias),-  FOREIGN KEY (rcv_host, rcv_port, rcv_id) REFERENCES rcv_queues (host, port, rcv_id),-  FOREIGN KEY (snd_host, snd_port, snd_id) REFERENCES snd_queues (host, port, snd_id)-) WITHOUT ROWID;--CREATE TABLE IF NOT EXISTS messages(-  conn_alias BLOB NOT NULL,-  internal_id INTEGER NOT NULL,-  internal_ts TEXT NOT NULL,-  internal_rcv_id INTEGER,-  internal_snd_id INTEGER,-  body TEXT NOT NULL,  -- deprecated-  PRIMARY KEY (conn_alias, internal_id),-  FOREIGN KEY (conn_alias)-    REFERENCES connections (conn_alias)-    ON DELETE CASCADE,-  FOREIGN KEY (conn_alias, internal_rcv_id)-    REFERENCES rcv_messages (conn_alias, internal_rcv_id)-    ON DELETE CASCADE-    DEFERRABLE INITIALLY DEFERRED,-  FOREIGN KEY (conn_alias, internal_snd_id)-    REFERENCES snd_messages (conn_alias, internal_snd_id)-    ON DELETE CASCADE-    DEFERRABLE INITIALLY DEFERRED-) WITHOUT ROWID;--CREATE TABLE IF NOT EXISTS rcv_messages(-  conn_alias BLOB NOT NULL,-  internal_rcv_id INTEGER NOT NULL,-  internal_id INTEGER NOT NULL,-  external_snd_id INTEGER NOT NULL,-  external_snd_ts TEXT NOT NULL,-  broker_id BLOB NOT NULL,-  broker_ts TEXT NOT NULL,-  rcv_status TEXT NOT NULL,-  ack_brocker_ts TEXT,-  ack_sender_ts TEXT,-  internal_hash BLOB NOT NULL,-  external_prev_snd_hash BLOB NOT NULL,-  integrity BLOB NOT NULL,-  PRIMARY KEY (conn_alias, internal_rcv_id),-  FOREIGN KEY (conn_alias, internal_id)-    REFERENCES messages (conn_alias, internal_id)-    ON DELETE CASCADE-) WITHOUT ROWID;--CREATE TABLE IF NOT EXISTS snd_messages(-  conn_alias BLOB NOT NULL,-  internal_snd_id INTEGER NOT NULL,-  internal_id INTEGER NOT NULL,-  snd_status TEXT NOT NULL,-  sent_ts TEXT,-  delivered_ts TEXT,-  internal_hash BLOB NOT NULL,-  PRIMARY KEY (conn_alias, internal_snd_id),-  FOREIGN KEY (conn_alias, internal_id)-    REFERENCES messages (conn_alias, internal_id)-    ON DELETE CASCADE-) WITHOUT ROWID;
− migrations/20210624_confirmations.sql 
@@ -1,9 +0,0 @@-CREATE TABLE conn_confirmations (-  confirmation_id BLOB NOT NULL PRIMARY KEY,-  conn_alias BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,-  sender_key BLOB NOT NULL,-  sender_conn_info BLOB NOT NULL,-  accepted INTEGER NOT NULL,-  own_conn_info BLOB,-  created_at TEXT NOT NULL DEFAULT (datetime('now'))-) WITHOUT ROWID;
− migrations/20210809_snd_messages.sql 
@@ -1,3 +0,0 @@-ALTER TABLE messages ADD msg_body BLOB NOT NULL DEFAULT x'';  -- this field replaces body TEXT--- TODO possibly migrate the data from body if it is possible in migration-ALTER TABLE snd_messages ADD previous_msg_hash BLOB NOT NULL DEFAULT x'';
− migrations/20211202_connection_mode.sql 
@@ -1,11 +0,0 @@-ALTER TABLE connections ADD conn_mode TEXT NOT NULL DEFAULT 'INV';--CREATE TABLE conn_invitations (-  invitation_id BLOB NOT NULL PRIMARY KEY,-  contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,-  cr_invitation BLOB NOT NULL,-  recipient_conn_info BLOB NOT NULL,-  accepted INTEGER NOT NULL DEFAULT 0,-  own_conn_info BLOB,-  created_at TEXT NOT NULL DEFAULT (datetime('now'))-) WITHOUT ROWID;
+ migrations/20220101_initial.sql view
@@ -0,0 +1,137 @@+CREATE TABLE servers (+  host TEXT NOT NULL,+  port TEXT NOT NULL,+  key_hash BLOB NOT NULL,+  PRIMARY KEY (host, port)+) WITHOUT ROWID;++CREATE TABLE connections (+  conn_id BLOB NOT NULL PRIMARY KEY,+  conn_mode TEXT NOT NULL,+  last_internal_msg_id INTEGER NOT NULL DEFAULT 0,+  last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0,+  last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0,+  last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0,+  last_rcv_msg_hash BLOB NOT NULL DEFAULT x'',+  last_snd_msg_hash BLOB NOT NULL DEFAULT x'',+  smp_agent_version INTEGER NOT NULL DEFAULT 1+) WITHOUT ROWID;++CREATE TABLE rcv_queues (+  host TEXT NOT NULL,+  port TEXT NOT NULL,+  rcv_id BLOB NOT NULL,+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,+  rcv_private_key BLOB NOT NULL,+  rcv_dh_secret BLOB NOT NULL,+  e2e_priv_key BLOB NOT NULL,+  e2e_dh_secret BLOB,+  snd_id BLOB NOT NULL,+  snd_key BLOB,+  status TEXT NOT NULL,+  smp_server_version INTEGER NOT NULL DEFAULT 1,+  smp_client_version INTEGER,+  PRIMARY KEY (host, port, rcv_id),+  FOREIGN KEY (host, port) REFERENCES servers+    ON DELETE RESTRICT ON UPDATE CASCADE,+  UNIQUE (host, port, snd_id)+) WITHOUT ROWID;++CREATE TABLE snd_queues (+  host TEXT NOT NULL,+  port TEXT NOT NULL,+  snd_id BLOB NOT NULL,+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,+  snd_private_key BLOB NOT NULL,+  e2e_dh_secret BLOB NOT NULL,+  status TEXT NOT NULL,+  smp_server_version INTEGER NOT NULL DEFAULT 1,+  smp_client_version INTEGER NOT NULL DEFAULT 1,+  PRIMARY KEY (host, port, snd_id),+  FOREIGN KEY (host, port) REFERENCES servers+    ON DELETE RESTRICT ON UPDATE CASCADE+) WITHOUT ROWID;++CREATE TABLE messages (+  conn_id BLOB NOT NULL REFERENCES connections (conn_id)+    ON DELETE CASCADE,+  internal_id INTEGER NOT NULL,+  internal_ts TEXT NOT NULL,+  internal_rcv_id INTEGER,+  internal_snd_id INTEGER,+  msg_type BLOB NOT NULL, -- (H)ELLO, (R)EPLY, (D)ELETE. Should SMP confirmation be saved too?+  msg_body BLOB NOT NULL DEFAULT x'',+  PRIMARY KEY (conn_id, internal_id),+  FOREIGN KEY (conn_id, internal_rcv_id) REFERENCES rcv_messages+    ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED,+  FOREIGN KEY (conn_id, internal_snd_id) REFERENCES snd_messages+    ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED+) WITHOUT ROWID;++CREATE TABLE rcv_messages (+  conn_id BLOB NOT NULL,+  internal_rcv_id INTEGER NOT NULL,+  internal_id INTEGER NOT NULL,+  external_snd_id INTEGER NOT NULL,+  broker_id BLOB NOT NULL,+  broker_ts TEXT NOT NULL,+  internal_hash BLOB NOT NULL,+  external_prev_snd_hash BLOB NOT NULL,+  integrity BLOB NOT NULL,+  PRIMARY KEY (conn_id, internal_rcv_id),+  FOREIGN KEY (conn_id, internal_id) REFERENCES messages+    ON DELETE CASCADE+) WITHOUT ROWID;++CREATE TABLE snd_messages (+  conn_id BLOB NOT NULL,+  internal_snd_id INTEGER NOT NULL,+  internal_id INTEGER NOT NULL,+  internal_hash BLOB NOT NULL,+  previous_msg_hash BLOB NOT NULL DEFAULT x'',+  PRIMARY KEY (conn_id, internal_snd_id),+  FOREIGN KEY (conn_id, internal_id) REFERENCES messages+    ON DELETE CASCADE+) WITHOUT ROWID;++CREATE TABLE conn_confirmations (+  confirmation_id BLOB NOT NULL PRIMARY KEY,+  conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,+  e2e_snd_pub_key BLOB NOT NULL, -- TODO per-queue key. Split?+  sender_key BLOB NOT NULL, -- TODO per-queue key. Split?+  ratchet_state BLOB NOT NULL,+  sender_conn_info BLOB NOT NULL,+  accepted INTEGER NOT NULL,+  own_conn_info BLOB,+  created_at TEXT NOT NULL DEFAULT (datetime('now'))+) WITHOUT ROWID;++CREATE TABLE conn_invitations (+  invitation_id BLOB NOT NULL PRIMARY KEY,+  contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,+  cr_invitation BLOB NOT NULL,+  recipient_conn_info BLOB NOT NULL,+  accepted INTEGER NOT NULL DEFAULT 0,+  own_conn_info BLOB,+  created_at TEXT NOT NULL DEFAULT (datetime('now'))+) WITHOUT ROWID;++CREATE TABLE ratchets (+  conn_id BLOB NOT NULL PRIMARY KEY REFERENCES connections+    ON DELETE CASCADE,+  -- x3dh keys are not saved on the sending side (the side accepting the connection)+  x3dh_priv_key_1 BLOB,+  x3dh_priv_key_2 BLOB,+  -- ratchet is initially empty on the receiving side (the side offering the connection)+  ratchet_state BLOB,+  e2e_version INTEGER NOT NULL DEFAULT 1+) WITHOUT ROWID;++CREATE TABLE skipped_messages (+  skipped_message_id INTEGER PRIMARY KEY,+  conn_id BLOB NOT NULL REFERENCES ratchets+    ON DELETE CASCADE,+  header_key BLOB NOT NULL,+  msg_n INTEGER NOT NULL,+  msg_key BLOB NOT NULL+);
simplexmq.cabal view
@@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: f5e649e0c359792d9528dec6e6cf07af772a521d746e66b8cc2b86d8c604afb2  name:           simplexmq-version:        0.5.2+version:        1.0.0 synopsis:       SimpleXMQ message broker description:    This package includes <./docs/Simplex-Messaging-Server.html server>,                 <./docs/Simplex-Messaging-Client.html client> and@@ -21,17 +19,14 @@ homepage:       https://github.com/simplex-chat/simplexmq#readme author:         simplex.chat maintainer:     chat@simplex.chat-copyright:      2020 simplex.chat+copyright:      2020-2022 simplex.chat license:        AGPL-3 license-file:   LICENSE build-type:     Simple extra-source-files:     README.md     CHANGELOG.md-    migrations/20210101_initial.sql-    migrations/20210624_confirmations.sql-    migrations/20210809_snd_messages.sql-    migrations/20211202_connection_mode.sql+    migrations/20220101_initial.sql     migrations/README.md  library@@ -40,12 +35,16 @@       Simplex.Messaging.Agent.Client       Simplex.Messaging.Agent.Env.SQLite       Simplex.Messaging.Agent.Protocol+      Simplex.Messaging.Agent.QueryString       Simplex.Messaging.Agent.RetryInterval       Simplex.Messaging.Agent.Store       Simplex.Messaging.Agent.Store.SQLite       Simplex.Messaging.Agent.Store.SQLite.Migrations       Simplex.Messaging.Client       Simplex.Messaging.Crypto+      Simplex.Messaging.Crypto.Ratchet+      Simplex.Messaging.Encoding+      Simplex.Messaging.Encoding.String       Simplex.Messaging.Parsers       Simplex.Messaging.Protocol       Simplex.Messaging.Server@@ -58,6 +57,7 @@       Simplex.Messaging.Transport       Simplex.Messaging.Transport.WebSockets       Simplex.Messaging.Util+      Simplex.Messaging.Version   other-modules:       Paths_simplexmq   hs-source-dirs:@@ -65,6 +65,7 @@   ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns   build-depends:       QuickCheck ==2.14.*+    , aeson ==1.5.*     , ansi-terminal >=0.10 && <0.12     , asn1-encoding ==0.9.*     , asn1-types ==0.3.*@@ -77,6 +78,8 @@     , constraints >=0.12 && <0.14     , containers ==0.6.*     , cryptonite >=0.27 && <0.30+    , cryptostore ==0.2.*+    , data-default ==0.7.*     , direct-sqlite ==2.3.*     , directory ==1.3.*     , file-embed >=0.0.14.0 && <=0.0.15.0@@ -95,11 +98,14 @@     , template-haskell ==2.16.*     , text ==1.2.*     , time ==1.9.*+    , tls ==1.5.*     , transformers ==0.5.*     , unliftio ==0.2.*     , unliftio-core ==0.2.*     , websockets ==0.12.*     , x509 ==1.7.*+    , x509-store ==1.6.*+    , x509-validation ==1.6.*   default-language: Haskell2010  executable smp-agent@@ -111,6 +117,7 @@   ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded   build-depends:       QuickCheck ==2.14.*+    , aeson ==1.5.*     , ansi-terminal >=0.10 && <0.12     , asn1-encoding ==0.9.*     , asn1-types ==0.3.*@@ -123,6 +130,8 @@     , constraints >=0.12 && <0.14     , containers ==0.6.*     , cryptonite >=0.27 && <0.30+    , cryptostore ==0.2.*+    , data-default ==0.7.*     , direct-sqlite ==2.3.*     , directory ==1.3.*     , file-embed >=0.0.14.0 && <=0.0.15.0@@ -142,11 +151,14 @@     , template-haskell ==2.16.*     , text ==1.2.*     , time ==1.9.*+    , tls ==1.5.*     , transformers ==0.5.*     , unliftio ==0.2.*     , unliftio-core ==0.2.*     , websockets ==0.12.*     , x509 ==1.7.*+    , x509-store ==1.6.*+    , x509-validation ==1.6.*   default-language: Haskell2010  executable smp-server@@ -158,6 +170,7 @@   ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded   build-depends:       QuickCheck ==2.14.*+    , aeson ==1.5.*     , ansi-terminal >=0.10 && <0.12     , asn1-encoding ==0.9.*     , asn1-types ==0.3.*@@ -171,6 +184,7 @@     , containers ==0.6.*     , cryptonite >=0.27 && <0.30     , cryptostore ==0.2.*+    , data-default ==0.7.*     , direct-sqlite ==2.3.*     , directory ==1.3.*     , file-embed >=0.0.14.0 && <=0.0.15.0@@ -184,6 +198,7 @@     , network ==3.1.*     , network-transport ==0.5.*     , optparse-applicative >=0.15 && <0.17+    , process ==1.6.*     , random >=1.1 && <1.3     , simple-logger ==0.1.*     , simplexmq@@ -192,11 +207,14 @@     , template-haskell ==2.16.*     , text ==1.2.*     , time ==1.9.*+    , tls ==1.5.*     , transformers ==0.5.*     , unliftio ==0.2.*     , unliftio-core ==0.2.*     , websockets ==0.12.*     , x509 ==1.7.*+    , x509-store ==1.6.*+    , x509-validation ==1.6.*   default-language: Haskell2010  test-suite smp-server-test@@ -205,9 +223,12 @@   other-modules:       AgentTests       AgentTests.ConnectionRequestTests+      AgentTests.DoubleRatchetTests       AgentTests.FunctionalAPITests       AgentTests.SQLiteTests-      ProtocolErrorTests+      CoreTests.EncodingTests+      CoreTests.ProtocolErrorTests+      CoreTests.VersionRangeTests       ServerTests       SMPAgentClient       SMPClient@@ -218,6 +239,7 @@   build-depends:       HUnit ==1.6.*     , QuickCheck ==2.14.*+    , aeson ==1.5.*     , ansi-terminal >=0.10 && <0.12     , asn1-encoding ==0.9.*     , asn1-types ==0.3.*@@ -230,6 +252,8 @@     , constraints >=0.12 && <0.14     , containers ==0.6.*     , cryptonite >=0.27 && <0.30+    , cryptostore ==0.2.*+    , data-default ==0.7.*     , direct-sqlite ==2.3.*     , directory ==1.3.*     , file-embed >=0.0.14.0 && <=0.0.15.0@@ -252,9 +276,12 @@     , text ==1.2.*     , time ==1.9.*     , timeit ==2.0.*+    , tls ==1.5.*     , transformers ==0.5.*     , unliftio ==0.2.*     , unliftio-core ==0.2.*     , websockets ==0.12.*     , x509 ==1.7.*+    , x509-store ==1.6.*+    , x509-validation ==1.6.*   default-language: Haskell2010
src/Simplex/Messaging/Agent.hs view
@@ -7,11 +7,9 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -62,7 +60,7 @@ import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader import Crypto.Random (MonadRandom)-import Data.Bifunctor (second)+import Data.Bifunctor (first, second) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Composition ((.:), (.:.))@@ -74,6 +72,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock+import Data.Time.Clock.System (systemToUTCTime) import Database.SQLite.Simple (SQLError) import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite@@ -83,10 +82,14 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore) import Simplex.Messaging.Client (SMPServerTransmission) import qualified Simplex.Messaging.Crypto as C-import Simplex.Messaging.Protocol (MsgBody, SenderPublicKey)+import qualified Simplex.Messaging.Crypto.Ratchet as CR+import Simplex.Messaging.Encoding+import Simplex.Messaging.Parsers (parse)+import Simplex.Messaging.Protocol (MsgBody) import qualified Simplex.Messaging.Protocol as SMP-import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), currentSMPVersionStr, runTransportServer)-import Simplex.Messaging.Util (bshow, tryError, unlessM)+import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), loadTLSServerParams, runTransportServer, simplexMQVersion)+import Simplex.Messaging.Util (bshow, liftError, tryError, unlessM)+import Simplex.Messaging.Version import System.Random (randomR) import UnliftIO.Async (async, race_) import qualified UnliftIO.Exception as E@@ -105,15 +108,19 @@ -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True) -- and when it is disconnected from the TCP socket once the server thread is killed (False). runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> m ()-runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort} = runReaderT (smpAgent t) =<< newSMPAgentEnv cfg+runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} = do+  runReaderT (smpAgent t) =<< newSMPAgentEnv cfg   where     smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()-    smpAgent _ = runTransportServer started tcpPort $ \(h :: c) -> do-      liftIO . putLn h $ "Welcome to SMP agent v" <> currentSMPVersionStr-      c <- getAgentClient-      logConnection c True-      race_ (connectClient h c) (runAgentClient c)-        `E.finally` disconnectAgentClient c+    smpAgent _ = do+      -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation+      tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile+      runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do+        liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion+        c <- getAgentClient+        logConnection c True+        race_ (connectClient h c) (runAgentClient c)+          `E.finally` disconnectAgentClient c  -- | Creates an SMP agent client instance getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m AgentClient@@ -131,11 +138,11 @@ type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m)  -- | Create SMP agent connection (NEW command)-createConnection :: AgentErrorMonad m => AgentClient -> SConnectionMode c -> m (ConnId, ConnectionRequest c)+createConnection :: AgentErrorMonad m => AgentClient -> SConnectionMode c -> m (ConnId, ConnectionRequestUri c) createConnection c cMode = withAgentEnv c $ newConn c "" cMode  -- | Join SMP agent connection (JOIN command)-joinConnection :: AgentErrorMonad m => AgentClient -> ConnectionRequest c -> ConnInfo -> m ConnId+joinConnection :: AgentErrorMonad m => AgentClient -> ConnectionRequestUri c -> ConnInfo -> m ConnId joinConnection c = withAgentEnv c .: joinConn c ""  -- | Allow connection to continue after CONF notification (LET command)@@ -258,53 +265,73 @@   OFF -> suspendConnection' c connId $> (connId, OK)   DEL -> deleteConnection' c connId $> (connId, OK) -newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequest c)+newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequestUri c) newConn c connId cMode = do   srv <- getSMPServer-  (rq, qUri, encryptKey) <- newRcvQueue c srv+  (rq, qUri) <- newRcvQueue c srv   g <- asks idsDrg   let cData = ConnData {connId}   connId' <- withStore $ \st -> createRcvConn st g cData rq cMode   addSubscription c rq connId'-  let crData = ConnReqData simplexChat [qUri] encryptKey-  pure . (connId',) $ case cMode of-    SCMInvitation -> CRInvitation crData-    SCMContact -> CRContact crData+  let crData = ConnReqUriData simplexChat smpAgentVRange [qUri]+  case cMode of+    SCMContact -> pure (connId', CRContactUri crData)+    SCMInvitation -> do+      (pk1, pk2, e2eRcvParams) <- liftIO $ CR.generateE2EParams CR.e2eEncryptVersion+      withStore $ \st -> createRatchetX3dhKeys st connId' pk1 pk2+      pure (connId', CRInvitationUri crData $ toVersionRangeT e2eRcvParams CR.e2eEncryptVRange) -joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequest c -> ConnInfo -> m ConnId-joinConn c connId (CRInvitation (ConnReqData _ (qUri :| _) encryptKey)) cInfo = do-  (sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey-  g <- asks idsDrg-  cfg <- asks config-  let cData = ConnData {connId}-  connId' <- withStore $ \st -> createSndConn st g cData sq-  confirmQueue c sq senderKey cInfo-  activateQueueJoining c connId' sq verifyKey $ retryInterval cfg-  pure connId'-joinConn c connId (CRContact (ConnReqData _ (qUri :| _) encryptKey)) cInfo = do-  (connId', cReq) <- newConn c connId SCMInvitation-  sendInvitation c qUri encryptKey cReq cInfo-  pure connId'+joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequestUri c -> ConnInfo -> m ConnId+joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2eRcvParamsUri) cInfo =+  case ( qUri `compatibleVersion` SMP.smpClientVRange,+         e2eRcvParamsUri `compatibleVersion` CR.e2eEncryptVRange,+         agentVRange `compatibleVersion` smpAgentVRange+       ) of+    (Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just _) -> do+      -- TODO in agent v2 - use found compatible version rather than current+      (pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams+      (_, rcDHRs) <- liftIO C.generateKeyPair'+      let rc = CR.initSndRatchet rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams+      (sq, smpConf) <- newSndQueue qInfo cInfo+      g <- asks idsDrg+      let cData = ConnData {connId}+      connId' <- withStore $ \st -> do+        connId' <- createSndConn st g cData sq+        createRatchet st connId' rc+        pure connId'+      confirmQueue c connId' sq smpConf $ Just e2eSndParams+      void $ enqueueMessage c connId' sq HELLO+      pure connId'+    _ -> throwError $ AGENT A_VERSION+joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInfo =+  case ( qUri `compatibleVersion` SMP.smpClientVRange,+         agentVRange `compatibleVersion` smpAgentVRange+       ) of+    (Just qInfo, Just _) -> do+      -- TODO in agent v2 - use found compatible version rather than current+      (connId', cReq) <- newConn c connId SCMInvitation+      sendInvitation c qInfo cReq cInfo+      pure connId'+    _ -> throwError $ AGENT A_VERSION -activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m ()-activateQueueJoining c connId sq verifyKey retryInterval =-  activateQueue c connId sq verifyKey retryInterval createReplyQueue-  where-    createReplyQueue :: m ()-    createReplyQueue = do-      srv <- getSMPServer-      (rq, qUri', encryptKey) <- newRcvQueue c srv-      addSubscription c rq connId-      withStore $ \st -> upgradeSndConnToDuplex st connId rq-      sendControlMessage c sq . REPLY $ CRInvitation $ ConnReqData CRSSimplex [qUri'] encryptKey+createReplyQueue :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()+createReplyQueue c connId sq = do+  srv <- getSMPServer+  (rq, qUri) <- newRcvQueue c srv+  -- TODO reply queue version should be the same as send queue, ignoring it in v1+  let qInfo = toVersionT qUri SMP.smpClientVersion+  addSubscription c rq connId+  withStore $ \st -> upgradeSndConnToDuplex st connId rq+  void . enqueueMessage c connId sq $ REPLY [qInfo]  -- | Approve confirmation (LET command) in Reader monad allowConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m () allowConnection' c connId confId ownConnInfo = do   withStore (`getConn` connId) >>= \case     SomeConn _ (RcvConnection _ rq) -> do-      AcceptedConfirmation {senderKey} <- withStore $ \st -> acceptConfirmation st confId ownConnInfo-      processConfirmation c rq senderKey+      AcceptedConfirmation {senderConf, ratchetState} <- withStore $ \st -> acceptConfirmation st confId ownConnInfo+      withStore $ \st -> createRatchet st connId ratchetState+      processConfirmation c rq senderConf     _ -> throwError $ CMD PROHIBITED  -- | Accept contact (ACPT command) in Reader monad@@ -322,10 +349,11 @@ rejectContact' _ contactConnId invId =   withStore $ \st -> deleteInvitation st contactConnId invId -processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()-processConfirmation c rq sndKey = do-  withStore $ \st -> setRcvQueueStatus st rq Confirmed-  secureQueue c rq sndKey+processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SMPConfirmation -> m ()+processConfirmation c rq@RcvQueue {e2ePrivKey} SMPConfirmation {senderKey, e2ePubKey} = do+  let dhSecret = C.dh' e2ePubKey e2ePrivKey+  withStore $ \st -> setRcvQueueConfirmedE2E st rq dhSecret+  secureQueue c rq senderKey   withStore $ \st -> setRcvQueueStatus st rq Secured  -- | Subscribe to receive connection messages (SUB command) in Reader monad@@ -334,71 +362,59 @@   withStore (`getConn` connId) >>= \case     SomeConn _ (DuplexConnection _ rq sq) -> do       resumeMsgDelivery c connId sq+      subscribeQueue c rq connId       case status (sq :: SndQueue) of-        Confirmed -> withVerifyKey sq $ \verifyKey -> do-          conf <- withStore (`getAcceptedConfirmation` connId)-          secureQueue c rq $ senderKey (conf :: AcceptedConfirmation)+        Confirmed -> do+          -- TODO if there is no confirmation saved, just update the status without securing the queue+          AcceptedConfirmation {senderConf = SMPConfirmation {senderKey}} <-+            withStore (`getAcceptedConfirmation` connId)+          secureQueue c rq senderKey           withStore $ \st -> setRcvQueueStatus st rq Secured-          activateSecuredQueue rq sq verifyKey-        Secured -> withVerifyKey sq $ activateSecuredQueue rq sq-        Active -> subscribeQueue c rq connId+        Secured -> pure ()+        Active -> pure ()         _ -> throwError $ INTERNAL "unexpected queue status"     SomeConn _ (SndConnection _ sq) -> do       resumeMsgDelivery c connId sq       case status (sq :: SndQueue) of-        Confirmed -> withVerifyKey sq $ \verifyKey ->-          activateQueueJoining c connId sq verifyKey =<< resumeInterval+        Confirmed -> pure ()         Active -> throwError $ CONN SIMPLEX         _ -> throwError $ INTERNAL "unexpected queue status"     SomeConn _ (RcvConnection _ rq) -> subscribeQueue c rq connId     SomeConn _ (ContactConnection _ rq) -> subscribeQueue c rq connId-  where-    withVerifyKey :: SndQueue -> (C.PublicKey -> m ()) -> m ()-    withVerifyKey sq action =-      let err = throwError $ INTERNAL "missing signing key public counterpart"-       in maybe err action . C.publicKey $ signKey sq-    activateSecuredQueue :: RcvQueue -> SndQueue -> C.PublicKey -> m ()-    activateSecuredQueue rq sq verifyKey = do-      activateQueueInitiating c connId sq verifyKey =<< resumeInterval-      subscribeQueue c rq connId-    resumeInterval :: m RetryInterval-    resumeInterval = do-      r <- asks $ retryInterval . config-      pure r {initialInterval = 5_000_000}  -- | Send message to the connection (SEND command) in Reader monad sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgBody -> m AgentMsgId sendMessage' c connId msg =   withStore (`getConn` connId) >>= \case-    SomeConn _ (DuplexConnection _ _ sq) -> enqueueMessage sq-    SomeConn _ (SndConnection _ sq) -> enqueueMessage sq+    SomeConn _ (DuplexConnection _ _ sq) -> enqueueMsg sq+    SomeConn _ (SndConnection _ sq) -> enqueueMsg sq     _ -> throwError $ CONN SIMPLEX   where-    enqueueMessage :: SndQueue -> m AgentMsgId-    enqueueMessage sq = do-      resumeMsgDelivery c connId sq-      msgId <- storeSentMsg-      queuePendingMsgs c connId sq [msgId]-      pure $ unId msgId-      where-        storeSentMsg :: m InternalId-        storeSentMsg = do-          internalTs <- liftIO getCurrentTime-          withStore $ \st -> do-            (internalId, internalSndId, previousMsgHash) <- updateSndIds st connId-            let msgBody =-                  serializeSMPMessage-                    SMPMessage-                      { senderMsgId = unSndId internalSndId,-                        senderTimestamp = internalTs,-                        previousMsgHash,-                        agentMessage = A_MSG msg-                      }-                internalHash = C.sha256Hash msgBody-                msgData = SndMsgData {..}-            createSndMsg st connId msgData-            pure internalId+    enqueueMsg :: SndQueue -> m AgentMsgId+    enqueueMsg sq = enqueueMessage c connId sq $ A_MSG msg +enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> AMessage -> m AgentMsgId+enqueueMessage c connId sq aMessage = do+  resumeMsgDelivery c connId sq+  msgId <- storeSentMsg+  queuePendingMsgs c connId sq [msgId]+  pure $ unId msgId+  where+    storeSentMsg :: m InternalId+    storeSentMsg = do+      internalTs <- liftIO getCurrentTime+      (internalId, internalSndId, prevMsgHash) <- withStore (`updateSndIds` connId)+      let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash+          agentMessage = smpEncode $ AgentMessage privHeader aMessage+          internalHash = C.sha256Hash agentMessage++      encAgentMessage <- agentRatchetEncrypt connId agentMessage e2eEncUserMsgLength+      let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion = smpAgentVersion, encAgentMessage}+          msgType = aMessageType aMessage+          msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, internalHash, prevMsgHash}+      withStore $ \st -> createSndMsg st connId msgData+      pure internalId+ resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> m () resumeMsgDelivery c connId sq@SndQueue {server, sndId} = do   let qKey = (connId, server, sndId)@@ -442,18 +458,37 @@     withStore (\st -> E.try $ getPendingMsgData st connId msgId) >>= \case       Left (e :: E.SomeException) ->         notify $ MERR mId (INTERNAL $ show e)-      Right msgBody -> do-        withRetryInterval ri $ \loop -> do+      Right (rq_, (msgType, msgBody)) ->+        withRetryInterval ri $ \loop ->           tryError (sendAgentMessage c sq msgBody) >>= \case-            Left e -> case e of-              SMP SMP.QUOTA -> loop-              SMP {} -> notify $ MERR mId e-              CMD {} -> notify $ MERR mId e-              _ -> loop+            Left e -> do+              case e of+                SMP SMP.QUOTA -> loop+                SMP SMP.AUTH -> case msgType of+                  HELLO_ -> loop+                  REPLY_ -> notify (ERR e) >> delMsg msgId+                  A_MSG_ -> notify (MERR mId e) >> delMsg msgId+                SMP (SMP.CMD _) -> notify (MERR mId e) >> delMsg msgId+                SMP SMP.LARGE_MSG -> notify (MERR mId e) >> delMsg msgId+                SMP {} -> notify (MERR mId e) >> loop+                _ -> loop             Right () -> do-              notify $ SENT mId-              withStore $ \st -> updateSndMsgStatus st connId msgId SndMsgSent+              case msgType of+                HELLO_ -> do+                  withStore $ \st -> setSndQueueStatus st sq Active+                  case rq_ of+                    -- party initiating connection+                    Just rq -> do+                      subscribeQueue c rq connId+                      notify CON+                    -- party joining connection+                    _ -> createReplyQueue c connId sq+                A_MSG_ -> notify $ SENT mId+                _ -> pure ()+              delMsg msgId   where+    delMsg :: InternalId -> m ()+    delMsg msgId = withStore $ \st -> deleteMsg st connId msgId     notify :: ACommand 'Agent -> m ()     notify cmd = atomically $ writeTBQueue subQ ("", connId, cmd) @@ -469,7 +504,7 @@       let mId = InternalId msgId       withStore $ \st -> checkRcvMsg st connId mId       sendAck c rq-      withStore $ \st -> updateRcvMsgAck st connId mId+      withStore $ \st -> deleteMsg st connId mId  -- | Suspend SMP agent connection (OFF command) in Reader monad suspendConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()@@ -503,17 +538,6 @@       i <- atomically . stateTVar gen $ randomR (0, L.length servers - 1)       pure $ servers L.!! i -sendControlMessage :: AgentMonad m => AgentClient -> SndQueue -> AMessage -> m ()-sendControlMessage c sq agentMessage = do-  senderTimestamp <- liftIO getCurrentTime-  sendAgentMessage c sq . serializeSMPMessage $-    SMPMessage-      { senderMsgId = 0,-        senderTimestamp,-        previousMsgHash = "",-        agentMessage-      }- subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () subscriber c@AgentClient {msgQ} = forever $ do   t <- atomically $ readTBQueue msgQ@@ -530,21 +554,38 @@     _ -> atomically $ writeTBQueue subQ ("", "", ERR $ CONN NOT_FOUND)   where     processSMP :: SConnType c -> ConnData -> RcvQueue -> m ()-    processSMP cType ConnData {connId} rq@RcvQueue {status} =+    processSMP cType ConnData {connId} rq@RcvQueue {rcvDhSecret, e2ePrivKey, e2eDhSecret, status} =       case cmd of-        SMP.MSG srvMsgId srvTs msgBody -> do+        SMP.MSG srvMsgId srvTs msgBody' -> handleNotifyAck $ do           -- TODO deduplicate with previously received-          msg <- decryptAndVerify rq msgBody-          let msgHash = C.sha256Hash msg-          case parseSMPMessage msg of-            Left e -> notify (ERR e) >> sendAck c rq-            Right (SMPConfirmation senderKey cInfo) -> smpConfirmation senderKey cInfo >> sendAck c rq-            Right SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} ->-              case agentMessage of-                HELLO verifyKey _ -> helloMsg verifyKey msgBody >> sendAck c rq-                REPLY cReq -> replyMsg cReq >> sendAck c rq-                A_MSG body -> agentClientMsg previousMsgHash (senderMsgId, senderTimestamp) (srvMsgId, srvTs) body msgHash-                A_INV cReq cInfo -> smpInvitation cReq cInfo >> sendAck c rq+          msgBody <- agentCbDecrypt rcvDhSecret (C.cbNonce srvMsgId) msgBody'+          clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-+            parseMessage msgBody+          unless (phVer `isCompatible` SMP.smpClientVRange) . throwError $ AGENT A_VERSION+          case (e2eDhSecret, e2ePubKey_) of+            (Nothing, Just e2ePubKey) -> do+              let e2eDh = C.dh' e2ePubKey e2ePrivKey+              decryptClientMessage e2eDh clientMsg >>= \case+                (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption, encConnInfo}) ->+                  smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo >> ack+                (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->+                  smpInvitation connReq connInfo >> ack+                _ -> prohibited >> ack+            (Just e2eDh, Nothing) -> do+              decryptClientMessage e2eDh clientMsg >>= \case+                (SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) -> do+                  agentMsgBody <- agentRatchetDecrypt connId encAgentMsg+                  parseMessage agentMsgBody >>= \case+                    AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage -> do+                      (msgId, msgMeta) <- agentClientMsg prevMsgHash sndMsgId (srvMsgId, systemToUTCTime srvTs) agentMsgBody aMessage+                      case aMessage of+                        HELLO -> helloMsg >> ack >> withStore (\st -> deleteMsg st connId msgId)+                        REPLY cReq -> replyMsg cReq >> ack >> withStore (\st -> deleteMsg st connId msgId)+                        -- note that there is no ACK sent here, it is sent with agent's user ACK command+                        A_MSG body -> notify $ MSG msgMeta body+                    _ -> prohibited >> ack+                _ -> prohibited >> ack+            _ -> prohibited >> ack         SMP.END -> do           removeSubscription c connId           logServer "<--" c srv rId "END"@@ -556,64 +597,98 @@         notify :: ACommand 'Agent -> m ()         notify msg = atomically $ writeTBQueue subQ ("", connId, msg) +        handleNotifyAck :: m () -> m ()+        handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack+         prohibited :: m ()         prohibited = notify . ERR $ AGENT A_PROHIBITED -        smpConfirmation :: SenderPublicKey -> ConnInfo -> m ()-        smpConfirmation senderKey cInfo = do-          logServer "<--" c srv rId "MSG <KEY>"+        ack :: m ()+        ack = sendAck c rq++        decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> m (SMP.PrivHeader, AgentMsgEnvelope)+        decryptClientMessage e2eDh SMP.ClientMsgEnvelope {cmNonce, cmEncBody} = do+          clientMsg <- agentCbDecrypt e2eDh cmNonce cmEncBody+          SMP.ClientMessage privHeader clientBody <- parseMessage clientMsg+          agentEnvelope <- parseMessage clientBody+          if agentVersion agentEnvelope `isCompatible` smpAgentVRange+            then pure (privHeader, agentEnvelope)+            else throwError $ AGENT A_VERSION++        parseMessage :: Encoding a => ByteString -> m a+        parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)++        smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> m ()+        smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo = do+          logServer "<--" c srv rId "MSG <CONF>"           case status of-            New -> case cType of-              SCRcv -> do-                g <- asks idsDrg-                let newConfirmation = NewConfirmation {connId, senderKey, senderConnInfo = cInfo}-                confId <- withStore $ \st -> createConfirmation st g newConfirmation-                notify $ CONF confId cInfo-              SCDuplex -> do-                notify $ INFO cInfo-                processConfirmation c rq senderKey+            New -> case (cType, e2eEncryption) of+              (SCRcv, Just e2eSndParams) -> do+                (pk1, rcDHRs) <- withStore $ \st -> getRatchetX3dhKeys st connId+                let rc = CR.initRcvRatchet rcDHRs $ CR.x3dhRcv pk1 rcDHRs e2eSndParams+                (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt rc M.empty encConnInfo+                case (agentMsgBody_, skipped) of+                  (Right agentMsgBody, CR.SMDNoChange) ->+                    parseMessage agentMsgBody >>= \case+                      AgentConnInfo connInfo -> do+                        g <- asks idsDrg+                        let senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}+                            newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}+                        confId <- withStore $ \st -> createConfirmation st g newConfirmation+                        notify $ CONF confId connInfo+                      _ -> prohibited+                  _ -> prohibited+              (SCDuplex, Nothing) -> do+                agentRatchetDecrypt connId encConnInfo >>= parseMessage >>= \case+                  AgentConnInfo connInfo -> do+                    notify $ INFO connInfo+                    processConfirmation c rq $ SMPConfirmation {senderKey, e2ePubKey, connInfo}+                  _ -> prohibited               _ -> prohibited             _ -> prohibited -        helloMsg :: SenderPublicKey -> ByteString -> m ()-        helloMsg verifyKey msgBody = do+        helloMsg :: m ()+        helloMsg = do           logServer "<--" c srv rId "MSG <HELLO>"           case status of             Active -> prohibited             _ -> do-              void $ verifyMessage (Just verifyKey) msgBody-              withStore $ \st -> setRcvQueueActive st rq verifyKey+              withStore $ \st -> setRcvQueueStatus st rq Active               case cType of                 SCDuplex -> notifyConnected c connId                 _ -> pure () -        replyMsg :: ConnectionRequest 'CMInvitation -> m ()-        replyMsg (CRInvitation (ConnReqData _ (qUri :| _) encryptKey)) = do+        replyMsg :: L.NonEmpty SMPQueueInfo -> m ()+        replyMsg (qInfo :| _) = do           logServer "<--" c srv rId "MSG <REPLY>"           case cType of             SCRcv -> do               AcceptedConfirmation {ownConnInfo} <- withStore (`getAcceptedConfirmation` connId)-              (sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey-              withStore $ \st -> upgradeRcvConnToDuplex st connId sq-              confirmQueue c sq senderKey ownConnInfo-              withStore (`removeConfirmations` connId)-              cfg <- asks config-              activateQueueInitiating c connId sq verifyKey $ retryInterval cfg+              case qInfo `proveCompatible` SMP.smpClientVRange of+                Nothing -> notify . ERR $ AGENT A_VERSION+                Just qInfo' -> do+                  (sq, smpConf) <- newSndQueue qInfo' ownConnInfo+                  withStore $ \st -> upgradeRcvConnToDuplex st connId sq+                  confirmQueue c connId sq smpConf Nothing+                  withStore (`removeConfirmations` connId)+                  void $ enqueueMessage c connId sq HELLO             _ -> prohibited -        agentClientMsg :: PrevRcvMsgHash -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> MsgBody -> MsgHash -> m ()-        agentClientMsg externalPrevSndHash sender broker msgBody internalHash = do+        agentClientMsg :: PrevRcvMsgHash -> ExternalSndId -> (BrokerId, BrokerTs) -> MsgBody -> AMessage -> m (InternalId, MsgMeta)+        agentClientMsg externalPrevSndHash sndMsgId broker msgBody aMessage = do           logServer "<--" c srv rId "MSG <MSG>"+          let internalHash = C.sha256Hash msgBody           internalTs <- liftIO getCurrentTime           (internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- withStore (`updateRcvIds` connId)-          let integrity = checkMsgIntegrity prevExtSndId (fst sender) prevRcvMsgHash externalPrevSndHash+          let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash externalPrevSndHash               recipient = (unId internalId, internalTs)-              msgMeta = MsgMeta {integrity, recipient, sender, broker}-              rcvMsg = RcvMsgData {..}+              msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}+              msgType = aMessageType aMessage+              rcvMsg = RcvMsgData {msgMeta, msgType, msgBody, internalRcvId, internalHash, externalPrevSndHash}           withStore $ \st -> createRcvMsg st connId rcvMsg-          notify $ MSG msgMeta msgBody+          pure (internalId, msgMeta) -        smpInvitation :: ConnectionRequest 'CMInvitation -> ConnInfo -> m ()+        smpInvitation :: ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()         smpInvitation connReq cInfo = do           logServer "<--" c srv rId "MSG <KEY>"           case cType of@@ -633,49 +708,60 @@           | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash           | otherwise = MsgError MsgDuplicate -- this case is not possible -confirmQueue :: AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> ConnInfo -> m ()-confirmQueue c sq senderKey cInfo = do-  sendConfirmation c sq senderKey cInfo+confirmQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> SMPConfirmation -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()+confirmQueue c connId sq SMPConfirmation {senderKey, e2ePubKey, connInfo} e2eEncryption = do+  msg <- mkConfirmation+  sendConfirmation c sq msg   withStore $ \st -> setSndQueueStatus st sq Confirmed+  where+    mkConfirmation :: m MsgBody+    mkConfirmation = do+      encConnInfo <- agentRatchetEncrypt connId (smpEncode $ AgentConnInfo connInfo) e2eEncConnInfoLength+      let agentEnvelope = AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}+      agentCbEncrypt sq (Just e2ePubKey) . smpEncode $+        SMP.ClientMessage (SMP.PHConfirmation senderKey) $ smpEncode agentEnvelope -activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m ()-activateQueueInitiating c connId sq verifyKey retryInterval =-  activateQueue c connId sq verifyKey retryInterval $ notifyConnected c connId+-- encoded AgentMessage -> encoded EncAgentMessage+agentRatchetEncrypt :: AgentMonad m => ConnId -> ByteString -> Int -> m ByteString+agentRatchetEncrypt connId msg paddedLen = do+  rc <- withStore $ \st -> getRatchet st connId+  (encMsg, rc') <- liftError cryptoError $ CR.rcEncrypt rc paddedLen msg+  withStore $ \st -> updateRatchet st connId rc' CR.SMDNoChange+  pure encMsg -activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () -> m ()-activateQueue c connId sq verifyKey retryInterval afterActivation =-  getActivation c connId >>= \case-    Nothing -> async runActivation >>= addActivation c connId-    Just _ -> pure ()-  where-    runActivation :: m ()-    runActivation = do-      sendHello c sq verifyKey retryInterval-      withStore $ \st -> setSndQueueStatus st sq Active-      removeActivation c connId-      removeVerificationKey-      afterActivation-    removeVerificationKey :: m ()-    removeVerificationKey =-      let safeSignKey = C.removePublicKey $ signKey sq-       in withStore $ \st -> updateSignKey st sq safeSignKey+-- encoded EncAgentMessage -> encoded AgentMessage+agentRatchetDecrypt :: AgentMonad m => ConnId -> ByteString -> m ByteString+agentRatchetDecrypt connId encAgentMsg = do+  (rc, skipped) <- withStore $ \st ->+    (,) <$> getRatchet st connId <*> getSkippedMsgKeys st connId+  (agentMsgBody_, rc', skippedDiff) <- liftError cryptoError $ CR.rcDecrypt rc skipped encAgentMsg+  withStore $ \st -> updateRatchet st connId rc' skippedDiff+  liftEither $ first cryptoError agentMsgBody_  notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m () notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON) -newSndQueue ::-  (MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> EncryptionKey -> m (SndQueue, SenderPublicKey, VerificationKey)-newSndQueue (SMPQueueUri smpServer senderId _) encryptKey = do-  size <- asks $ rsaKeySize . config-  (senderKey, sndPrivateKey) <- liftIO $ C.generateKeyPair size-  (verifyKey, signKey) <- liftIO $ C.generateKeyPair size+newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => Compatible SMPQueueInfo -> ConnInfo -> m (SndQueue, SMPConfirmation)+newSndQueue qInfo cInfo =+  asks (cmdSignAlg . config) >>= \case+    C.SignAlg a -> newSndQueue_ a qInfo cInfo++newSndQueue_ ::+  (C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m) =>+  C.SAlgorithm a ->+  Compatible SMPQueueInfo ->+  ConnInfo ->+  m (SndQueue, SMPConfirmation)+newSndQueue_ a (Compatible (SMPQueueInfo _clientVersion smpServer senderId rcvE2ePubDhKey)) cInfo = do+  -- this function assumes clientVersion is compatible - it was tested before+  (senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a+  (e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'   let sndQueue =         SndQueue           { server = smpServer,             sndId = senderId,             sndPrivateKey,-            encryptKey,-            signKey,+            e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,             status = New           }-  return (sndQueue, senderKey, verifyKey)+  pure (sndQueue, SMPConfirmation senderKey e2ePubKey cInfo)
src/Simplex/Messaging/Agent/Client.hs view
@@ -2,10 +2,14 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Simplex.Messaging.Agent.Client   ( AgentClient (..),@@ -19,20 +23,16 @@     sendConfirmation,     sendInvitation,     RetryInterval (..),-    sendHello,     secureQueue,     sendAgentMessage,-    decryptAndVerify,-    verifyMessage,+    agentCbEncrypt,+    agentCbDecrypt,+    cryptoError,     sendAck,     suspendQueue,     deleteQueue,     logServer,     removeSubscription,-    cryptoError,-    addActivation,-    getActivation,-    removeActivation,   ) where @@ -42,7 +42,7 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader-import Control.Monad.Trans.Except+import Data.Bifunctor (first) import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B@@ -52,17 +52,18 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Text.Encoding-import Data.Time.Clock import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C-import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey)+import Simplex.Messaging.Encoding+import Simplex.Messaging.Protocol (QueueId, QueueIdsKeys (..), SndPublicVerifyKey) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Util (bshow, liftEitherError, liftError)-import UnliftIO.Exception (IOException)+import Simplex.Messaging.Version+import UnliftIO.Exception (Exception, IOException) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -73,7 +74,6 @@     smpClients :: TVar (Map SMPServer SMPClient),     subscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)),     subscrConns :: TVar (Map ConnId SMPServer),-    activations :: TVar (Map ConnId (Async ())), -- activations of send queues in progress     connMsgsQueued :: TVar (Map ConnId Bool),     smpQueueMsgQueues :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId)),     smpQueueMsgDeliveries :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (Async ())),@@ -93,18 +93,29 @@   smpClients <- newTVar M.empty   subscrSrvrs <- newTVar M.empty   subscrConns <- newTVar M.empty-  activations <- newTVar M.empty   connMsgsQueued <- newTVar M.empty   smpQueueMsgQueues <- newTVar M.empty   smpQueueMsgDeliveries <- newTVar M.empty   reconnections <- newTVar []   clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)   lock <- newTMVar ()-  return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, activations, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, clientId, agentEnv, smpSubscriber = undefined, lock}+  return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, clientId, agentEnv, smpSubscriber = undefined, lock}  -- | Agent monad with MonadReader Env and MonadError AgentErrorType type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m) +newtype InternalException e = InternalException {unInternalException :: e}+  deriving (Eq, Show)++instance Exception e => Exception (InternalException e)++instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where+  withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b+  withRunInIO exceptToIO =+    withExceptT unInternalException . ExceptT . E.try $+      withRunInIO $ \run ->+        exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)+ getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient getSMPServerClient c@AgentClient {smpClients, msgQ} srv =   readTVarIO smpClients@@ -174,7 +185,6 @@ closeAgentClient :: MonadUnliftIO m => AgentClient -> m () closeAgentClient c = liftIO $ do   closeSMPServerClients c-  cancelActions $ activations c   cancelActions $ reconnections c   cancelActions $ smpQueueMsgDeliveries c @@ -225,25 +235,37 @@   SMPTransportError e -> BROKER $ TRANSPORT e   e -> INTERNAL $ show e -newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri, EncryptionKey)-newRcvQueue c srv = do-  size <- asks $ rsaKeySize . config-  (recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size+newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)+newRcvQueue c srv =+  asks (cmdSignAlg . config) >>= \case+    C.SignAlg a -> newRcvQueue_ a c srv++newRcvQueue_ ::+  (C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) =>+  C.SAlgorithm a ->+  AgentClient ->+  SMPServer ->+  m (RcvQueue, SMPQueueUri)+newRcvQueue_ a c srv = do+  (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a+  (dhKey, privDhKey) <- liftIO C.generateKeyPair'+  (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'   logServer "-->" c srv "" "NEW"-  (rcvId, sId) <- withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey-  logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sId]-  (encryptKey, decryptKey) <- liftIO $ C.generateKeyPair size+  QIK {rcvId, sndId, rcvPublicDhKey} <-+    withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey+  logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]   let rq =         RcvQueue           { server = srv,             rcvId,             rcvPrivateKey,-            sndId = Just sId,-            decryptKey,-            verifyKey = Nothing,+            rcvDhSecret = C.dh' rcvPublicDhKey privDhKey,+            e2ePrivKey,+            e2eDhSecret = Nothing,+            sndId = Just sndId,             status = New           }-  pure (rq, SMPQueueUri srv sId reservedServerKey, encryptKey)+  pure (rq, SMPQueueUri srv sndId SMP.smpClientVRange e2eDhKey)  subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m () subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do@@ -273,72 +295,37 @@       let cs' = M.delete connId cs        in if M.null cs' then Nothing else Just cs' -addActivation :: MonadUnliftIO m => AgentClient -> ConnId -> Async () -> m ()-addActivation c connId a = atomically . modifyTVar (activations c) $ M.insert connId a--getActivation :: MonadUnliftIO m => AgentClient -> ConnId -> m (Maybe (Async ()))-getActivation c connId = M.lookup connId <$> readTVarIO (activations c)--removeActivation :: MonadUnliftIO m => AgentClient -> ConnId -> m ()-removeActivation c connId = atomically . modifyTVar (activations c) $ M.delete connId- logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m () logServer dir AgentClient {clientId} srv 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)+showServer SMPServer {host, port} =+  B.pack $ host <> if null port then "" else ':' : port  logSecret :: ByteString -> ByteString logSecret bs = encode $ B.take 3 bs -sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> ConnInfo -> m ()-sendConfirmation c sq@SndQueue {server, sndId} senderKey cInfo =-  withLogSMP_ c server sndId "SEND <KEY>" $ \smp -> do-    msg <- mkConfirmation smp-    liftSMP $ sendSMPMessage smp Nothing sndId msg-  where-    mkConfirmation :: SMPClient -> m MsgBody-    mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey cInfo--sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> RetryInterval -> m ()-sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey ri =-  withLogSMP_ c server sndId "SEND <HELLO> (retrying)" $ \smp -> do-    msg <- mkHello smp $ AckMode On-    liftSMP . withRetryInterval ri $ \loop ->-      sendSMPMessage smp (Just sndPrivateKey) sndId msg `catchE` \case-        SMPServerError AUTH -> loop-        e -> throwE e-  where-    mkHello :: SMPClient -> AckMode -> m ByteString-    mkHello smp ackMode = do-      senderTimestamp <- liftIO getCurrentTime-      encryptAndSign smp sq . serializeSMPMessage $-        SMPMessage-          { senderMsgId = 0,-            senderTimestamp,-            previousMsgHash = "",-            agentMessage = HELLO verifyKey ackMode-          }+-- TODO maybe package E2ERatchetParams into SMPConfirmation+sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()+sendConfirmation c SndQueue {server, sndId} encConfirmation =+  withLogSMP_ c server sndId "SEND <CONF>" $ \smp ->+    liftSMP $ sendSMPMessage smp Nothing sndId encConfirmation -sendInvitation :: forall m. AgentMonad m => AgentClient -> SMPQueueUri -> EncryptionKey -> ConnectionRequest 'CMInvitation -> ConnInfo -> m ()-sendInvitation c SMPQueueUri {smpServer, senderId} encryptKey cReq connInfo = do+sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()+sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) connReq connInfo =   withLogSMP_ c smpServer senderId "SEND <INV>" $ \smp -> do-    msg <- mkInvitation smp+    msg <- mkInvitation     liftSMP $ sendSMPMessage smp Nothing senderId msg   where-    mkInvitation :: SMPClient -> m ByteString-    mkInvitation smp = do-      senderTimestamp <- liftIO getCurrentTime-      encryptUnsigned smp encryptKey . serializeSMPMessage $-        SMPMessage-          { senderMsgId = 0,-            senderTimestamp,-            previousMsgHash = "",-            agentMessage = A_INV cReq connInfo-          }+    mkInvitation :: m ByteString+    -- this is only encrypted with per-queue E2E, not with double ratchet+    mkInvitation = do+      let agentEnvelope = AgentInvitation {agentVersion = smpAgentVersion, connReq, connInfo}+      agentCbEncryptOnce dhPublicKey . smpEncode $+        SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope -secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()+secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m () secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =   withLogSMP c server rcvId "KEY <key>" $ \smp ->     secureSMPQueue smp rcvPrivateKey rcvId senderKey@@ -358,48 +345,49 @@   withLogSMP c server rcvId "DEL" $ \smp ->     deleteSMPQueue smp rcvPrivateKey rcvId -sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()-sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msg =-  withLogSMP_ c server sndId "SEND <message>" $ \smp -> do-    msg' <- encryptAndSign smp sq msg-    liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg'--encryptAndSign :: AgentMonad m => SMPClient -> SndQueue -> ByteString -> m ByteString-encryptAndSign smp SndQueue {encryptKey, signKey} msg = do-  paddedSize <- asks $ (blockSize smp -) . reservedMsgSize-  liftError cryptoError $ do-    enc <- C.encrypt encryptKey paddedSize msg-    C.Signature sig <- C.sign signKey enc-    pure $ sig <> enc+-- TODO this is just wrong+sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()+sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} agentMsg =+  withLogSMP_ c server sndId "SEND <MSG>" $ \smp -> do+    let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg+    msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg+    liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg -decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString-decryptAndVerify RcvQueue {decryptKey, verifyKey} msg =-  verifyMessage verifyKey msg-    >>= liftError cryptoError . C.decrypt decryptKey+agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString+agentCbEncrypt SndQueue {e2eDhSecret} e2ePubKey msg = do+  cmNonce <- liftIO C.randomCbNonce+  let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey+  cmEncBody <-+    liftEither . first cryptoError $+      C.cbEncrypt e2eDhSecret cmNonce msg paddedLen+  -- TODO per-queue client version+  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) e2ePubKey+  pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody} -encryptUnsigned :: AgentMonad m => SMPClient -> EncryptionKey -> ByteString -> m ByteString-encryptUnsigned smp encryptKey msg = do-  paddedSize <- asks $ (blockSize smp -) . reservedMsgSize-  size <- asks $ rsaKeySize . config-  liftError cryptoError $ do-    enc <- C.encrypt encryptKey paddedSize msg-    let sig = B.replicate size ' '-    pure $ sig <> enc+-- add encoding as AgentInvitation'?+agentCbEncryptOnce :: AgentMonad m => C.PublicKeyX25519 -> ByteString -> m ByteString+agentCbEncryptOnce dhRcvPubKey msg = do+  (dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'+  let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey+  cmNonce <- liftIO C.randomCbNonce+  cmEncBody <-+    liftEither . first cryptoError $+      C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength+  -- TODO per-queue client version+  let cmHeader = SMP.PubHeader (maxVersion SMP.smpClientVRange) (Just dhSndPubKey)+  pure $ smpEncode SMP.ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody} -verifyMessage :: AgentMonad m => Maybe VerificationKey -> ByteString -> m ByteString-verifyMessage verifyKey msg = do-  size <- asks $ rsaKeySize . config-  let (sig, enc) = B.splitAt size msg-  case verifyKey of-    Nothing -> pure enc-    Just k-      | C.verify k (C.Signature sig) enc -> pure enc-      | otherwise -> throwError $ AGENT A_SIGNATURE+-- | NaCl crypto-box decrypt - both for messages received from the server+-- and per-queue E2E encrypted messages from the sender that were inside.+agentCbDecrypt :: AgentMonad m => C.DhSecretX25519 -> C.CbNonce -> ByteString -> m ByteString+agentCbDecrypt dhSecret nonce msg =+  liftEither . first cryptoError $+    C.cbDecrypt dhSecret nonce msg  cryptoError :: C.CryptoError -> AgentErrorType cryptoError = \case   C.CryptoLargeMsgError -> CMD LARGE-  C.RSADecryptError _ -> AGENT A_ENCRYPTION   C.CryptoHeaderError _ -> AGENT A_ENCRYPTION   C.AESDecryptError -> AGENT A_ENCRYPTION+  C.CBDecryptError -> AGENT A_ENCRYPTION   e -> INTERNAL $ show e
src/Simplex/Messaging/Agent/Env/SQLite.hs view
@@ -16,20 +16,23 @@ import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client+import qualified Simplex.Messaging.Crypto as C import System.Random (StdGen, newStdGen) import UnliftIO.STM  data AgentConfig = AgentConfig   { tcpPort :: ServiceName,     smpServers :: NonEmpty SMPServer,-    rsaKeySize :: Int,+    cmdSignAlg :: C.SignAlg,     connIdBytes :: Int,     tbqSize :: Natural,     dbFile :: FilePath,     dbPoolSize :: Int,     smpCfg :: SMPClientConfig,-    retryInterval :: RetryInterval,-    reconnectInterval :: RetryInterval+    reconnectInterval :: RetryInterval,+    caCertificateFile :: FilePath,+    privateKeyFile :: FilePath,+    certificateFile :: FilePath   }  minute :: Int@@ -39,25 +42,24 @@ defaultAgentConfig =   AgentConfig     { tcpPort = "5224",-      smpServers = undefined,-      rsaKeySize = 2048 `div` 8,+      smpServers = undefined, -- TODO move it elsewhere?+      cmdSignAlg = C.SignAlg C.SEd448,       connIdBytes = 12,       tbqSize = 16,       dbFile = "smp-agent.db",       dbPoolSize = 4,       smpCfg = smpDefaultConfig,-      retryInterval =-        RetryInterval-          { initialInterval = 1_000_000,-            increaseAfter = minute,-            maxInterval = 10 * minute-          },       reconnectInterval =         RetryInterval           { initialInterval = 1_000_000,             increaseAfter = 10_000_000,             maxInterval = 10_000_000-          }+          },+      -- CA certificate private key is not needed for initialization+      -- ! we do not generate these+      caCertificateFile = "/etc/opt/simplex-agent/ca.crt",+      privateKeyFile = "/etc/opt/simplex-agent/agent.key",+      certificateFile = "/etc/opt/simplex-agent/agent.crt"     }  data Env = Env@@ -65,7 +67,6 @@     store :: SQLiteStore,     idsDrg :: TVar ChaChaDRG,     clientCounter :: TVar Int,-    reservedMsgSize :: Int,     randomServer :: TVar StdGen   } @@ -75,10 +76,4 @@   store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app   clientCounter <- newTVarIO 0   randomServer <- newTVarIO =<< liftIO newStdGen-  return Env {config = cfg, store, idsDrg, clientCounter, reservedMsgSize, randomServer}-  where-    -- 1st rsaKeySize is used by the RSA signature in each command,-    -- 2nd - by encrypted message body header-    -- 3rd - by message signature-    -- smpCommandSize - is the estimated max size for SMP command, queueId, corrId-    reservedMsgSize = 3 * rsaKeySize cfg + smpCommandSize (smpCfg cfg)+  return Env {config = cfg, store, idsDrg, clientCounter, randomServer}
src/Simplex/Messaging/Agent/Protocol.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}@@ -10,6 +11,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -28,26 +30,38 @@ -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md module Simplex.Messaging.Agent.Protocol-  ( -- * SMP agent protocol types+  ( -- * Protocol parameters+    smpAgentVersion,+    smpAgentVRange,+    e2eEncConnInfoLength,+    e2eEncUserMsgLength,++    -- * SMP agent protocol types     ConnInfo,     ACommand (..),     AParty (..),     SAParty (..),     MsgHash,     MsgMeta (..),-    SMPMessage (..),+    SMPConfirmation (..),+    AgentMsgEnvelope (..),+    AgentMessage (..),+    APrivHeader (..),     AMessage (..),+    AMsgType (..),     SMPServer (..),+    SrvLoc (..),     SMPQueueUri (..),+    SMPQueueInfo (..),     ConnectionMode (..),     SConnectionMode (..),     AConnectionMode (..),     cmInvitation,     cmContact,     ConnectionModeI (..),-    ConnectionRequest (..),-    AConnectionRequest (..),-    ConnReqData (..),+    ConnectionRequestUri (..),+    AConnectionRequestUri (..),+    ConnReqUriData (..),     ConnReqScheme (..),     simplexChat,     AgentErrorType (..),@@ -61,42 +75,27 @@     ConnId,     ConfirmationId,     InvitationId,-    AckMode (..),-    OnOff (..),     MsgIntegrity (..),     MsgErrorType (..),     QueueStatus (..),-    SignatureKey,-    VerificationKey,-    EncryptionKey,-    DecryptionKey,     ACorrId,     AgentMsgId, -    -- * Parse and serialize+    -- * Encode/decode     serializeCommand,-    serializeSMPMessage,     serializeMsgIntegrity,-    serializeServer,-    serializeSMPQueueUri,-    reservedServerKey, -- TODO remove-    serializeConnMode,-    serializeConnMode',     connMode,     connMode',-    serializeConnReq,-    serializeConnReq',     serializeAgentError,+    serializeSmpErrorType,     commandP,-    parseSMPMessage,-    smpServerP,-    smpQueueUriP,     connModeT,-    connReqP,-    connReqP',     msgIntegrityP,     agentErrorTypeP,-    agentMessageP,+    smpErrorTypeP,+    serializeQueueStatus,+    queueStatusT,+    aMessageType,      -- * TCP transport functions     tPut,@@ -108,20 +107,18 @@  import Control.Applicative (optional, (<|>)) import Control.Monad.IO.Class-import qualified Crypto.PubKey.RSA as R+import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Base64-import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B+import Data.Composition ((.:)) import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind (Type)-import Data.List (find) import qualified Data.List.NonEmpty as L import Data.Maybe (isJust)-import Data.String (IsString (..)) import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Time.ISO8601@@ -129,23 +126,43 @@ import Data.Typeable () import GHC.Generics (Generic) import Generic.Random (genericArbitraryU)-import Network.HTTP.Types (parseSimpleQuery, renderSimpleQuery)-import Network.Socket (HostName, ServiceName)+import Simplex.Messaging.Agent.QueryString import qualified Simplex.Messaging.Crypto as C-import Simplex.Messaging.Parsers+import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)+import Simplex.Messaging.Encoding+import Simplex.Messaging.Encoding.String+import Simplex.Messaging.Parsers (base64P, parse, parseRead, parseRead1, parseRead2, tsISO8601P) import Simplex.Messaging.Protocol   ( ErrorType,     MsgBody,     MsgId,-    SenderPublicKey,+    SMPServer (..),+    SndPublicVerifyKey,+    SrvLoc (..),   ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP) import Simplex.Messaging.Util+import Simplex.Messaging.Version import Test.QuickCheck (Arbitrary (..)) import Text.Read import UnliftIO.Exception (Exception) +smpAgentVersion :: Version+smpAgentVersion = 1++smpAgentVRange :: VersionRange+smpAgentVRange = mkVersionRange 1 smpAgentVersion++-- it is shorter to allow all handshake headers,+-- including E2E (double-ratchet) parameters and+-- signing key of the sender for the server+e2eEncConnInfoLength :: Int+e2eEncConnInfoLength = 14848++e2eEncUserMsgLength :: Int+e2eEncUserMsgLength = 15856+ -- | Raw (unparsed) SMP agent protocol transmission. type ARawTransmission = (ByteString, ByteString, ByteString) @@ -184,8 +201,8 @@ -- | Parameterized type for SMP agent protocol commands and responses from all participants. data ACommand (p :: AParty) where   NEW :: AConnectionMode -> ACommand Client -- response INV-  INV :: AConnectionRequest -> ACommand Agent-  JOIN :: AConnectionRequest -> ConnInfo -> ACommand Client -- response OK+  INV :: AConnectionRequestUri -> ACommand Agent+  JOIN :: AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK   CONF :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender   LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client   REQ :: InvitationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender@@ -197,15 +214,12 @@   END :: ACommand Agent   DOWN :: ACommand Agent   UP :: ACommand Agent-  -- QST :: QueueDirection -> ACommand Client-  -- STAT :: QueueDirection -> Maybe QueueStatus -> Maybe SubMode -> ACommand Agent   SEND :: MsgBody -> ACommand Client   MID :: AgentMsgId -> ACommand Agent   SENT :: AgentMsgId -> ACommand Agent   MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent   MSG :: MsgMeta -> MsgBody -> ACommand Agent   ACK :: AgentMsgId -> ACommand Client-  -- RCVD :: AgentMsgId -> ACommand Agent   OFF :: ACommand Client   DEL :: ACommand Client   OK :: ACommand Agent@@ -231,7 +245,7 @@   testEquality SCMContact SCMContact = Just Refl   testEquality _ _ = Nothing -data AConnectionMode = forall m. ACM (SConnectionMode m)+data AConnectionMode = forall m. ConnectionModeI m => ACM (SConnectionMode m)  instance Eq AConnectionMode where   ACM m == ACM m' = isJust $ testEquality m m'@@ -265,206 +279,196 @@   { integrity :: MsgIntegrity,     recipient :: (AgentMsgId, UTCTime),     broker :: (MsgId, UTCTime),-    sender :: (AgentMsgId, UTCTime)+    sndMsgId :: AgentMsgId   }   deriving (Eq, Show) --- | SMP message formats.-data SMPMessage-  = -- | SMP confirmation-    -- (see <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message SMP protocol>)-    SMPConfirmation-      { -- | sender's public key to use for authentication of sender's commands at the recepient's server-        senderKey :: SenderPublicKey,-        -- | sender's information to be associated with the connection, e.g. sender's profile information-        connInfo :: ConnInfo-      }-  | -- | Agent message header and envelope for client messages-    -- (see <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents SMP agent protocol>)-    SMPMessage-      { -- | sequential ID assigned by the sending agent-        senderMsgId :: AgentMsgId,-        -- | timestamp from the sending agent-        senderTimestamp :: SenderTimestamp,-        -- | digest of the previous message-        previousMsgHash :: MsgHash,-        -- | messages sent between agents once queue is secured-        agentMessage :: AMessage-      }+data SMPConfirmation = SMPConfirmation+  { -- | sender's public key to use for authentication of sender's commands at the recepient's server+    senderKey :: SndPublicVerifyKey,+    -- | sender's DH public key for simple per-queue e2e encryption+    e2ePubKey :: C.PublicKeyX25519,+    -- | sender's information to be associated with the connection, e.g. sender's profile information+    connInfo :: ConnInfo+  }   deriving (Show) --- | Messages sent between SMP agents once SMP queue is secured.------ https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents-data AMessage where-  -- | the first message in the queue to validate it is secured-  HELLO :: VerificationKey -> AckMode -> AMessage-  -- | reply queue information-  REPLY :: ConnectionRequest CMInvitation -> AMessage-  -- | agent envelope for the client message-  A_MSG :: MsgBody -> AMessage-  -- | connection request with the invitation to connect-  A_INV :: ConnectionRequest CMInvitation -> ConnInfo -> AMessage+data AgentMsgEnvelope+  = AgentConfirmation+      { agentVersion :: Version,+        e2eEncryption :: Maybe (E2ERatchetParams 'C.X448),+        encConnInfo :: ByteString+      }+  | AgentMsgEnvelope+      { agentVersion :: Version,+        encAgentMessage :: ByteString+      }+  | AgentInvitation -- the connInfo in contactInvite is only encrypted with per-queue E2E, not with double ratchet,+      { agentVersion :: Version,+        connReq :: (ConnectionRequestUri 'CMInvitation),+        connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet,+      }   deriving (Show) --- | Parse SMP message.-parseSMPMessage :: ByteString -> Either AgentErrorType SMPMessage-parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE-  where-    smpMessageP :: Parser SMPMessage-    smpMessageP = A.endOfLine *> smpClientMessageP <|> smpConfirmationP--    smpConfirmationP :: Parser SMPMessage-    smpConfirmationP = "KEY " *> (SMPConfirmation <$> C.pubKeyP <* A.endOfLine <* A.endOfLine <*> binaryBodyP <* A.endOfLine)--    smpClientMessageP :: Parser SMPMessage-    smpClientMessageP =-      SMPMessage-        <$> A.decimal <* A.space-        <*> tsISO8601P <* A.space-        -- TODO previous message hash should become mandatory when we support HELLO and REPLY-        -- (for HELLO it would be the hash of SMPConfirmation)-        <*> (base64P <|> pure "") <* A.endOfLine-        <*> agentMessageP+instance Encoding AgentMsgEnvelope where+  smpEncode = \case+    AgentConfirmation {agentVersion, e2eEncryption, encConnInfo} ->+      smpEncode (agentVersion, 'C', e2eEncryption, Tail encConnInfo)+    AgentMsgEnvelope {agentVersion, encAgentMessage} ->+      smpEncode (agentVersion, 'M', Tail encAgentMessage)+    AgentInvitation {agentVersion, connReq, connInfo} ->+      smpEncode (agentVersion, 'I', Large $ strEncode connReq, Tail connInfo)+  smpP = do+    agentVersion <- smpP+    smpP >>= \case+      'C' -> do+        (e2eEncryption, Tail encConnInfo) <- smpP+        pure AgentConfirmation {agentVersion, e2eEncryption, encConnInfo}+      'M' -> do+        Tail encAgentMessage <- smpP+        pure AgentMsgEnvelope {agentVersion, encAgentMessage}+      'I' -> do+        connReq <- strDecode . unLarge <$?> smpP+        Tail connInfo <- smpP+        pure AgentInvitation {agentVersion, connReq, connInfo}+      _ -> fail "bad AgentMsgEnvelope" --- | Serialize SMP message.-serializeSMPMessage :: SMPMessage -> ByteString-serializeSMPMessage = \case-  SMPConfirmation sKey cInfo -> smpMessage ("KEY " <> C.serializePubKey sKey) "" (serializeBinary cInfo) <> "\n"-  SMPMessage {senderMsgId, senderTimestamp, previousMsgHash, agentMessage} ->-    let header = messageHeader senderMsgId senderTimestamp previousMsgHash-        body = serializeAgentMessage agentMessage-     in smpMessage "" header body-  where-    messageHeader msgId ts prevMsgHash =-      B.unwords [bshow msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash]-    smpMessage smpHeader aHeader aBody = B.intercalate "\n" [smpHeader, aHeader, aBody, ""]+-- SMP agent message formats (after double ratchet decryption,+-- or in case of AgentInvitation - in plain text body)+data AgentMessage = AgentConnInfo ConnInfo | AgentMessage APrivHeader AMessage+  deriving (Show) -agentMessageP :: Parser AMessage-agentMessageP =-  "HELLO " *> hello-    <|> "REPLY " *> reply-    <|> "MSG " *> a_msg-    <|> "INV " *> a_inv-  where-    hello = HELLO <$> C.pubKeyP <*> ackMode-    reply = REPLY <$> connReqP'-    a_msg = A_MSG <$> binaryBodyP <* A.endOfLine-    a_inv = A_INV <$> connReqP' <* A.space <*> binaryBodyP <* A.endOfLine-    ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On)+instance Encoding AgentMessage where+  smpEncode = \case+    AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)+    AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)+  smpP =+    smpP >>= \case+      'I' -> AgentConnInfo . unTail <$> smpP+      'M' -> AgentMessage <$> smpP <*> smpP+      _ -> fail "bad AgentMessage" --- | SMP server location parser.-smpServerP :: Parser SMPServer-smpServerP = SMPServer <$> server <*> optional port <*> optional kHash-  where-    server = B.unpack <$> A.takeWhile1 (A.notInClass ":#,; ")-    port = A.char ':' *> (B.unpack <$> A.takeWhile1 A.isDigit)-    kHash = C.KeyHash <$> (A.char '#' *> base64P)+data APrivHeader = APrivHeader+  { -- | sequential ID assigned by the sending agent+    sndMsgId :: AgentMsgId,+    -- | digest of the previous message+    prevMsgHash :: MsgHash+  }+  deriving (Show) -serializeAgentMessage :: AMessage -> ByteString-serializeAgentMessage = \case-  HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else ""-  REPLY cReq -> "REPLY " <> serializeConnReq' cReq-  A_MSG body -> "MSG " <> serializeBinary body <> "\n"-  A_INV cReq cInfo -> B.unwords ["INV", serializeConnReq' cReq, serializeBinary cInfo] <> "\n"+instance Encoding APrivHeader where+  smpEncode APrivHeader {sndMsgId, prevMsgHash} =+    smpEncode (sndMsgId, prevMsgHash)+  smpP = APrivHeader <$> smpP <*> smpP --- | Serialize SMP queue information that is sent out-of-band.-serializeSMPQueueUri :: SMPQueueUri -> ByteString-serializeSMPQueueUri (SMPQueueUri srv qId _) =-  serializeServerUri srv <> "/" <> U.encode qId <> "#"+data AMsgType = HELLO_ | REPLY_ | A_MSG_+  deriving (Eq) --- | SMP queue information parser.-smpQueueUriP :: Parser SMPQueueUri-smpQueueUriP =-  SMPQueueUri <$> smpServerUriP <* "/" <*> base64UriP <* "#" <*> pure reservedServerKey+instance Encoding AMsgType where+  smpEncode = \case+    HELLO_ -> "H"+    REPLY_ -> "R"+    A_MSG_ -> "M"+  smpP =+    smpP >>= \case+      'H' -> pure HELLO_+      'R' -> pure REPLY_+      'M' -> pure A_MSG_+      _ -> fail "bad AMsgType" -reservedServerKey :: C.PublicKey-reservedServerKey = C.PublicKey $ R.PublicKey 1 0 0+aMessageType :: AMessage -> AMsgType+aMessageType = \case+  HELLO -> HELLO_+  REPLY _ -> REPLY_+  A_MSG _ -> A_MSG_ -serializeConnReq :: AConnectionRequest -> ByteString-serializeConnReq (ACR _ cr) = serializeConnReq' cr+-- | Messages sent between SMP agents once SMP queue is secured.+--+-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents+data AMessage+  = -- | the first message in the queue to validate it is secured+    HELLO+  | -- | reply queues information+    REPLY (L.NonEmpty SMPQueueInfo)+  | -- | agent envelope for the client message+    A_MSG MsgBody+  deriving (Show) -serializeConnReq' :: ConnectionRequest m -> ByteString-serializeConnReq' = \case-  CRInvitation crData -> serialize CMInvitation crData-  CRContact crData -> serialize CMContact crData-  where-    serialize crMode ConnReqData {crScheme, crSmpQueues, crEncryptKey} =-      sch <> "/" <> m <> "#/" <> queryStr-      where-        sch = case crScheme of-          CRSSimplex -> "simplex:"-          CRSAppServer host port -> B.pack $ "https://" <> host <> maybe "" (':' :) port-        m = case crMode of-          CMInvitation -> "invitation"-          CMContact -> "contact"-        queryStr = renderSimpleQuery True [("smp", queues), ("e2e", key)]-        queues = B.intercalate "," . map serializeSMPQueueUri $ L.toList crSmpQueues-        key = C.serializePubKeyUri crEncryptKey+instance Encoding AMessage where+  smpEncode = \case+    HELLO -> smpEncode HELLO_+    REPLY smpQueues -> smpEncode (REPLY_, smpQueues)+    A_MSG body -> smpEncode (A_MSG_, Tail body)+  smpP =+    smpP+      >>= \case+        HELLO_ -> pure HELLO+        REPLY_ -> REPLY <$> smpP+        A_MSG_ -> A_MSG . unTail <$> smpP -connReqP' :: forall m. ConnectionModeI m => Parser (ConnectionRequest m)-connReqP' = do-  ACR m cr <- connReqP-  case testEquality m $ sConnectionMode @m of-    Just Refl -> pure cr-    _ -> fail "bad connection request mode"+instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where+  strEncode = \case+    CRInvitationUri crData e2eParams -> crEncode "invitation" crData (Just e2eParams)+    CRContactUri crData -> crEncode "contact" crData Nothing+    where+      crEncode :: ByteString -> ConnReqUriData -> Maybe (E2ERatchetParamsUri 'C.X448) -> ByteString+      crEncode crMode ConnReqUriData {crScheme, crAgentVRange, crSmpQueues} e2eParams =+        strEncode crScheme <> "/" <> crMode <> "#/?" <> queryStr+        where+          queryStr =+            strEncode . QSP QEscape $+              [("v", strEncode crAgentVRange), ("smp", strEncode crSmpQueues)]+                <> maybe [] (\e2e -> [("e2e", strEncode e2e)]) e2eParams+  strP = do+    ACR m cr <- strP+    case testEquality m $ sConnectionMode @m of+      Just Refl -> pure cr+      _ -> fail "bad connection request mode" -connReqP :: Parser AConnectionRequest-connReqP = do-  crScheme <- "simplex:" $> CRSSimplex <|> "https://" *> appServer-  crMode <- "/" *> mode <* "#/?"-  query <- parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')-  crSmpQueues <- paramP "smp" smpQueues query-  crEncryptKey <- paramP "e2e" C.pubKeyUriP query-  let cReq = ConnReqData {crScheme, crSmpQueues, crEncryptKey}-  pure $ case crMode of-    CMInvitation -> ACR SCMInvitation $ CRInvitation cReq-    CMContact -> ACR SCMContact $ CRContact cReq-  where-    appServer = CRSAppServer <$> host <*> optional port-    host = B.unpack <$> A.takeTill (\c -> c == ':' || c == '/')-    port = B.unpack <$> (A.char ':' *> A.takeTill (== '/'))-    mode = "invitation" $> CMInvitation <|> "contact" $> CMContact-    paramP param parser query =-      let p = maybe (fail "") (pure . snd) $ find ((== param) . fst) query-       in parseAll parser <$?> p-    smpQueues =-      maybe (fail "no SMP queues") pure . L.nonEmpty-        =<< (smpQueue `A.sepBy1'` A.char ',')-    smpQueue = parseAll smpQueueUriP <$?> A.takeTill (== ',')+instance StrEncoding AConnectionRequestUri where+  strEncode (ACR _ cr) = strEncode cr+  strP = do+    crScheme <- strP+    crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"+    query <- strP+    crAgentVRange <- queryParam "v" query+    crSmpQueues <- queryParam "smp" query+    let crData = ConnReqUriData {crScheme, crAgentVRange, crSmpQueues}+    case crMode of+      CMInvitation -> do+        crE2eParams <- queryParam "e2e" query+        pure . ACR SCMInvitation $ CRInvitationUri crData crE2eParams+      CMContact -> pure . ACR SCMContact $ CRContactUri crData+    where+      crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact --- | Serialize SMP server location.-serializeServer :: SMPServer -> ByteString-serializeServer SMPServer {host, port, keyHash} =-  B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . encode . C.unKeyHash) keyHash+instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where+  parseJSON = strParseJSON "ConnectionRequestUri" -serializeServerUri :: SMPServer -> ByteString-serializeServerUri SMPServer {host, port, keyHash} = "smp://" <> kh <> B.pack host <> p-  where-    kh = maybe "" ((<> "@") . U.encode . C.unKeyHash) keyHash-    p = B.pack $ maybe "" (':' :) port+instance ConnectionModeI m => ToJSON (ConnectionRequestUri m) where+  toJSON = strToJSON+  toEncoding = strToJEncoding -smpServerUriP :: Parser SMPServer-smpServerUriP = do-  _ <- "smp://"-  keyHash <- optional $ C.KeyHash <$> (U.decode <$?> A.takeTill (== '@') <* A.char '@')-  host <- B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")-  port <- optional $ B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)-  pure SMPServer {host, port, keyHash}+instance FromJSON AConnectionRequestUri where+  parseJSON = strParseJSON "ConnectionRequestUri" -serializeConnMode :: AConnectionMode -> ByteString-serializeConnMode (ACM cMode) = serializeConnMode' $ connMode cMode+instance ToJSON AConnectionRequestUri where+  toJSON = strToJSON+  toEncoding = strToJEncoding -serializeConnMode' :: ConnectionMode -> ByteString-serializeConnMode' = \case-  CMInvitation -> "INV"-  CMContact -> "CON"+-- debug :: Show a => String -> a -> a+-- debug name value = unsafePerformIO (putStrLn $ name <> ": " <> show value) `seq` value+-- {-# INLINE debug #-} -connModeP' :: Parser ConnectionMode-connModeP' = "INV" $> CMInvitation <|> "CON" $> CMContact+instance StrEncoding ConnectionMode where+  strEncode = \case+    CMInvitation -> "INV"+    CMContact -> "CON"+  strP = "INV" $> CMInvitation <|> "CON" $> CMContact -connModeP :: Parser AConnectionMode-connModeP = connMode' <$> connModeP'+instance StrEncoding AConnectionMode where+  strEncode (ACM cMode) = strEncode $ connMode cMode+  strP = connMode' <$> strP  connModeT :: Text -> Maybe ConnectionMode connModeT = \case@@ -472,83 +476,113 @@   "CON" -> Just CMContact   _ -> Nothing --- | SMP server location and transport key digest (hash).-data SMPServer = SMPServer-  { host :: HostName,-    port :: Maybe ServiceName,-    keyHash :: Maybe C.KeyHash-  }-  deriving (Eq, Ord, Show)--instance IsString SMPServer where-  fromString = parseString $ parseAll smpServerP---- | SMP agent connection alias.+-- | SMP agent connection ID. type ConnId = ByteString  type ConfirmationId = ByteString  type InvitationId = ByteString --- | Connection modes.-data OnOff = On | Off deriving (Eq, Show, Read)+data SMPQueueInfo = SMPQueueInfo+  { clientVersion :: Version,+    smpServer :: SMPServer,+    senderId :: SMP.SenderId,+    dhPublicKey :: C.PublicKeyX25519+  }+  deriving (Eq, Show) --- | Message acknowledgement mode of the connection.-newtype AckMode = AckMode OnOff deriving (Eq, Show)+instance Encoding SMPQueueInfo where+  smpEncode SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey} =+    smpEncode (clientVersion, smpServer, senderId, dhPublicKey)+  smpP = do+    (clientVersion, smpServer, senderId, dhPublicKey) <- smpP+    pure SMPQueueInfo {clientVersion, smpServer, senderId, dhPublicKey} +-- This instance seems contrived and there was a temptation to split a common part of both types.+-- But this is created to allow backward and forward compatibility where SMPQueueUri+-- could have more fields to convert to different versions of SMPQueueInfo in a different way,+-- and this instance would become non-trivial.+instance VersionI SMPQueueInfo where+  type VersionRangeT SMPQueueInfo = SMPQueueUri+  version = clientVersion+  toVersionRangeT SMPQueueInfo {smpServer, senderId, dhPublicKey} vr =+    SMPQueueUri {clientVRange = vr, smpServer, senderId, dhPublicKey}++instance VersionRangeI SMPQueueUri where+  type VersionT SMPQueueUri = SMPQueueInfo+  versionRange = clientVRange+  toVersionT SMPQueueUri {smpServer, senderId, dhPublicKey} v =+    SMPQueueInfo {clientVersion = v, smpServer, senderId, dhPublicKey}+ -- | SMP queue information sent out-of-band. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages data SMPQueueUri = SMPQueueUri   { smpServer :: SMPServer,     senderId :: SMP.SenderId,-    serverVerifyKey :: VerificationKey+    clientVRange :: VersionRange,+    dhPublicKey :: C.PublicKeyX25519   }   deriving (Eq, Show) -data ConnectionRequest (m :: ConnectionMode) where-  CRInvitation :: ConnReqData -> ConnectionRequest CMInvitation-  CRContact :: ConnReqData -> ConnectionRequest CMContact+-- TODO change SMP queue URI format to include version range and allow unknown parameters+instance StrEncoding SMPQueueUri where+  -- v1 uses short SMP queue URI format+  strEncode SMPQueueUri {smpServer = srv, senderId = qId, clientVRange = _vr, dhPublicKey = k} =+    strEncode srv <> "/" <> strEncode qId <> "#" <> strEncode k+  strP = do+    smpServer <- strP <* A.char '/'+    senderId <- strP <* optional (A.char '/') <* A.char '#'+    (vr, dhPublicKey) <- unversioned <|> versioned+    pure SMPQueueUri {smpServer, senderId, clientVRange = vr, dhPublicKey}+    where+      unversioned = (SMP.smpClientVRange,) <$> strP <* A.endOfInput+      versioned = do+        dhKey_ <- optional strP+        query <- optional (A.char '/') *> A.char '?' *> strP+        vr <- queryParam "v" query+        dhKey <- maybe (queryParam "dh" query) pure dhKey_+        pure (vr, dhKey) -deriving instance Eq (ConnectionRequest m)+data ConnectionRequestUri (m :: ConnectionMode) where+  CRInvitationUri :: ConnReqUriData -> E2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation+  -- contact connection request does NOT contain E2E encryption parameters -+  -- they are passed in AgentInvitation message+  CRContactUri :: ConnReqUriData -> ConnectionRequestUri CMContact -deriving instance Show (ConnectionRequest m)+deriving instance Eq (ConnectionRequestUri m) -data AConnectionRequest = forall m. ACR (SConnectionMode m) (ConnectionRequest m)+deriving instance Show (ConnectionRequestUri m) -instance Eq AConnectionRequest where+data AConnectionRequestUri = forall m. ConnectionModeI m => ACR (SConnectionMode m) (ConnectionRequestUri m)++instance Eq AConnectionRequestUri where   ACR m cr == ACR m' cr' = case testEquality m m' of     Just Refl -> cr == cr'     _ -> False -deriving instance Show AConnectionRequest+deriving instance Show AConnectionRequestUri -data ConnReqData = ConnReqData+data ConnReqUriData = ConnReqUriData   { crScheme :: ConnReqScheme,-    crSmpQueues :: L.NonEmpty SMPQueueUri,-    crEncryptKey :: EncryptionKey+    crAgentVRange :: VersionRange,+    crSmpQueues :: L.NonEmpty SMPQueueUri   }   deriving (Eq, Show) -data ConnReqScheme = CRSSimplex | CRSAppServer HostName (Maybe ServiceName)+data ConnReqScheme = CRSSimplex | CRSAppServer SrvLoc   deriving (Eq, Show) -simplexChat :: ConnReqScheme-simplexChat = CRSAppServer "simplex.chat" Nothing---- | Public key used to E2E encrypt SMP messages.-type EncryptionKey = C.PublicKey---- | Private key used to E2E decrypt SMP messages.-type DecryptionKey = C.SafePrivateKey---- | Private key used to sign SMP commands-type SignatureKey = C.APrivateKey---- | Public key used by SMP server to authorize (verify) SMP commands.-type VerificationKey = C.PublicKey+instance StrEncoding ConnReqScheme where+  strEncode = \case+    CRSSimplex -> "simplex:"+    CRSAppServer srv -> "https://" <> strEncode srv+  strP =+    "simplex:" $> CRSSimplex+      <|> "https://" *> (CRSAppServer <$> strP) -data QueueDirection = SND | RCV deriving (Show)+simplexChat :: ConnReqScheme+simplexChat = CRSAppServer $ SrvLoc "simplex.chat" ""  -- | SMP queue status. data QueueStatus@@ -564,10 +598,25 @@     Disabled   deriving (Eq, Show, Read) -type AgentMsgId = Int64+serializeQueueStatus :: QueueStatus -> Text+serializeQueueStatus = \case+  New -> "new"+  Confirmed -> "confirmed"+  Secured -> "secured"+  Active -> "active"+  Disabled -> "disabled" -type SenderTimestamp = UTCTime+queueStatusT :: Text -> Maybe QueueStatus+queueStatusT = \case+  "new" -> Just New+  "confirmed" -> Just Confirmed+  "secured" -> Just Secured+  "active" -> Just Active+  "disabled" -> Just Disabled+  _ -> Nothing +type AgentMsgId = Int64+ -- | Result of received message integrity validation. data MsgIntegrity = MsgOk | MsgError MsgErrorType   deriving (Eq, Show)@@ -608,9 +657,9 @@  -- | Connection error. data ConnectionErrorType-  = -- | connection alias is not in the database+  = -- | connection is not in the database     NOT_FOUND-  | -- | connection alias already exists+  | -- | connection already exists     DUPLICATE   | -- | connection is simplex, but operation requires another queue     SIMPLEX@@ -631,15 +680,16 @@   deriving (Eq, Generic, Read, Show, Exception)  -- | Errors of another SMP agent.+-- TODO encode/decode without A prefix data SMPAgentError-  = -- | possibly should include bytestring that failed to parse+  = -- | client or agent message that failed to parse     A_MESSAGE-  | -- | possibly should include the prohibited SMP/agent message+  | -- | prohibited SMP/agent message     A_PROHIBITED-  | -- | cannot RSA/AES-decrypt or parse decrypted header+  | -- | incompatible version of SMP client, agent or encryption protocols+    A_VERSION+  | -- | cannot decrypt message     A_ENCRYPTION-  | -- | invalid RSA signature-    A_SIGNATURE   deriving (Eq, Generic, Read, Show, Exception)  instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU@@ -680,28 +730,28 @@     <|> "CON" $> ACmd SAgent CON     <|> "OK" $> ACmd SAgent OK   where-    newCmd = ACmd SClient . NEW <$> connModeP-    invResp = ACmd SAgent . INV <$> connReqP-    joinCmd = ACmd SClient <$> (JOIN <$> connReqP <* A.space <*> A.takeByteString)-    confMsg = ACmd SAgent <$> (CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)-    letCmd = ACmd SClient <$> (LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)-    reqMsg = ACmd SAgent <$> (REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)-    acptCmd = ACmd SClient <$> (ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)+    newCmd = ACmd SClient . NEW <$> strP+    invResp = ACmd SAgent . INV <$> strP+    joinCmd = ACmd SClient .: JOIN <$> strP_ <*> A.takeByteString+    confMsg = ACmd SAgent .: CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString+    letCmd = ACmd SClient .: LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString+    reqMsg = ACmd SAgent .: REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString+    acptCmd = ACmd SClient .: ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString     rjctCmd = ACmd SClient . RJCT <$> A.takeByteString     infoCmd = ACmd SAgent . INFO <$> A.takeByteString     sendCmd = ACmd SClient . SEND <$> A.takeByteString     msgIdResp = ACmd SAgent . MID <$> A.decimal     sentResp = ACmd SAgent . SENT <$> A.decimal-    msgErrResp = ACmd SAgent <$> (MERR <$> A.decimal <* A.space <*> agentErrorTypeP)-    message = ACmd SAgent <$> (MSG <$> msgMetaP <* A.space <*> A.takeByteString)+    msgErrResp = ACmd SAgent .: MERR <$> A.decimal <* A.space <*> agentErrorTypeP+    message = ACmd SAgent .: MSG <$> msgMetaP <* A.space <*> A.takeByteString     ackCmd = ACmd SClient . ACK <$> A.decimal     msgMetaP = do       integrity <- msgIntegrityP       recipient <- " R=" *> partyMeta A.decimal       broker <- " B=" *> partyMeta base64P-      sender <- " S=" *> partyMeta A.decimal-      pure MsgMeta {integrity, recipient, broker, sender}-    partyMeta idParser = (,) <$> idParser <* "," <*> tsISO8601P+      sndMsgId <- " S=" *> A.decimal+      pure MsgMeta {integrity, recipient, broker, sndMsgId}+    partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P     agentError = ACmd SAgent . ERR <$> agentErrorTypeP  -- | Message integrity validation result parser.@@ -720,9 +770,9 @@ -- | Serialize SMP agent command. serializeCommand :: ACommand p -> ByteString serializeCommand = \case-  NEW cMode -> "NEW " <> serializeConnMode cMode-  INV cReq -> "INV " <> serializeConnReq cReq-  JOIN cReq cInfo -> B.unwords ["JOIN", serializeConnReq cReq, serializeBinary cInfo]+  NEW cMode -> "NEW " <> strEncode cMode+  INV cReq -> "INV " <> strEncode cReq+  JOIN cReq cInfo -> B.unwords ["JOIN", strEncode cReq, serializeBinary cInfo]   CONF confId cInfo -> B.unwords ["CONF", confId, serializeBinary cInfo]   LET confId cInfo -> B.unwords ["LET", confId, serializeBinary cInfo]   REQ invId cInfo -> B.unwords ["REQ", invId, serializeBinary cInfo]@@ -748,12 +798,12 @@     showTs :: UTCTime -> ByteString     showTs = B.pack . formatISO8601Millis     serializeMsgMeta :: MsgMeta -> ByteString-    serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sender = (smId, sTs)} =+    serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =       B.unwords         [ serializeMsgIntegrity integrity,           "R=" <> bshow rmId <> "," <> showTs rTs,           "B=" <> encode bmId <> "," <> showTs bTs,-          "S=" <> bshow smId <> "," <> showTs sTs+          "S=" <> bshow sndMsgId         ]  -- | Serialize message integrity validation result.@@ -771,8 +821,8 @@ -- | SMP agent protocol error parser. agentErrorTypeP :: Parser AgentErrorType agentErrorTypeP =-  "SMP " *> (SMP <$> SMP.errorTypeP)-    <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> SMP.errorTypeP)+  "SMP " *> (SMP <$> smpErrorTypeP)+    <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> smpErrorTypeP)     <|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)     <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)     <|> parseRead2@@ -780,16 +830,19 @@ -- | Serialize SMP agent protocol error. serializeAgentError :: AgentErrorType -> ByteString serializeAgentError = \case-  SMP e -> "SMP " <> SMP.serializeErrorType e-  BROKER (RESPONSE e) -> "BROKER RESPONSE " <> SMP.serializeErrorType e+  SMP e -> "SMP " <> serializeSmpErrorType e+  BROKER (RESPONSE e) -> "BROKER RESPONSE " <> serializeSmpErrorType e   BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e   e -> bshow e -binaryBodyP :: Parser ByteString-binaryBodyP = do-  size :: Int <- A.decimal <* A.endOfLine-  A.take size+-- | SMP error parser.+smpErrorTypeP :: Parser ErrorType+smpErrorTypeP = "CMD " *> (SMP.CMD <$> parseRead1) <|> parseRead1 +-- | Serialize SMP error.+serializeSmpErrorType :: ErrorType -> ByteString+serializeSmpErrorType = bshow+ serializeBinary :: ByteString -> ByteString serializeBinary body = bshow (B.length body) <> "\n" <> body @@ -806,8 +859,8 @@  -- | Send SMP agent protocol command (or response) to TCP connection. tPut :: (Transport c, MonadIO m) => c -> ATransmission p -> m ()-tPut h (corrId, connAlias, command) =-  liftIO $ tPutRaw h (corrId, connAlias, serializeCommand command)+tPut h (corrId, connId, command) =+  liftIO $ tPutRaw h (corrId, connId, serializeCommand command)  -- | Receive client and agent transmissions from TCP connection. tGet :: forall c m p. (Transport c, MonadIO m) => SAParty p -> c -> m (ATransmissionOrError p)@@ -849,7 +902,6 @@       INFO cInfo -> INFO <$$> getBody cInfo       cmd -> pure $ Right cmd -    -- TODO refactor with server     getBody :: ByteString -> m (Either AgentErrorType ByteString)     getBody binary =       case B.unpack binary of
+ src/Simplex/Messaging/Agent/QueryString.hs view
@@ -0,0 +1,30 @@+module Simplex.Messaging.Agent.QueryString where++import Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.List (find)+import qualified Network.HTTP.Types as Q+import Simplex.Messaging.Encoding.String+import Simplex.Messaging.Parsers (parseAll)++data QueryStringParams = QSP QSPEscaping Q.SimpleQuery+  deriving (Show)++data QSPEscaping = QEscape | QNoEscaping+  deriving (Show)++instance StrEncoding QueryStringParams where+  strEncode (QSP esc q) = case esc of+    QEscape -> Q.renderSimpleQuery False q+    QNoEscaping ->+      Q.renderQueryPartialEscape False $+        map (\(n, v) -> (n, [Q.QN v])) q+  strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')++queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a+queryParam name (QSP _ q) =+  case find ((== name) . fst) q of+    Just (_, p) -> either fail pure $ parseAll strP p+    _ -> fail $ "no qs param " <> B.unpack name
src/Simplex/Messaging/Agent/Store.hs view
@@ -18,12 +18,14 @@ import Data.Time (UTCTime) import Data.Type.Equality import Simplex.Messaging.Agent.Protocol+import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff, SkippedMsgKeys) import Simplex.Messaging.Protocol   ( MsgBody,     MsgId,-    RecipientPrivateKey,-    SenderPrivateKey,-    SenderPublicKey,+    RcvDhSecret,+    RcvPrivateSignKey,+    SndPrivateSignKey,   ) import qualified Simplex.Messaging.Protocol as SMP @@ -35,15 +37,13 @@   createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId   createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId   getConn :: s -> ConnId -> m SomeConn-  getAllConnIds :: s -> m [ConnId] -- TODO remove - hack for subscribing to all   getRcvConn :: s -> SMPServer -> SMP.RecipientId -> m SomeConn   deleteConn :: s -> ConnId -> m ()   upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m ()   upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m ()   setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()-  setRcvQueueActive :: s -> RcvQueue -> VerificationKey -> m ()+  setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.DhSecretX25519 -> m ()   setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()-  updateSignKey :: s -> SndQueue -> SignatureKey -> m ()    -- Confirmations   createConfirmation :: s -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId@@ -62,23 +62,37 @@   createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()   updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)   createSndMsg :: s -> ConnId -> SndMsgData -> m ()-  updateSndMsgStatus :: s -> ConnId -> InternalId -> SndMsgStatus -> m ()-  getPendingMsgData :: s -> ConnId -> InternalId -> m MsgBody+  getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody))   getPendingMsgs :: s -> ConnId -> m [InternalId]-  getMsg :: s -> ConnId -> InternalId -> m Msg   checkRcvMsg :: s -> ConnId -> InternalId -> m ()-  updateRcvMsgAck :: s -> ConnId -> InternalId -> m ()+  deleteMsg :: s -> ConnId -> InternalId -> m () +  -- Double ratchet persistence+  createRatchetX3dhKeys :: s -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()+  getRatchetX3dhKeys :: s -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)+  createRatchet :: s -> ConnId -> RatchetX448 -> m ()+  getRatchet :: s -> ConnId -> m RatchetX448+  getSkippedMsgKeys :: s -> ConnId -> m SkippedMsgKeys+  updateRatchet :: s -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()+ -- * Queue types  -- | A receive queue. SMP queue through which the agent receives messages from a sender. data RcvQueue = RcvQueue   { server :: SMPServer,+    -- | recipient queue ID     rcvId :: SMP.RecipientId,-    rcvPrivateKey :: RecipientPrivateKey,+    -- | key used by the recipient to sign transmissions+    rcvPrivateKey :: RcvPrivateSignKey,+    -- | shared DH secret used to encrypt/decrypt message bodies from server to recipient+    rcvDhSecret :: RcvDhSecret,+    -- | private DH key related to public sent to sender out-of-band (to agree simple per-queue e2e)+    e2ePrivKey :: C.PrivateKeyX25519,+    -- | public sender's DH key and agreed shared DH secret for simple per-queue e2e+    e2eDhSecret :: Maybe C.DhSecretX25519,+    -- | sender queue ID     sndId :: Maybe SMP.SenderId,-    decryptKey :: DecryptionKey,-    verifyKey :: Maybe VerificationKey,+    -- | queue status     status :: QueueStatus   }   deriving (Eq, Show)@@ -86,10 +100,13 @@ -- | A send queue. SMP queue through which the agent sends messages to a recipient. data SndQueue = SndQueue   { server :: SMPServer,+    -- | sender queue ID     sndId :: SMP.SenderId,-    sndPrivateKey :: SenderPrivateKey,-    encryptKey :: EncryptionKey,-    signKey :: SignatureKey,+    -- | key used by the sender to sign transmissions+    sndPrivateKey :: SndPrivateSignKey,+    -- | shared DH secret agreed for simple per-queue e2e encryption+    e2eDhSecret :: C.DhSecretX25519,+    -- | queue status     status :: QueueStatus   }   deriving (Eq, Show)@@ -160,15 +177,15 @@  data NewConfirmation = NewConfirmation   { connId :: ConnId,-    senderKey :: SenderPublicKey,-    senderConnInfo :: ConnInfo+    senderConf :: SMPConfirmation,+    ratchetState :: RatchetX448   }  data AcceptedConfirmation = AcceptedConfirmation   { confirmationId :: ConfirmationId,     connId :: ConnId,-    senderKey :: SenderPublicKey,-    senderConnInfo :: ConnInfo,+    senderConf :: SMPConfirmation,+    ratchetState :: RatchetX448,     ownConnInfo :: ConnInfo   } @@ -176,14 +193,14 @@  data NewInvitation = NewInvitation   { contactConnId :: ConnId,-    connReq :: ConnectionRequest 'CMInvitation,+    connReq :: ConnectionRequestUri 'CMInvitation,     recipientConnInfo :: ConnInfo   }  data Invitation = Invitation   { invitationId :: InvitationId,     contactConnId :: ConnId,-    connReq :: ConnectionRequest 'CMInvitation,+    connReq :: ConnectionRequestUri 'CMInvitation,     recipientConnInfo :: ConnInfo,     ownConnInfo :: Maybe ConnInfo,     accepted :: Bool@@ -200,12 +217,11 @@ -- | Corresponds to `last_snd_msg_hash` in `connections` table type PrevSndMsgHash = MsgHash --- ? merge/replace these with RcvMsg and SndMsg- -- * Message data containers - used on Msg creation to reduce number of parameters  data RcvMsgData = RcvMsgData   { msgMeta :: MsgMeta,+    msgType :: AMsgType,     msgBody :: MsgBody,     internalRcvId :: InternalRcvId,     internalHash :: MsgHash,@@ -216,9 +232,10 @@   { internalId :: InternalId,     internalSndId :: InternalSndId,     internalTs :: InternalTs,+    msgType :: AMsgType,     msgBody :: MsgBody,     internalHash :: MsgHash,-    previousMsgHash :: MsgHash+    prevMsgHash :: MsgHash   }  data PendingMsg = PendingMsg@@ -227,43 +244,6 @@   }   deriving (Show) --- * Broadcast types--type BroadcastId = ByteString---- * Message types---- | A message in either direction that is stored by the agent.-data Msg = MRcv RcvMsg | MSnd SndMsg-  deriving (Eq, Show)---- | A message received by the agent from a sender.-data RcvMsg = RcvMsg-  { msgBase :: MsgBase,-    internalRcvId :: InternalRcvId,-    -- | Id of the message at sender, corresponds to `internalSndId` from the sender's side.-    -- Sender Id is made sequential for detection of missing messages. For redundant / parallel queues,-    -- it also allows to keep track of duplicates and restore the original order before delivery to the client.-    externalSndId :: ExternalSndId,-    externalSndTs :: ExternalSndTs,-    -- | Id of the message at broker, although it is not sequential (to avoid metadata leakage for potential observer),-    -- it is needed to track repeated deliveries in case of connection loss - this logic is not implemented yet.-    brokerId :: BrokerId,-    brokerTs :: BrokerTs,-    rcvMsgStatus :: RcvMsgStatus,-    -- | Timestamp of acknowledgement to broker, corresponds to `AcknowledgedToBroker` status.-    -- Do not mix up with `brokerTs` - timestamp created at broker after it receives the message from sender.-    ackBrokerTs :: AckBrokerTs,-    -- | Timestamp of acknowledgement to sender, corresponds to `AcknowledgedToSender` status.-    -- Do not mix up with `externalSndTs` - timestamp created at sender before sending,-    -- which in its turn corresponds to `internalTs` in sending agent.-    ackSenderTs :: AckSenderTs,-    -- | Hash of previous message as received from sender - stored for integrity forensics.-    externalPrevSndHash :: MsgHash,-    msgIntegrity :: MsgIntegrity-  }-  deriving (Eq, Show)- -- internal Ids are newtypes to prevent mixing them up newtype InternalRcvId = InternalRcvId {unRcvId :: Int64} deriving (Eq, Show) @@ -275,44 +255,11 @@  type BrokerTs = UTCTime -data RcvMsgStatus-  = Received-  | AcknowledgedToBroker-  | AcknowledgedToSender-  deriving (Eq, Show)--type AckBrokerTs = UTCTime--type AckSenderTs = UTCTime---- | A message sent by the agent to a recipient.-data SndMsg = SndMsg-  { msgBase :: MsgBase,-    -- | Id of the message sent / to be sent, as in its number in order of sending.-    internalSndId :: InternalSndId,-    sndMsgStatus :: SndMsgStatus,-    -- | Timestamp of the message received by broker, corresponds to `Sent` status.-    sentTs :: SentTs,-    -- | Timestamp of the message received by recipient, corresponds to `Delivered` status.-    deliveredTs :: DeliveredTs-  }-  deriving (Eq, Show)- newtype InternalSndId = InternalSndId {unSndId :: Int64} deriving (Eq, Show) -data SndMsgStatus-  = SndMsgCreated-  | SndMsgSent-  | SndMsgDelivered-  deriving (Eq, Show)--type SentTs = UTCTime--type DeliveredTs = UTCTime- -- | Base message data independent of direction. data MsgBase = MsgBase-  { connAlias :: ConnId,+  { connId :: ConnId,     -- | Monotonically increasing id of a message per connection, internal to the agent.     -- Internal Id preserves ordering between both received and sent messages, and is needed     -- to track the order of the conversation (which can be different for the sender / receiver)@@ -336,11 +283,11 @@ data StoreError   = -- | IO exceptions in store actions.     SEInternal ByteString-  | -- | failed to generate unique random ID+  | -- | Failed to generate unique random ID     SEUniqueID-  | -- | Connection alias not found (or both queues absent).+  | -- | Connection not found (or both queues absent).     SEConnNotFound-  | -- | Connection alias already used.+  | -- | Connection already used.     SEConnDuplicate   | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa.     -- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error.@@ -355,6 +302,10 @@     -- as we always know what it should be at any stage of the protocol,     -- and in case it does not match use this error.     SEBadQueueStatus+  | -- | connection does not have associated double-ratchet state+    SERatchetNotFound+  | -- | connection does not have associated x3dh keys+    SEX3dhKeysNotFound   | -- | Used in `getMsg` that is not implemented/used. TODO remove.     SENotImplemented   deriving (Eq, Show, Exception)
src/Simplex/Messaging/Agent/Store/SQLite.hs view
@@ -23,6 +23,7 @@     withConnection,     withTransaction,     fromTextField_,+    firstRow,   ) where @@ -32,11 +33,13 @@ import Control.Monad.Except import Control.Monad.IO.Unlift (MonadUnliftIO) import Crypto.Random (ChaChaDRG, randomBytesGenerate)+import Data.Bifunctor (second) import Data.ByteString (ByteString)-import Data.ByteString.Base64 (encode)+import qualified Data.ByteString.Base64.URL as U import Data.Char (toLower)-import Data.List (find)-import Data.Maybe (fromMaybe)+import Data.Functor (($>))+import Data.List (find, foldl')+import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1)@@ -47,11 +50,14 @@ import Database.SQLite.Simple.Ok (Ok (Ok)) import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.ToField (ToField (..))-import Network.Socket (ServiceName) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations+import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)+import Simplex.Messaging.Encoding+import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (blobFieldParser) import Simplex.Messaging.Protocol (MsgBody) import qualified Simplex.Messaging.Protocol as SMP@@ -60,7 +66,6 @@ import System.Exit (exitFailure) import System.FilePath (takeDirectory) import System.IO (hFlush, stdout)-import Text.Read (readMaybe) import qualified UnliftIO.Exception as E  -- * SQLite Store implementation@@ -150,56 +155,50 @@             loop (t * 9 `div` 8) (tLim - t) db           else E.throwIO e +createConn_ ::+  (MonadUnliftIO m, MonadError StoreError m) =>+  SQLiteStore ->+  TVar ChaChaDRG ->+  ConnData ->+  (DB.Connection -> ByteString -> IO ()) ->+  m ByteString+createConn_ st gVar cData create =+  liftIOEither . checkConstraint SEConnDuplicate . withTransaction st $ \db ->+    case cData of+      ConnData {connId = ""} -> createWithRandomId gVar $ create db+      ConnData {connId} -> create db connId $> Right connId+ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where   createRcvConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId   createRcvConn st gVar cData q@RcvQueue {server} cMode =-    -- TODO if schema has to be restarted, this function can be refactored-    -- to create connection first using createWithRandomId-    liftIOEither . checkConstraint SEConnDuplicate . withTransaction st $ \db ->-      getConnId_ db gVar cData >>= traverse (create db)-    where-      create :: DB.Connection -> ConnId -> IO ConnId-      create db connId = do-        upsertServer_ db server-        insertRcvQueue_ db connId q-        insertRcvConnection_ db cData {connId} q cMode-        pure connId+    createConn_ st gVar cData $ \db connId -> do+      upsertServer_ db server+      DB.execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, cMode)+      insertRcvQueue_ db connId q    createSndConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId   createSndConn st gVar cData q@SndQueue {server} =-    -- TODO if schema has to be restarted, this function can be refactored-    -- to create connection first using createWithRandomId-    liftIOEither . checkConstraint SEConnDuplicate . withTransaction st $ \db ->-      getConnId_ db gVar cData >>= traverse (create db)-    where-      create :: DB.Connection -> ConnId -> IO ConnId-      create db connId = do-        upsertServer_ db server-        insertSndQueue_ db connId q-        insertSndConnection_ db cData {connId} q-        pure connId+    createConn_ st gVar cData $ \db connId -> do+      upsertServer_ db server+      DB.execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, SCMInvitation)+      insertSndQueue_ db connId q    getConn :: SQLiteStore -> ConnId -> m SomeConn   getConn st connId =     liftIOEither . withTransaction st $ \db ->       getConn_ db connId -  getAllConnIds :: SQLiteStore -> m [ConnId]-  getAllConnIds st =-    liftIO . withTransaction st $ \db ->-      concat <$> (DB.query_ db "SELECT conn_alias FROM connections;" :: IO [[ConnId]])-   getRcvConn :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m SomeConn   getRcvConn st SMPServer {host, port} rcvId =     liftIOEither . withTransaction st $ \db ->       DB.queryNamed         db         [sql|-          SELECT q.conn_alias+          SELECT q.conn_id           FROM rcv_queues q           WHERE q.host = :host AND q.port = :port AND q.rcv_id = :rcv_id;         |]-        [":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId]+        [":host" := host, ":port" := port, ":rcv_id" := rcvId]         >>= \case           [Only connId] -> getConn_ db connId           _ -> pure $ Left SEConnNotFound@@ -209,8 +208,8 @@     liftIO . withTransaction st $ \db ->       DB.executeNamed         db-        "DELETE FROM connections WHERE conn_alias = :conn_alias;"-        [":conn_alias" := connId]+        "DELETE FROM connections WHERE conn_id = :conn_id;"+        [":conn_id" := connId]    upgradeRcvConnToDuplex :: SQLiteStore -> ConnId -> SndQueue -> m ()   upgradeRcvConnToDuplex st connId sq@SndQueue {server} =@@ -219,7 +218,6 @@         Right (SomeConn _ RcvConnection {}) -> do           upsertServer_ db server           insertSndQueue_ db connId sq-          updateConnWithSndQueue_ db connId sq           pure $ Right ()         Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c         _ -> pure $ Left SEConnNotFound@@ -231,7 +229,6 @@         Right (SomeConn _ SndConnection {}) -> do           upsertServer_ db server           insertRcvQueue_ db connId rq-          updateConnWithRcvQueue_ db connId rq           pure $ Right ()         Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c         _ -> pure $ Left SEConnNotFound@@ -247,23 +244,23 @@           SET status = :status           WHERE host = :host AND port = :port AND rcv_id = :rcv_id;         |]-        [":status" := status, ":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId]+        [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId] -  setRcvQueueActive :: SQLiteStore -> RcvQueue -> VerificationKey -> m ()-  setRcvQueueActive st RcvQueue {rcvId, server = SMPServer {host, port}} verifyKey =-    -- ? throw error if queue does not exist?+  setRcvQueueConfirmedE2E :: SQLiteStore -> RcvQueue -> C.DhSecretX25519 -> m ()+  setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = SMPServer {host, port}} e2eDhSecret =     liftIO . withTransaction st $ \db ->       DB.executeNamed         db         [sql|           UPDATE rcv_queues-          SET verify_key = :verify_key, status = :status-          WHERE host = :host AND port = :port AND rcv_id = :rcv_id;+          SET e2e_dh_secret = :e2e_dh_secret,+              status = :status+          WHERE host = :host AND port = :port AND rcv_id = :rcv_id         |]-        [ ":verify_key" := Just verifyKey,-          ":status" := Active,+        [ ":status" := Confirmed,+          ":e2e_dh_secret" := e2eDhSecret,           ":host" := host,-          ":port" := serializePort_ port,+          ":port" := port,           ":rcv_id" := rcvId         ] @@ -278,31 +275,19 @@           SET status = :status           WHERE host = :host AND port = :port AND snd_id = :snd_id;         |]-        [":status" := status, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId]--  updateSignKey :: SQLiteStore -> SndQueue -> SignatureKey -> m ()-  updateSignKey st SndQueue {sndId, server = SMPServer {host, port}} signatureKey =-    liftIO . withTransaction st $ \db ->-      DB.executeNamed-        db-        [sql|-          UPDATE snd_queues-          SET sign_key = :sign_key-          WHERE host = :host AND port = :port AND snd_id = :snd_id;-        |]-        [":sign_key" := signatureKey, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId]+        [":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId]    createConfirmation :: SQLiteStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId-  createConfirmation st gVar NewConfirmation {connId, senderKey, senderConnInfo} =+  createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}, ratchetState} =     liftIOEither . withTransaction st $ \db ->       createWithRandomId gVar $ \confirmationId ->         DB.execute           db           [sql|             INSERT INTO conn_confirmations-            (confirmation_id, conn_alias, sender_key, sender_conn_info, accepted) VALUES (?, ?, ?, ?, 0);+            (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, accepted) VALUES (?, ?, ?, ?, ?, ?, 0);           |]-          (confirmationId, connId, senderKey, senderConnInfo)+          (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo)    acceptConfirmation :: SQLiteStore -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation   acceptConfirmation st confirmationId ownConnInfo =@@ -318,36 +303,46 @@         [ ":own_conn_info" := ownConnInfo,           ":confirmation_id" := confirmationId         ]-      confirmation-        <$> DB.query+      firstRow confirmation SEConfirmationNotFound $+        DB.query           db           [sql|-            SELECT conn_alias, sender_key, sender_conn_info+            SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info             FROM conn_confirmations             WHERE confirmation_id = ?;           |]           (Only confirmationId)     where-      confirmation [(connId, senderKey, senderConnInfo)] =-        Right $ AcceptedConfirmation {confirmationId, connId, senderKey, senderConnInfo, ownConnInfo}-      confirmation _ = Left SEConfirmationNotFound+      confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo) =+        AcceptedConfirmation+          { confirmationId,+            connId,+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},+            ratchetState,+            ownConnInfo+          }    getAcceptedConfirmation :: SQLiteStore -> ConnId -> m AcceptedConfirmation   getAcceptedConfirmation st connId =     liftIOEither . withTransaction st $ \db ->-      confirmation-        <$> DB.query+      firstRow confirmation SEConfirmationNotFound $+        DB.query           db           [sql|-            SELECT confirmation_id, sender_key, sender_conn_info, own_conn_info+            SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, own_conn_info             FROM conn_confirmations-            WHERE conn_alias = ? AND accepted = 1;+            WHERE conn_id = ? AND accepted = 1;           |]           (Only connId)     where-      confirmation [(confirmationId, senderKey, senderConnInfo, ownConnInfo)] =-        Right $ AcceptedConfirmation {confirmationId, connId, senderKey, senderConnInfo, ownConnInfo}-      confirmation _ = Left SEConfirmationNotFound+      confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, ownConnInfo) =+        AcceptedConfirmation+          { confirmationId,+            connId,+            senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},+            ratchetState,+            ownConnInfo+          }    removeConfirmations :: SQLiteStore -> ConnId -> m ()   removeConfirmations st connId =@@ -356,9 +351,9 @@         db         [sql|           DELETE FROM conn_confirmations-          WHERE conn_alias = :conn_alias;+          WHERE conn_id = :conn_id;         |]-        [":conn_alias" := connId]+        [":conn_id" := connId]    createInvitation :: SQLiteStore -> TVar ChaChaDRG -> NewInvitation -> m InvitationId   createInvitation st gVar NewInvitation {contactConnId, connReq, recipientConnInfo} =@@ -375,8 +370,8 @@   getInvitation :: SQLiteStore -> InvitationId -> m Invitation   getInvitation st invitationId =     liftIOEither . withTransaction st $ \db ->-      invitation-        <$> DB.query+      firstRow invitation SEInvitationNotFound $+        DB.query           db           [sql|             SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted@@ -386,9 +381,8 @@           |]           (Only invitationId)     where-      invitation [(contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted)] =-        Right Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}-      invitation _ = Left SEInvitationNotFound+      invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted) =+        Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}    acceptInvitation :: SQLiteStore -> InvitationId -> ConnInfo -> m ()   acceptInvitation st invitationId ownConnInfo =@@ -446,47 +440,28 @@       insertSndMsgDetails_ db connId sndMsgData       updateHashSnd_ db connId sndMsgData -  updateSndMsgStatus :: SQLiteStore -> ConnId -> InternalId -> SndMsgStatus -> m ()-  updateSndMsgStatus st connId msgId msgStatus =-    liftIO . withTransaction st $ \db ->-      DB.executeNamed-        db-        [sql|-          UPDATE snd_messages-          SET snd_status = :snd_status-          WHERE conn_alias = :conn_alias AND internal_id = :internal_id-        |]-        [ ":conn_alias" := connId,-          ":internal_id" := msgId,-          ":snd_status" := msgStatus-        ]--  getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m MsgBody+  getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody))   getPendingMsgData st connId msgId =-    liftIOEither . withTransaction st $ \db ->-      sndMsgData-        <$> DB.query-          db-          [sql|-            SELECT m.msg_body-            FROM messages m-            JOIN snd_messages s ON s.conn_alias = m.conn_alias AND s.internal_id = m.internal_id-            WHERE m.conn_alias = ? AND m.internal_id = ?-          |]-          (connId, msgId)-    where-      sndMsgData :: [Only MsgBody] -> Either StoreError MsgBody-      sndMsgData [Only msgBody] = Right msgBody-      sndMsgData _ = Left SEMsgNotFound+    liftIOEither . withTransaction st $ \db -> runExceptT $ do+      rq_ <- liftIO $ getRcvQueueByConnId_ db connId+      msgData <-+        ExceptT . firstRow id SEMsgNotFound $+          DB.query+            db+            [sql|+                SELECT m.msg_type, m.msg_body+                FROM messages m+                JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id+                WHERE m.conn_id = ? AND m.internal_id = ?+              |]+            (connId, msgId)+      pure (rq_, msgData)    getPendingMsgs :: SQLiteStore -> ConnId -> m [InternalId]   getPendingMsgs st connId =     liftIO . withTransaction st $ \db ->       map fromOnly-        <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_alias = ? AND snd_status = ?" (connId, SndMsgCreated)--  getMsg :: SQLiteStore -> ConnId -> InternalId -> m Msg-  getMsg _st _connId _id = throwError SENotImplemented+        <$> DB.query db "SELECT internal_id FROM snd_messages WHERE conn_id = ?" (Only connId)    checkRcvMsg :: SQLiteStore -> ConnId -> InternalId -> m ()   checkRcvMsg st connId msgId =@@ -495,41 +470,89 @@         <$> DB.query           db           [sql|-            SELECT conn_alias, internal_id+            SELECT conn_id, internal_id             FROM rcv_messages-            WHERE conn_alias = ? AND internal_id = ?+            WHERE conn_id = ? AND internal_id = ?           |]           (connId, msgId)     where       hasMsg :: [(ConnId, InternalId)] -> Either StoreError ()       hasMsg r = if null r then Left SEMsgNotFound else Right () -  updateRcvMsgAck :: SQLiteStore -> ConnId -> InternalId -> m ()-  updateRcvMsgAck st connId msgId =+  deleteMsg :: SQLiteStore -> ConnId -> InternalId -> m ()+  deleteMsg st connId msgId =+    liftIO . withTransaction st $ \db ->+      DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)++  createRatchetX3dhKeys :: SQLiteStore -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> m ()+  createRatchetX3dhKeys st connId x3dhPrivKey1 x3dhPrivKey2 =+    liftIO . withTransaction st $ \db ->+      DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)++  getRatchetX3dhKeys :: SQLiteStore -> ConnId -> m (C.PrivateKeyX448, C.PrivateKeyX448)+  getRatchetX3dhKeys st connId =+    liftIOEither . withTransaction st $ \db ->+      fmap hasKeys $+        firstRow id SEX3dhKeysNotFound $+          DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)+    where+      hasKeys = \case+        Right (Just k1, Just k2) -> Right (k1, k2)+        _ -> Left SEX3dhKeysNotFound++  createRatchet :: SQLiteStore -> ConnId -> RatchetX448 -> m ()+  createRatchet st connId rc =     liftIO . withTransaction st $ \db -> do-      DB.execute+      DB.executeNamed         db         [sql|-          UPDATE rcv_messages-          SET rcv_status = ?, ack_brocker_ts = datetime('now')-          WHERE conn_alias = ? AND internal_id = ?+          INSERT INTO ratchets (conn_id, ratchet_state)+          VALUES (:conn_id, :ratchet_state)+          ON CONFLICT (conn_id) DO UPDATE SET+            ratchet_state = :ratchet_state,+            x3dh_priv_key_1 = NULL,+            x3dh_priv_key_2 = NULL         |]-        (AcknowledgedToBroker, connId, msgId)+        [":conn_id" := connId, ":ratchet_state" := rc] --- * Auxiliary helpers+  getRatchet :: SQLiteStore -> ConnId -> m RatchetX448+  getRatchet st connId =+    liftIOEither . withTransaction st $ \db ->+      ratchet+        <$> DB.query db "SELECT ratchet_state FROM ratchets WHERE conn_id = ?" (Only connId)+    where+      ratchet (Only (Just rc) : _) = Right rc+      ratchet _ = Left SERatchetNotFound --- ? replace with ToField? - it's easy to forget to use this-serializePort_ :: Maybe ServiceName -> ServiceName-serializePort_ = fromMaybe "_"+  getSkippedMsgKeys :: SQLiteStore -> ConnId -> m SkippedMsgKeys+  getSkippedMsgKeys st connId =+    liftIO . withTransaction st $ \db ->+      skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId)+    where+      skipped ms = foldl' addSkippedKey M.empty ms+      addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks+        where+          addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk) -deserializePort_ :: ServiceName -> Maybe ServiceName-deserializePort_ "_" = Nothing-deserializePort_ port = Just port+  updateRatchet :: SQLiteStore -> ConnId -> RatchetX448 -> SkippedMsgDiff -> m ()+  updateRatchet st connId rc skipped =+    liftIO . withTransaction st $ \db -> do+      DB.execute db "UPDATE ratchets SET ratchet_state = ? WHERE conn_id = ?" (rc, connId)+      case skipped of+        SMDNoChange -> pure ()+        SMDRemove hk msgN ->+          DB.execute db "DELETE FROM skipped_messages WHERE conn_id = ? AND header_key = ? AND msg_n = ?" (connId, hk, msgN)+        SMDAdd smks ->+          forM_ (M.assocs smks) $ \(hk, mks) ->+            forM_ (M.assocs mks) $ \(msgN, mk) ->+              DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk) -instance ToField QueueStatus where toField = toField . show+-- * Auxiliary helpers -instance FromField QueueStatus where fromField = fromTextField_ $ readMaybe . T.unpack+instance ToField QueueStatus where toField = toField . serializeQueueStatus +instance FromField QueueStatus where fromField = fromTextField_ queueStatusT+ instance ToField InternalRcvId where toField (InternalRcvId x) = toField x  instance FromField InternalRcvId where fromField x = InternalRcvId <$> fromField x@@ -542,27 +565,27 @@  instance FromField InternalId where fromField x = InternalId <$> fromField x -instance ToField RcvMsgStatus where toField = toField . show+instance ToField AMsgType where toField = toField . smpEncode -instance ToField SndMsgStatus where toField = toField . show+instance FromField AMsgType where fromField = blobFieldParser smpP  instance ToField MsgIntegrity where toField = toField . serializeMsgIntegrity  instance FromField MsgIntegrity where fromField = blobFieldParser msgIntegrityP -instance ToField SMPQueueUri where toField = toField . serializeSMPQueueUri+instance ToField SMPQueueUri where toField = toField . strEncode -instance FromField SMPQueueUri where fromField = blobFieldParser smpQueueUriP+instance FromField SMPQueueUri where fromField = blobFieldParser strP -instance ToField AConnectionRequest where toField = toField . serializeConnReq+instance ToField AConnectionRequestUri where toField = toField . strEncode -instance FromField AConnectionRequest where fromField = blobFieldParser connReqP+instance FromField AConnectionRequestUri where fromField = blobFieldParser strP -instance ToField (ConnectionRequest c) where toField = toField . serializeConnReq'+instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . strEncode -instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequest c) where fromField = blobFieldParser connReqP'+instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldParser strP -instance ToField ConnectionMode where toField = toField . decodeLatin1 . serializeConnMode'+instance ToField ConnectionMode where toField = toField . decodeLatin1 . strEncode  instance FromField ConnectionMode where fromField = fromTextField_ connModeT @@ -578,6 +601,13 @@       _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t)   f -> returnError ConversionFailed f "expecting SQLText column type" +listToEither :: e -> [a] -> Either e a+listToEither _ (x : _) = Right x+listToEither e _ = Left e++firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b)+firstRow f e a = second f . listToEither e <$> a+ {- ORMOLU_DISABLE -} -- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries instance (FromField a, FromField b, FromField c, FromField d, FromField e,@@ -603,13 +633,13 @@     [ toField a, toField b, toField c, toField d, toField e, toField f,       toField g, toField h, toField i, toField j, toField k, toField l     ]+ {- ORMOLU_ENABLE -}  -- * Server upsert helper  upsertServer_ :: DB.Connection -> SMPServer -> IO () upsertServer_ dbConn SMPServer {host, port, keyHash} = do-  let port_ = serializePort_ port   DB.executeNamed     dbConn     [sql|@@ -619,92 +649,53 @@         port=excluded.port,         key_hash=excluded.key_hash;     |]-    [":host" := host, ":port" := port_, ":key_hash" := keyHash]+    [":host" := host, ":port" := port, ":key_hash" := keyHash]  -- * createRcvConn helpers  insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO () insertRcvQueue_ dbConn connId RcvQueue {..} = do-  let port_ = serializePort_ $ port server   DB.executeNamed     dbConn     [sql|       INSERT INTO rcv_queues-        ( host, port, rcv_id, conn_alias, rcv_private_key, snd_id, decrypt_key, verify_key, status)+        ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status)       VALUES-        (:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:snd_id,:decrypt_key,:verify_key,:status);+        (:host,:port,:rcv_id,:conn_id,:rcv_private_key,:rcv_dh_secret,:e2e_priv_key,:e2e_dh_secret,:snd_id,:status);     |]     [ ":host" := host server,-      ":port" := port_,+      ":port" := port server,       ":rcv_id" := rcvId,-      ":conn_alias" := connId,+      ":conn_id" := connId,       ":rcv_private_key" := rcvPrivateKey,+      ":rcv_dh_secret" := rcvDhSecret,+      ":e2e_priv_key" := e2ePrivKey,+      ":e2e_dh_secret" := e2eDhSecret,       ":snd_id" := sndId,-      ":decrypt_key" := decryptKey,-      ":verify_key" := verifyKey,       ":status" := status     ] -insertRcvConnection_ :: DB.Connection -> ConnData -> RcvQueue -> SConnectionMode c -> IO ()-insertRcvConnection_ dbConn ConnData {connId} RcvQueue {server, rcvId} cMode = do-  let port_ = serializePort_ $ port server-  DB.executeNamed-    dbConn-    [sql|-      INSERT INTO connections-        ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id, last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id, last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash,-          conn_mode )-      VALUES-        (:conn_alias,:rcv_host,:rcv_port,:rcv_id, NULL,     NULL,     NULL, 0, 0, 0, 0, x'', x'',-         :conn_mode );-    |]-    [ ":conn_alias" := connId,-      ":rcv_host" := host server,-      ":rcv_port" := port_,-      ":rcv_id" := rcvId,-      ":conn_mode" := cMode-    ]- -- * createSndConn helpers  insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO () insertSndQueue_ dbConn connId SndQueue {..} = do-  let port_ = serializePort_ $ port server   DB.executeNamed     dbConn     [sql|       INSERT INTO snd_queues-        ( host, port, snd_id, conn_alias, snd_private_key, encrypt_key, sign_key, status)+        ( host, port, snd_id, conn_id, snd_private_key, e2e_dh_secret, status)       VALUES-        (:host,:port,:snd_id,:conn_alias,:snd_private_key,:encrypt_key,:sign_key,:status);+        (:host,:port,:snd_id,:conn_id,:snd_private_key,:e2e_dh_secret,:status);     |]     [ ":host" := host server,-      ":port" := port_,+      ":port" := port server,       ":snd_id" := sndId,-      ":conn_alias" := connId,+      ":conn_id" := connId,       ":snd_private_key" := sndPrivateKey,-      ":encrypt_key" := encryptKey,-      ":sign_key" := signKey,+      ":e2e_dh_secret" := e2eDhSecret,       ":status" := status     ] -insertSndConnection_ :: DB.Connection -> ConnData -> SndQueue -> IO ()-insertSndConnection_ dbConn ConnData {connId} SndQueue {server, sndId} = do-  let port_ = serializePort_ $ port server-  DB.executeNamed-    dbConn-    [sql|-      INSERT INTO connections-        ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id, last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id, last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash)-      VALUES-        (:conn_alias, NULL,     NULL,     NULL,  :snd_host,:snd_port,:snd_id, 0, 0, 0, 0, x'', x'');-    |]-    [ ":conn_alias" := connId,-      ":snd_host" := host server,-      ":snd_port" := port_,-      ":snd_id" := sndId-    ]- -- * getConn helpers  getConn_ :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)@@ -712,8 +703,8 @@   getConnData_ dbConn connId >>= \case     Nothing -> pure $ Left SEConnNotFound     Just (connData, cMode) -> do-      rQ <- getRcvQueueByConnAlias_ dbConn connId-      sQ <- getSndQueueByConnAlias_ dbConn connId+      rQ <- getRcvQueueByConnId_ dbConn connId+      sQ <- getSndQueueByConnId_ dbConn connId       pure $ case (rQ, sQ, cMode) of         (Just rcvQ, Just sndQ, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection connData rcvQ sndQ)         (Just rcvQ, Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection connData rcvQ)@@ -724,76 +715,48 @@ getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode)) getConnData_ dbConn connId' =   connData-    <$> DB.query dbConn "SELECT conn_alias, conn_mode FROM connections WHERE conn_alias = ?;" (Only connId')+    <$> DB.query dbConn "SELECT conn_id, conn_mode FROM connections WHERE conn_id = ?;" (Only connId')   where     connData [(connId, cMode)] = Just (ConnData {connId}, cMode)     connData _ = Nothing -getRcvQueueByConnAlias_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)-getRcvQueueByConnAlias_ dbConn connId =+getRcvQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)+getRcvQueueByConnId_ dbConn connId =   rcvQueue     <$> DB.query       dbConn       [sql|-        SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key,-          q.snd_id, q.decrypt_key, q.verify_key, q.status+        SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,+          q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status         FROM rcv_queues q         INNER JOIN servers s ON q.host = s.host AND q.port = s.port-        WHERE q.conn_alias = ?;+        WHERE q.conn_id = ?;       |]       (Only connId)   where-    rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, sndId, decryptKey, verifyKey, status)] =-      let srv = SMPServer host (deserializePort_ port) keyHash-       in Just $ RcvQueue srv rcvId rcvPrivateKey sndId decryptKey verifyKey status+    rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)] =+      let server = SMPServer host port keyHash+       in Just RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status}     rcvQueue _ = Nothing -getSndQueueByConnAlias_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)-getSndQueueByConnAlias_ dbConn connId =+getSndQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)+getSndQueueByConnId_ dbConn connId =   sndQueue     <$> DB.query       dbConn       [sql|-        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.encrypt_key, q.sign_key, q.status+        SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.e2e_dh_secret, q.status         FROM snd_queues q         INNER JOIN servers s ON q.host = s.host AND q.port = s.port-        WHERE q.conn_alias = ?;+        WHERE q.conn_id = ?;       |]       (Only connId)   where-    sndQueue [(keyHash, host, port, sndId, sndPrivateKey, encryptKey, signKey, status)] =-      let srv = SMPServer host (deserializePort_ port) keyHash-       in Just $ SndQueue srv sndId sndPrivateKey encryptKey signKey status+    sndQueue [(keyHash, host, port, sndId, sndPrivateKey, e2eDhSecret, status)] =+      let server = SMPServer host port keyHash+       in Just SndQueue {server, sndId, sndPrivateKey, e2eDhSecret, status}     sndQueue _ = Nothing --- * upgradeRcvConnToDuplex helpers--updateConnWithSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO ()-updateConnWithSndQueue_ dbConn connId SndQueue {server, sndId} = do-  let port_ = serializePort_ $ port server-  DB.executeNamed-    dbConn-    [sql|-      UPDATE connections-      SET snd_host = :snd_host, snd_port = :snd_port, snd_id = :snd_id-      WHERE conn_alias = :conn_alias;-    |]-    [":snd_host" := host server, ":snd_port" := port_, ":snd_id" := sndId, ":conn_alias" := connId]---- * upgradeSndConnToDuplex helpers--updateConnWithRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()-updateConnWithRcvQueue_ dbConn connId RcvQueue {server, rcvId} = do-  let port_ = serializePort_ $ port server-  DB.executeNamed-    dbConn-    [sql|-      UPDATE connections-      SET rcv_host = :rcv_host, rcv_port = :rcv_port, rcv_id = :rcv_id-      WHERE conn_alias = :conn_alias;-    |]-    [":rcv_host" := host server, ":rcv_port" := port_, ":rcv_id" := rcvId, ":conn_alias" := connId]- -- * updateRcvIds helpers  retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)@@ -804,9 +767,9 @@       [sql|         SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash         FROM connections-        WHERE conn_alias = :conn_alias;+        WHERE conn_id = :conn_id;       |]-      [":conn_alias" := connId]+      [":conn_id" := connId]   return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)  updateLastIdsRcv_ :: DB.Connection -> ConnId -> InternalId -> InternalRcvId -> IO ()@@ -817,56 +780,55 @@       UPDATE connections       SET last_internal_msg_id = :last_internal_msg_id,           last_internal_rcv_msg_id = :last_internal_rcv_msg_id-      WHERE conn_alias = :conn_alias;+      WHERE conn_id = :conn_id;     |]     [ ":last_internal_msg_id" := newInternalId,       ":last_internal_rcv_msg_id" := newInternalRcvId,-      ":conn_alias" := connId+      ":conn_id" := connId     ]  -- * createRcvMsg helpers  insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()-insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgBody, internalRcvId} = do+insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgBody, internalRcvId} = do   let MsgMeta {recipient = (internalId, internalTs)} = msgMeta   DB.executeNamed     dbConn     [sql|       INSERT INTO messages-        ( conn_alias, internal_id, internal_ts, internal_rcv_id, internal_snd_id, body, msg_body)+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)       VALUES-        (:conn_alias,:internal_id,:internal_ts,:internal_rcv_id,            NULL,   '',:msg_body);+        (:conn_id,:internal_id,:internal_ts,:internal_rcv_id,            NULL,:msg_type, :msg_body);     |]-    [ ":conn_alias" := connId,+    [ ":conn_id" := connId,       ":internal_id" := internalId,       ":internal_ts" := internalTs,       ":internal_rcv_id" := internalRcvId,+      ":msg_type" := msgType,       ":msg_body" := msgBody     ]  insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvMsgData -> IO () insertRcvMsgDetails_ dbConn connId RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash} = do-  let MsgMeta {integrity, recipient, sender, broker} = msgMeta+  let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta   DB.executeNamed     dbConn     [sql|       INSERT INTO rcv_messages-        ( conn_alias, internal_rcv_id, internal_id, external_snd_id, external_snd_ts,-          broker_id, broker_ts, rcv_status, ack_brocker_ts, ack_sender_ts,+        ( conn_id, internal_rcv_id, internal_id, external_snd_id,+          broker_id, broker_ts,           internal_hash, external_prev_snd_hash, integrity)       VALUES-        (:conn_alias,:internal_rcv_id,:internal_id,:external_snd_id,:external_snd_ts,-         :broker_id,:broker_ts,:rcv_status,           NULL,          NULL,+        (:conn_id,:internal_rcv_id,:internal_id,:external_snd_id,+         :broker_id,:broker_ts,          :internal_hash,:external_prev_snd_hash,:integrity);     |]-    [ ":conn_alias" := connId,+    [ ":conn_id" := connId,       ":internal_rcv_id" := internalRcvId,       ":internal_id" := fst recipient,-      ":external_snd_id" := fst sender,-      ":external_snd_ts" := snd sender,+      ":external_snd_id" := sndMsgId,       ":broker_id" := fst broker,       ":broker_ts" := snd broker,-      ":rcv_status" := Received,       ":internal_hash" := internalHash,       ":external_prev_snd_hash" := externalPrevSndHash,       ":integrity" := integrity@@ -881,12 +843,12 @@       UPDATE connections       SET last_external_snd_msg_id = :last_external_snd_msg_id,           last_rcv_msg_hash = :last_rcv_msg_hash-      WHERE conn_alias = :conn_alias+      WHERE conn_id = :conn_id         AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id;     |]-    [ ":last_external_snd_msg_id" := fst (sender msgMeta),+    [ ":last_external_snd_msg_id" := sndMsgId (msgMeta :: MsgMeta),       ":last_rcv_msg_hash" := internalHash,-      ":conn_alias" := connId,+      ":conn_id" := connId,       ":last_internal_rcv_msg_id" := internalRcvId     ] @@ -900,9 +862,9 @@       [sql|         SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash         FROM connections-        WHERE conn_alias = :conn_alias;+        WHERE conn_id = :conn_id;       |]-      [":conn_alias" := connId]+      [":conn_id" := connId]   return (lastInternalId, lastInternalSndId, lastSndHash)  updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO ()@@ -913,11 +875,11 @@       UPDATE connections       SET last_internal_msg_id = :last_internal_msg_id,           last_internal_snd_msg_id = :last_internal_snd_msg_id-      WHERE conn_alias = :conn_alias;+      WHERE conn_id = :conn_id;     |]     [ ":last_internal_msg_id" := newInternalId,       ":last_internal_snd_msg_id" := newInternalSndId,-      ":conn_alias" := connId+      ":conn_id" := connId     ]  -- * createSndMsg helpers@@ -928,14 +890,15 @@     dbConn     [sql|       INSERT INTO messages-        ( conn_alias, internal_id, internal_ts, internal_rcv_id, internal_snd_id, body, msg_body)+        ( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_body)       VALUES-        (:conn_alias,:internal_id,:internal_ts,            NULL,:internal_snd_id,   '',:msg_body);+        (:conn_id,:internal_id,:internal_ts,            NULL,:internal_snd_id,:msg_type, :msg_body);     |]-    [ ":conn_alias" := connId,+    [ ":conn_id" := connId,       ":internal_id" := internalId,       ":internal_ts" := internalTs,       ":internal_snd_id" := internalSndId,+      ":msg_type" := msgType,       ":msg_body" := msgBody     ] @@ -945,16 +908,15 @@     dbConn     [sql|       INSERT INTO snd_messages-        ( conn_alias, internal_snd_id, internal_id, snd_status, sent_ts, delivered_ts, internal_hash, previous_msg_hash)+        ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash)       VALUES-        (:conn_alias,:internal_snd_id,:internal_id,:snd_status,    NULL,         NULL,:internal_hash,:previous_msg_hash);+        (:conn_id,:internal_snd_id,:internal_id,:internal_hash,:previous_msg_hash);     |]-    [ ":conn_alias" := connId,+    [ ":conn_id" := connId,       ":internal_snd_id" := internalSndId,       ":internal_id" := internalId,-      ":snd_status" := SndMsgCreated,       ":internal_hash" := internalHash,-      ":previous_msg_hash" := previousMsgHash+      ":previous_msg_hash" := prevMsgHash     ]  updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()@@ -965,31 +927,15 @@     [sql|       UPDATE connections       SET last_snd_msg_hash = :last_snd_msg_hash-      WHERE conn_alias = :conn_alias+      WHERE conn_id = :conn_id         AND last_internal_snd_msg_id = :last_internal_snd_msg_id;     |]     [ ":last_snd_msg_hash" := internalHash,-      ":conn_alias" := connId,+      ":conn_id" := connId,       ":last_internal_snd_msg_id" := internalSndId     ]  -- create record with a random ID--getConnId_ :: DB.Connection -> TVar ChaChaDRG -> ConnData -> IO (Either StoreError ConnId)-getConnId_ dbConn gVar ConnData {connId = ""} = getUniqueRandomId gVar $ getConnData_ dbConn-getConnId_ _ _ ConnData {connId} = pure $ Right connId--getUniqueRandomId :: TVar ChaChaDRG -> (ByteString -> IO (Maybe a)) -> IO (Either StoreError ByteString)-getUniqueRandomId gVar get = tryGet 3-  where-    tryGet :: Int -> IO (Either StoreError ByteString)-    tryGet 0 = pure $ Left SEUniqueID-    tryGet n = do-      id' <- randomId gVar 12-      get id' >>= \case-        Nothing -> pure $ Right id'-        Just _ -> tryGet (n - 1)- createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString) createWithRandomId gVar create = tryCreate 3   where@@ -1004,4 +950,4 @@           | otherwise -> pure . Left . SEInternal $ bshow e  randomId :: TVar ChaChaDRG -> Int -> IO ByteString-randomId gVar n = encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)+randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
src/Simplex/Messaging/Client.hs view
@@ -23,14 +23,16 @@ -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md module Simplex.Messaging.Client   ( -- * Connect (disconnect) client to (from) SMP server-    SMPClient (blockSize),+    SMPClient,     getSMPClient,     closeSMPClient,      -- * SMP protocol command functions     createSMPQueue,     subscribeSMPQueue,+    subscribeSMPQueueNotifications,     secureSMPQueue,+    enableSMPQueueNotifications,     sendSMPMessage,     ackSMPMessage,     suspendSMPQueue,@@ -59,10 +61,9 @@ import Data.Maybe (fromMaybe) import Network.Socket (ServiceName) import Numeric.Natural-import Simplex.Messaging.Agent.Protocol (SMPServer (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol-import Simplex.Messaging.Transport (ATransport (..), TCP, THandle (..), TProxy, Transport (..), TransportError, clientHandshake, runTransportClient)+import Simplex.Messaging.Transport (ATransport (..), THandle (..), TLS, TProxy, Transport (..), TransportError, clientHandshake, runTransportClient) import Simplex.Messaging.Transport.WebSockets (WS) import Simplex.Messaging.Util (bshow, liftError, raceAny_) import System.Timeout (timeout)@@ -76,18 +77,18 @@ data SMPClient = SMPClient   { action :: Async (),     connected :: TVar Bool,+    sessionId :: ByteString,     smpServer :: SMPServer,     tcpTimeout :: Int,     clientCorrId :: TVar Natural,     sentCommands :: TVar (Map CorrId Request),-    sndQ :: TBQueue SignedRawTransmission,-    rcvQ :: TBQueue SignedTransmissionOrError,-    msgQ :: TBQueue SMPServerTransmission,-    blockSize :: Int+    sndQ :: TBQueue SentRawTransmission,+    rcvQ :: TBQueue (SignedTransmission BrokerMsg),+    msgQ :: TBQueue SMPServerTransmission   }  -- | Type synonym for transmission from some SPM server queue.-type SMPServerTransmission = (SMPServer, RecipientId, Command 'Broker)+type SMPServerTransmission = (SMPServer, RecipientId, BrokerMsg)  -- | SMP client configuration. data SMPClientConfig = SMPClientConfig@@ -98,13 +99,7 @@     -- | timeout of TCP commands (microseconds)     tcpTimeout :: Int,     -- | period for SMP ping commands (microseconds)-    smpPing :: Int,-    -- | SMP transport block size, Nothing - the block size will be set by the server.-    -- Allowed sizes are 4, 8, 16, 32, 64 KiB (* 1024 bytes).-    smpBlockSize :: Maybe Int,-    -- | estimated maximum size of SMP command excluding message body,-    -- determines the maximum allowed message size-    smpCommandSize :: Int+    smpPing :: Int   }  -- | Default SMP client configuration.@@ -112,11 +107,9 @@ smpDefaultConfig =   SMPClientConfig     { qSize = 16,-      defaultTransport = ("5223", transport @TCP),+      defaultTransport = ("5223", transport @TLS),       tcpTimeout = 4_000_000,-      smpPing = 30_000_000,-      smpBlockSize = Just 8192,-      smpCommandSize = 256+      smpPing = 30_000_000     }  data Request = Request@@ -124,7 +117,7 @@     responseVar :: TMVar Response   } -type Response = Either SMPClientError Cmd+type Response = Either SMPClientError BrokerMsg  -- | Connects to 'SMPServer' using passed client configuration -- and queue for messages and notifications.@@ -132,7 +125,7 @@ -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)-getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlockSize} msgQ disconnected =+getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ disconnected =   atomically mkSMPClient >>= runClient useTransport   where     mkSMPClient :: STM SMPClient@@ -145,7 +138,7 @@       return         SMPClient           { action = undefined,-            blockSize = undefined,+            sessionId = undefined,             connected,             smpServer,             tcpTimeout,@@ -161,45 +154,46 @@       thVar <- newEmptyTMVarIO       action <-         async $-          runTransportClient (host smpServer) port' (client t c thVar)+          runTransportClient (host smpServer) port' (keyHash smpServer) (client t c thVar)             `finally` atomically (putTMVar thVar $ Left SMPNetworkError)-      bSize <- tcpTimeout `timeout` atomically (takeTMVar thVar)-      pure $ case bSize of-        Just (Right blockSize) -> Right c {action, blockSize}+      th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)+      pure $ case th_ of+        Just (Right THandle {sessionId}) -> Right c {action, sessionId}         Just (Left e) -> Left e         Nothing -> Left SMPNetworkError      useTransport :: (ServiceName, ATransport)     useTransport = case port smpServer of-      Nothing -> defaultTransport cfg-      Just "80" -> ("80", transport @WS)-      Just p -> (p, transport @TCP)+      "" -> defaultTransport cfg+      "80" -> ("80", transport @WS)+      p -> (p, transport @TLS) -    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()+    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError (THandle c)) -> c -> IO ()     client _ c thVar h =-      runExceptT (clientHandshake h smpBlockSize $ keyHash smpServer) >>= \case+      runExceptT (clientHandshake h $ keyHash smpServer) >>= \case         Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e-        Right th -> do+        Right th@THandle {sessionId} -> do           atomically $ do             writeTVar (connected c) True-            putTMVar thVar . Right $ blockSize (th :: THandle c)-          raceAny_ [send c th, process c, receive c th, ping c]+            putTMVar thVar $ Right th+          let c' = c {sessionId} :: SMPClient+          raceAny_ [send c' th, process c', receive c' th, ping c']             `finally` disconnected      send :: Transport c => SMPClient -> THandle c -> IO ()     send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h      receive :: Transport c => SMPClient -> THandle c -> IO ()-    receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ+    receive SMPClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ      ping :: SMPClient -> IO ()     ping c = forever $ do       threadDelay smpPing-      runExceptT $ sendSMPCommand c Nothing "" (Cmd SSender PING)+      runExceptT $ sendSMPCommand c Nothing "" PING      process :: SMPClient -> IO ()     process SMPClient {rcvQ, sentCommands} = forever $ do-      (_, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ+      (_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ       if B.null $ bs corrId         then sendMsg qId respOrErr         else do@@ -212,13 +206,13 @@                 if queueId == qId                   then case respOrErr of                     Left e -> Left $ SMPResponseError e-                    Right (Cmd _ (ERR e)) -> Left $ SMPServerError e+                    Right (ERR e) -> Left $ SMPServerError e                     Right r -> Right r                   else Left SMPUnexpectedResponse -    sendMsg :: QueueId -> Either ErrorType Cmd -> IO ()+    sendMsg :: QueueId -> Either ErrorType BrokerMsg -> IO ()     sendMsg qId = \case-      Right (Cmd SBroker cmd) -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd)+      Right cmd -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd)       -- TODO send everything else to errQ and log in agent       _ -> return () @@ -257,49 +251,64 @@ -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command createSMPQueue ::   SMPClient ->-  RecipientPrivateKey ->-  RecipientPublicKey ->-  ExceptT SMPClientError IO (RecipientId, SenderId)-createSMPQueue c rpKey rKey =-  -- TODO add signing this request too - requires changes in the server-  sendSMPCommand c (Just rpKey) "" (Cmd SRecipient $ NEW rKey) >>= \case-    Cmd _ (IDS rId sId) -> return (rId, sId)+  RcvPrivateSignKey ->+  RcvPublicVerifyKey ->+  RcvPublicDhKey ->+  ExceptT SMPClientError IO QueueIdsKeys+createSMPQueue c rpKey rKey dhKey =+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case+    IDS qik -> pure qik     _ -> throwE SMPUnexpectedResponse  -- | Subscribe to the SMP queue. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-subscribeSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> ExceptT SMPClientError IO ()+subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =-  sendSMPCommand c (Just rpKey) rId (Cmd SRecipient SUB) >>= \case-    Cmd _ OK -> return ()-    Cmd _ cmd@MSG {} ->+  sendSMPCommand c (Just rpKey) rId SUB >>= \case+    OK -> return ()+    cmd@MSG {} ->       lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)     _ -> throwE SMPUnexpectedResponse +-- | Subscribe to the SMP queue notifications.+--+-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications+subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()+subscribeSMPQueueNotifications = okSMPCommand NSUB+ -- | Secure the SMP queue by adding a sender public key. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command-secureSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> SenderPublicKey -> ExceptT SMPClientError IO ()-secureSMPQueue c rpKey rId senderKey = okSMPCommand (Cmd SRecipient $ KEY senderKey) c rpKey rId+secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()+secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId +-- | Enable notifications for the queue for push notifications server.+--+-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command+enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT SMPClientError IO NotifierId+enableSMPQueueNotifications c rpKey rId notifierKey =+  sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case+    NID nId -> pure nId+    _ -> throwE SMPUnexpectedResponse+ -- | Send SMP message. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message-sendSMPMessage :: SMPClient -> Maybe SenderPrivateKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()+sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO () sendSMPMessage c spKey sId msg =-  sendSMPCommand c spKey sId (Cmd SSender $ SEND msg) >>= \case-    Cmd _ OK -> return ()+  sendSMPCommand c spKey sId (SEND msg) >>= \case+    OK -> pure ()     _ -> throwE SMPUnexpectedResponse  -- | Acknowledge message delivery (server deletes the message). -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery-ackSMPMessage :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()+ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO () ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =-  sendSMPCommand c (Just rpKey) rId (Cmd SRecipient ACK) >>= \case-    Cmd _ OK -> return ()-    Cmd _ cmd@MSG {} ->+  sendSMPCommand c (Just rpKey) rId ACK >>= \case+    OK -> return ()+    cmd@MSG {} ->       lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)     _ -> throwE SMPUnexpectedResponse @@ -307,26 +316,27 @@ -- The existing messages from the queue will still be delivered. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue-suspendSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()-suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF+suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()+suspendSMPQueue = okSMPCommand OFF  -- | Irreversibly delete SMP queue and all messages in it. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue-deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()-deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL+deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()+deleteSMPQueue = okSMPCommand DEL -okSMPCommand :: Cmd -> SMPClient -> C.SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()+okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO () okSMPCommand cmd c pKey qId =   sendSMPCommand c (Just pKey) qId cmd >>= \case-    Cmd _ OK -> return ()+    OK -> return ()     _ -> throwE SMPUnexpectedResponse --- | Send any SMP command ('Cmd' type).-sendSMPCommand :: SMPClient -> Maybe C.SafePrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd-sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId cmd = do+-- | Send SMP command+-- TODO sign all requests (SEND of SMP confirmation would be signed with the same key that is passed to the recipient)+sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg+sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do   corrId <- lift_ getNextCorrId-  t <- signTransmission $ serializeTransmission (corrId, qId, cmd)+  t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd)   ExceptT $ sendRecv corrId t   where     lift_ :: STM a -> ExceptT SMPClientError IO a@@ -337,20 +347,20 @@       i <- stateTVar clientCorrId $ \i -> (i, i + 1)       pure . CorrId $ bshow i -    signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission+    signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission     signTransmission t = case pKey of-      Nothing -> return ("", t)+      Nothing -> return (Nothing, t)       Just pk -> do         sig <- liftError SMPSignatureError $ C.sign pk t-        return (sig, t)+        return (Just sig, t)      -- two separate "atomically" needed to avoid blocking-    sendRecv :: CorrId -> SignedRawTransmission -> IO Response+    sendRecv :: CorrId -> SentRawTransmission -> IO Response     sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar       where         withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a -    send :: CorrId -> SignedRawTransmission -> STM (TMVar Response)+    send :: CorrId -> SentRawTransmission -> STM (TMVar Response)     send corrId t = do       r <- newEmptyTMVar       modifyTVar sentCommands . M.insert corrId $ Request qId r
src/Simplex/Messaging/Crypto.hs view
@@ -1,522 +1,934 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module      : Simplex.Messaging.Crypto--- Copyright   : (c) simplex.chat--- License     : AGPL-3------ Maintainer  : chat@simplex.chat--- Stability   : experimental--- Portability : non-portable------ This module provides cryptography implementation for SMP protocols based on--- <https://hackage.haskell.org/package/cryptonite cryptonite package>.-module Simplex.Messaging.Crypto-  ( -- * RSA keys-    PrivateKey (rsaPrivateKey, publicKey),-    SafePrivateKey (..), -- constructor is not exported-    FullPrivateKey (..),-    APrivateKey (..),-    PublicKey (..),-    SafeKeyPair,-    FullKeyPair,-    KeyHash (..),-    generateKeyPair,-    publicKey',-    publicKeySize,-    validKeySize,-    safePrivateKey,-    removePublicKey,--    -- * E2E hybrid encryption scheme-    encrypt,-    decrypt,--    -- * RSA OAEP encryption-    encryptOAEP,-    decryptOAEP,--    -- * RSA PSS signing-    Signature (..),-    sign,-    verify,--    -- * AES256 AEAD-GCM scheme-    Key (..),-    IV (..),-    encryptAES,-    decryptAES,-    authTagSize,-    authTagToBS,-    bsToAuthTag,-    randomAesKey,-    randomIV,-    aesKeyP,-    ivP,--    -- * Encoding of RSA keys-    serializePrivKey,-    serializePubKey,-    serializePubKeyUri,-    encodePubKey,-    publicKeyHash,-    privKeyP,-    pubKeyP,-    pubKeyUriP,-    binaryPubKeyP,--    -- * SHA256 hash-    sha256Hash,--    -- * Cryptography error type-    CryptoError (..),-  )-where--import Control.Exception (Exception)-import Control.Monad.Except-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 (Digest, SHA256 (..), hash)-import Crypto.Number.Generate (generateMax)-import Crypto.Number.Prime (findPrimeFrom)-import qualified Crypto.PubKey.RSA as R-import qualified Crypto.PubKey.RSA.OAEP as OAEP-import qualified Crypto.PubKey.RSA.PSS as PSS-import Crypto.Random (getRandomBytes)-import Data.ASN1.BinaryEncoding-import Data.ASN1.Encoding-import Data.ASN1.Types-import Data.Attoparsec.ByteString.Char8 (Parser)-import qualified Data.Attoparsec.ByteString.Char8 as A-import Data.Bifunctor (bimap, first)-import qualified Data.ByteArray as BA-import Data.ByteString.Base64 (decode, encode)-import qualified Data.ByteString.Base64.URL as U-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.ByteString.Internal (c2w, w2c)-import Data.ByteString.Lazy (fromStrict, toStrict)-import Data.String-import Data.X509-import Database.SQLite.Simple.FromField (FromField (..))-import Database.SQLite.Simple.ToField (ToField (..))-import Network.Transport.Internal (decodeWord32, encodeWord32)-import Simplex.Messaging.Parsers (base64P, base64UriP, blobFieldParser, parseAll, parseString)-import Simplex.Messaging.Util (liftEitherError, (<$?>))---- | A newtype of 'Crypto.PubKey.RSA.PublicKey'.-newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show)---- | A newtype of 'Crypto.PubKey.RSA.PrivateKey', with PublicKey removed.------ It is not possible to recover PublicKey from SafePrivateKey.--- The constructor of this type is not exported.-newtype SafePrivateKey = SafePrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show)---- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (with PublicKey inside).-newtype FullPrivateKey = FullPrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show)---- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (PublicKey may be inside).-newtype APrivateKey = APrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show)---- | Type-class used for both private key types: SafePrivateKey and FullPrivateKey.-class PrivateKey k where-  -- unwraps 'Crypto.PubKey.RSA.PrivateKey'-  rsaPrivateKey :: k -> R.PrivateKey--  -- equivalent to data type constructor, not exported-  _privateKey :: R.PrivateKey -> k--  -- smart constructor removing public key from SafePrivateKey but keeping it in FullPrivateKey-  mkPrivateKey :: R.PrivateKey -> k--  -- extracts public key from private key-  publicKey :: k -> Maybe PublicKey---- | Remove public key exponent from APrivateKey.-removePublicKey :: APrivateKey -> APrivateKey-removePublicKey (APrivateKey R.PrivateKey {private_pub = k, private_d}) =-  APrivateKey $ unPrivateKey (safePrivateKey (R.public_size k, R.public_n k, private_d) :: SafePrivateKey)--instance PrivateKey SafePrivateKey where-  rsaPrivateKey = unPrivateKey-  _privateKey = SafePrivateKey-  mkPrivateKey R.PrivateKey {private_pub = k, private_d} =-    safePrivateKey (R.public_size k, R.public_n k, private_d)-  publicKey _ = Nothing--instance PrivateKey FullPrivateKey where-  rsaPrivateKey = unPrivateKey-  _privateKey = FullPrivateKey-  mkPrivateKey = FullPrivateKey-  publicKey = Just . PublicKey . R.private_pub . rsaPrivateKey--instance PrivateKey APrivateKey where-  rsaPrivateKey = unPrivateKey-  _privateKey = APrivateKey-  mkPrivateKey = APrivateKey-  publicKey pk =-    let k = R.private_pub $ rsaPrivateKey pk-     in if R.public_e k == 0-          then Nothing-          else Just $ PublicKey k--instance IsString FullPrivateKey where-  fromString = parseString $ decode >=> decodePrivKey--instance IsString PublicKey where-  fromString = parseString $ decode >=> decodePubKey--instance ToField SafePrivateKey where toField = toField . encodePrivKey--instance ToField APrivateKey where toField = toField . encodePrivKey--instance ToField PublicKey where toField = toField . encodePubKey--instance FromField SafePrivateKey where fromField = blobFieldParser binaryPrivKeyP--instance FromField APrivateKey where fromField = blobFieldParser binaryPrivKeyP--instance FromField PublicKey where fromField = blobFieldParser binaryPubKeyP---- | Tuple of RSA 'PublicKey' and 'PrivateKey'.-type KeyPair k = (PublicKey, k)---- | Tuple of RSA 'PublicKey' and 'SafePrivateKey'.-type SafeKeyPair = (PublicKey, SafePrivateKey)---- | Tuple of RSA 'PublicKey' and 'FullPrivateKey'.-type FullKeyPair = (PublicKey, FullPrivateKey)---- | RSA signature newtype.-newtype Signature = Signature {unSignature :: ByteString} deriving (Eq, Show)--instance IsString Signature where-  fromString = Signature . fromString---- | Various cryptographic or related errors.-data CryptoError-  = -- | RSA OAEP encryption error-    RSAEncryptError R.Error-  | -- | RSA OAEP decryption error-    RSADecryptError R.Error-  | -- | RSA PSS signature error-    RSASignError R.Error-  | -- | AES initialization error-    AESCipherError CE.CryptoError-  | -- | IV generation error-    CryptoIVError-  | -- | AES decryption error-    AESDecryptError-  | -- | message does not fit in SMP block-    CryptoLargeMsgError-  | -- | failure parsing RSA-encrypted message header-    CryptoHeaderError String-  deriving (Eq, Show, Exception)--pubExpRange :: Integer-pubExpRange = 2 ^ (1024 :: Int)--aesKeySize :: Int-aesKeySize = 256 `div` 8--authTagSize :: Int-authTagSize = 128 `div` 8---- | Generate RSA key pair with either SafePrivateKey or FullPrivateKey.-generateKeyPair :: PrivateKey k => Int -> IO (KeyPair k)-generateKeyPair size = loop-  where-    publicExponent = findPrimeFrom . (+ 3) <$> generateMax pubExpRange-    loop = do-      (k, pk) <- R.generate size =<< publicExponent-      let n = R.public_n k-          d = R.private_d pk-      if d * d < n-        then loop-        else pure (PublicKey k, mkPrivateKey pk)--privateKeySize :: PrivateKey k => k -> Int-privateKeySize = R.public_size . R.private_pub . rsaPrivateKey--publicKey' :: FullPrivateKey -> PublicKey-publicKey' = PublicKey . R.private_pub . rsaPrivateKey--publicKeySize :: PublicKey -> Int-publicKeySize = R.public_size . rsaPublicKey--validKeySize :: Int -> Bool-validKeySize = \case-  128 -> True-  256 -> True-  384 -> True-  512 -> True-  _ -> False--data Header = Header-  { aesKey :: Key,-    ivBytes :: IV,-    authTag :: AES.AuthTag,-    msgSize :: Int-  }---- | AES key newtype.-newtype Key = Key {unKey :: ByteString}---- | IV bytes newtype.-newtype IV = IV {unIV :: ByteString}---- | Key hash newtype.-newtype KeyHash = KeyHash {unKeyHash :: ByteString} deriving (Eq, Ord, Show)--instance IsString KeyHash where-  fromString = parseString . parseAll $ KeyHash <$> base64P--instance ToField KeyHash where toField = toField . encode . unKeyHash--instance FromField KeyHash where fromField = blobFieldParser $ KeyHash <$> base64P---- | Digest (hash) of binary X509 encoding of RSA public key.-publicKeyHash :: PublicKey -> KeyHash-publicKeyHash = KeyHash . sha256Hash . encodePubKey---- | SHA256 digest.-sha256Hash :: ByteString -> ByteString-sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)--serializeHeader :: Header -> ByteString-serializeHeader Header {aesKey, ivBytes, authTag, msgSize} =-  unKey aesKey <> unIV ivBytes <> authTagToBS authTag <> (encodeWord32 . fromIntegral) msgSize--headerP :: Parser Header-headerP = do-  aesKey <- aesKeyP-  ivBytes <- ivP-  authTag <- bsToAuthTag <$> A.take authTagSize-  msgSize <- fromIntegral . decodeWord32 <$> A.take 4-  return Header {aesKey, ivBytes, authTag, msgSize}---- | AES256 key parser.-aesKeyP :: Parser Key-aesKeyP = Key <$> A.take aesKeySize---- | IV bytes parser.-ivP :: Parser IV-ivP = IV <$> A.take (ivSize @AES256)--parseHeader :: ByteString -> Either CryptoError Header-parseHeader = first CryptoHeaderError . parseAll headerP---- * E2E hybrid encryption scheme---- | E2E encrypt SMP agent messages.------ https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption-encrypt :: PublicKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString-encrypt k paddedSize msg = do-  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'---- | E2E decrypt SMP agent messages.------ https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption-decrypt :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO ByteString-decrypt pk msg'' = do-  let (encHeader, msg') = B.splitAt (privateKeySize 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---- | AEAD-GCM encryption.------ Used as part of hybrid E2E encryption scheme and for SMP transport blocks encryption.-encryptAES :: Key -> IV -> Int -> ByteString -> ExceptT CryptoError IO (AES.AuthTag, ByteString)-encryptAES aesKey ivBytes paddedSize msg = do-  aead <- initAEAD @AES256 aesKey ivBytes-  msg' <- paddedMsg-  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) '#')---- | AEAD-GCM decryption.------ Used as part of hybrid E2E encryption scheme and for SMP transport blocks decryption.-decryptAES :: Key -> IV -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString-decryptAES aesKey ivBytes msg authTag = do-  aead <- initAEAD @AES256 aesKey ivBytes-  maybeError AESDecryptError $ 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-  iv <- makeIV @c ivBytes-  cryptoFailable $ do-    cipher <- AES.cipherInit aesKey-    AES.aeadInit AES.AEAD_GCM cipher iv---- | Random AES256 key.-randomAesKey :: IO Key-randomAesKey = Key <$> getRandomBytes aesKeySize---- | Random IV bytes for AES256 encryption.-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--maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a-maybeError e = maybe (throwE e) return---- | Convert AEAD 'AuthTag' to ByteString.-authTagToBS :: AES.AuthTag -> ByteString-authTagToBS = B.pack . map w2c . BA.unpack . AES.unAuthTag---- | Convert ByteString to AEAD 'AuthTag'.-bsToAuthTag :: ByteString -> AES.AuthTag-bsToAuthTag = AES.AuthTag . BA.pack . map c2w . B.unpack--cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a-cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError--oaepParams :: OAEP.OAEPParams SHA256 ByteString ByteString-oaepParams = OAEP.defaultOAEPParams SHA256---- | RSA OAEP encryption.------ Used as part of hybrid E2E encryption scheme and for SMP transport handshake.-encryptOAEP :: PublicKey -> ByteString -> ExceptT CryptoError IO ByteString-encryptOAEP (PublicKey k) aesKey =-  liftEitherError RSAEncryptError $-    OAEP.encrypt oaepParams k aesKey---- | RSA OAEP decryption.------ Used as part of hybrid E2E encryption scheme and for SMP transport handshake.-decryptOAEP :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO ByteString-decryptOAEP pk encKey =-  liftEitherError RSADecryptError $-    OAEP.decryptSafer oaepParams (rsaPrivateKey pk) encKey--pssParams :: PSS.PSSParams SHA256 ByteString ByteString-pssParams = PSS.defaultPSSParams SHA256---- | RSA PSS message signing.------ Used by SMP clients to sign SMP commands and by SMP agents to sign messages.-sign :: PrivateKey k => k -> ByteString -> ExceptT CryptoError IO Signature-sign pk msg = ExceptT $ bimap RSASignError Signature <$> PSS.signSafer pssParams (rsaPrivateKey pk) msg---- | RSA PSS signature verification.------ Used by SMP servers to authorize SMP commands and by SMP agents to verify messages.-verify :: PublicKey -> Signature -> ByteString -> Bool-verify (PublicKey k) (Signature sig) msg = PSS.verify pssParams k msg sig---- | Base-64 X509 encoding of RSA public key.------ Used as part of SMP queue information (out-of-band message).-serializePubKey :: PublicKey -> ByteString-serializePubKey = ("rsa:" <>) . encode . encodePubKey--serializePubKeyUri :: PublicKey -> ByteString-serializePubKeyUri = ("rsa:" <>) . U.encode . encodePubKey---- | Base-64 PKCS8 encoding of PSA private key.------ Not used as part of SMP protocols.-serializePrivKey :: PrivateKey k => k -> ByteString-serializePrivKey = ("rsa:" <>) . encode . encodePrivKey---- Base-64 X509 RSA public key parser.-pubKeyP :: Parser PublicKey-pubKeyP = decodePubKey <$?> ("rsa:" *> base64P)--pubKeyUriP :: Parser PublicKey-pubKeyUriP = decodePubKey <$?> ("rsa:" *> base64UriP)---- Binary X509 RSA public key parser.-binaryPubKeyP :: Parser PublicKey-binaryPubKeyP = decodePubKey <$?> A.takeByteString---- Base-64 PKCS8 RSA private key parser.-privKeyP :: PrivateKey k => Parser k-privKeyP = decodePrivKey <$?> ("rsa:" *> base64P)---- Binary PKCS8 RSA private key parser.-binaryPrivKeyP :: PrivateKey k => Parser k-binaryPrivKeyP = decodePrivKey <$?> A.takeByteString---- | Construct 'SafePrivateKey' from three numbers - used internally and in the tests.-safePrivateKey :: (Int, Integer, Integer) -> SafePrivateKey-safePrivateKey = SafePrivateKey . safeRsaPrivateKey--safeRsaPrivateKey :: (Int, Integer, Integer) -> R.PrivateKey-safeRsaPrivateKey (size, n, d) =-  R.PrivateKey-    { private_pub =-        R.PublicKey-          { public_size = size,-            public_n = n,-            public_e = 0-          },-      private_d = d,-      private_p = 0,-      private_q = 0,-      private_dP = 0,-      private_dQ = 0,-      private_qinv = 0-    }---- Binary X509 encoding of 'PublicKey'.-encodePubKey :: PublicKey -> ByteString-encodePubKey = encodeKey . PubKeyRSA . rsaPublicKey---- Binary PKCS8 encoding of 'PrivateKey'.-encodePrivKey :: PrivateKey k => k -> ByteString-encodePrivKey = encodeKey . PrivKeyRSA . rsaPrivateKey--encodeKey :: ASN1Object a => a -> ByteString-encodeKey k = toStrict . encodeASN1 DER $ toASN1 k []---- Decoding of binary X509 'PublicKey'.-decodePubKey :: ByteString -> Either String PublicKey-decodePubKey =-  decodeKey >=> \case-    (PubKeyRSA k, []) -> Right $ PublicKey k-    r -> keyError r---- Decoding of binary PKCS8 'PrivateKey'.-decodePrivKey :: PrivateKey k => ByteString -> Either String k-decodePrivKey =-  decodeKey >=> \case-    (PrivKeyRSA pk, []) -> Right $ mkPrivateKey pk-    r -> keyError r--decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1])-decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict--keyError :: (a, [ASN1]) -> Either String b-keyError = \case-  (_, []) -> Left "not RSA key"+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}++-- |+-- Module      : Simplex.Messaging.Crypto+-- Copyright   : (c) simplex.chat+-- License     : AGPL-3+--+-- Maintainer  : chat@simplex.chat+-- Stability   : experimental+-- Portability : non-portable+--+-- This module provides cryptography implementation for SMP protocols based on+-- <https://hackage.haskell.org/package/cryptonite cryptonite package>.+module Simplex.Messaging.Crypto+  ( -- * Cryptographic keys+    Algorithm (..),+    SAlgorithm (..),+    Alg (..),+    SignAlg (..),+    DhAlg (..),+    DhAlgorithm,+    PrivateKey (..),+    PublicKey (..),+    PrivateKeyX25519,+    PublicKeyX25519,+    PrivateKeyX448,+    PublicKeyX448,+    APrivateKey (..),+    APublicKey (..),+    APrivateSignKey (..),+    APublicVerifyKey (..),+    APrivateDhKey (..),+    APublicDhKey (..),+    CryptoPublicKey (..),+    CryptoPrivateKey (..),+    KeyPair,+    DhSecret (..),+    DhSecretX25519,+    ADhSecret (..),+    KeyHash (..),+    generateKeyPair,+    generateKeyPair',+    generateSignatureKeyPair,+    generateDhKeyPair,+    privateToX509,+    publicKey,++    -- * key encoding/decoding+    encodePubKey,+    encodePrivKey,+    pubKeyBytes,++    -- * sign/verify+    Signature (..),+    ASignature (..),+    CryptoSignature (..),+    SignatureSize (..),+    SignatureAlgorithm,+    AlgorithmI (..),+    sign,+    verify,+    verify',+    validSignatureSize,++    -- * DH derivation+    dh',+    dhBytes',++    -- * AES256 AEAD-GCM scheme+    Key (..),+    IV (..),+    AuthTag (..),+    encryptAES,+    decryptAES,+    encryptAEAD,+    decryptAEAD,+    authTagSize,+    randomAesKey,+    randomIV,+    ivSize,++    -- * NaCl crypto_box+    CbNonce (unCbNonce),+    cbEncrypt,+    cbDecrypt,+    cbNonce,+    randomCbNonce,++    -- * SHA256 hash+    sha256Hash,++    -- * Message padding / un-padding+    pad,+    unPad,++    -- * Cryptography error type+    CryptoError (..),+  )+where++import Control.Exception (Exception)+import Control.Monad.Except+import Control.Monad.Trans.Except+import Crypto.Cipher.AES (AES256)+import qualified Crypto.Cipher.Types as AES+import qualified Crypto.Cipher.XSalsa as XSalsa+import qualified Crypto.Error as CE+import Crypto.Hash (Digest, SHA256 (..), hash)+import qualified Crypto.MAC.Poly1305 as Poly1305+import qualified Crypto.PubKey.Curve25519 as X25519+import qualified Crypto.PubKey.Curve448 as X448+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import Crypto.Random (getRandomBytes)+import Data.ASN1.BinaryEncoding+import Data.ASN1.Encoding+import Data.ASN1.Types+import Data.Aeson (FromJSON (..), ToJSON (..))+import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.Bifunctor (bimap, first)+import qualified Data.ByteArray as BA+import Data.ByteString.Base64 (decode, encode)+import qualified Data.ByteString.Base64.URL as U+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Internal (c2w, w2c)+import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.Constraint (Dict (..))+import Data.Kind (Constraint, Type)+import Data.String+import Data.Type.Equality+import Data.Typeable (Typeable)+import Data.X509+import Database.SQLite.Simple.FromField (FromField (..))+import Database.SQLite.Simple.ToField (ToField (..))+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Network.Transport.Internal (decodeWord16, encodeWord16)+import Simplex.Messaging.Encoding+import Simplex.Messaging.Encoding.String+import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)+import Simplex.Messaging.Util ((<$?>))++-- | Cryptographic algorithms.+data Algorithm = Ed25519 | Ed448 | X25519 | X448++-- | Singleton types for 'Algorithm'.+data SAlgorithm :: Algorithm -> Type where+  SEd25519 :: SAlgorithm Ed25519+  SEd448 :: SAlgorithm Ed448+  SX25519 :: SAlgorithm X25519+  SX448 :: SAlgorithm X448++deriving instance Eq (SAlgorithm a)++deriving instance Show (SAlgorithm a)++data Alg = forall a. AlgorithmI a => Alg (SAlgorithm a)++data SignAlg+  = forall a.+    (AlgorithmI a, SignatureAlgorithm a) =>+    SignAlg (SAlgorithm a)++data DhAlg+  = forall a.+    (AlgorithmI a, DhAlgorithm a) =>+    DhAlg (SAlgorithm a)++class AlgorithmI (a :: Algorithm) where sAlgorithm :: SAlgorithm a++instance AlgorithmI Ed25519 where sAlgorithm = SEd25519++instance AlgorithmI Ed448 where sAlgorithm = SEd448++instance AlgorithmI X25519 where sAlgorithm = SX25519++instance AlgorithmI X448 where sAlgorithm = SX448++checkAlgorithm :: forall t a a'. (AlgorithmI a, AlgorithmI a') => t a' -> Either String (t a)+checkAlgorithm x = case testEquality (sAlgorithm @a) (sAlgorithm @a') of+  Just Refl -> Right x+  Nothing -> Left "bad algorithm"++instance TestEquality SAlgorithm where+  testEquality SEd25519 SEd25519 = Just Refl+  testEquality SEd448 SEd448 = Just Refl+  testEquality SX25519 SX25519 = Just Refl+  testEquality SX448 SX448 = Just Refl+  testEquality _ _ = Nothing++-- | GADT for public keys.+data PublicKey (a :: Algorithm) where+  PublicKeyEd25519 :: Ed25519.PublicKey -> PublicKey Ed25519+  PublicKeyEd448 :: Ed448.PublicKey -> PublicKey Ed448+  PublicKeyX25519 :: X25519.PublicKey -> PublicKey X25519+  PublicKeyX448 :: X448.PublicKey -> PublicKey X448++deriving instance Eq (PublicKey a)++deriving instance Show (PublicKey a)++data APublicKey+  = forall a.+    AlgorithmI a =>+    APublicKey (SAlgorithm a) (PublicKey a)++instance Eq APublicKey where+  APublicKey a k == APublicKey a' k' = case testEquality a a' of+    Just Refl -> k == k'+    Nothing -> False++deriving instance Show APublicKey++type PublicKeyX25519 = PublicKey X25519++type PublicKeyX448 = PublicKey X448++-- | GADT for private keys.+data PrivateKey (a :: Algorithm) where+  PrivateKeyEd25519 :: Ed25519.SecretKey -> Ed25519.PublicKey -> PrivateKey Ed25519+  PrivateKeyEd448 :: Ed448.SecretKey -> Ed448.PublicKey -> PrivateKey Ed448+  PrivateKeyX25519 :: X25519.SecretKey -> X25519.PublicKey -> PrivateKey X25519+  PrivateKeyX448 :: X448.SecretKey -> X448.PublicKey -> PrivateKey X448++deriving instance Eq (PrivateKey a)++deriving instance Show (PrivateKey a)++data APrivateKey+  = forall a.+    AlgorithmI a =>+    APrivateKey (SAlgorithm a) (PrivateKey a)++instance Eq APrivateKey where+  APrivateKey a k == APrivateKey a' k' = case testEquality a a' of+    Just Refl -> k == k'+    Nothing -> False++deriving instance Show APrivateKey++type PrivateKeyX25519 = PrivateKey X25519++type PrivateKeyX448 = PrivateKey X448++type family SignatureAlgorithm (a :: Algorithm) :: Constraint where+  SignatureAlgorithm Ed25519 = ()+  SignatureAlgorithm Ed448 = ()+  SignatureAlgorithm a =+    (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used to sign/verify"))++signatureAlgorithm :: SAlgorithm a -> Maybe (Dict (SignatureAlgorithm a))+signatureAlgorithm = \case+  SEd25519 -> Just Dict+  SEd448 -> Just Dict+  _ -> Nothing++data APrivateSignKey+  = forall a.+    (AlgorithmI a, SignatureAlgorithm a) =>+    APrivateSignKey (SAlgorithm a) (PrivateKey a)++instance Eq APrivateSignKey where+  APrivateSignKey a k == APrivateSignKey a' k' = case testEquality a a' of+    Just Refl -> k == k'+    Nothing -> False++deriving instance Show APrivateSignKey++data APublicVerifyKey+  = forall a.+    (AlgorithmI a, SignatureAlgorithm a) =>+    APublicVerifyKey (SAlgorithm a) (PublicKey a)++instance Eq APublicVerifyKey where+  APublicVerifyKey a k == APublicVerifyKey a' k' = case testEquality a a' of+    Just Refl -> k == k'+    Nothing -> False++deriving instance Show APublicVerifyKey++data APrivateDhKey+  = forall a.+    (AlgorithmI a, DhAlgorithm a) =>+    APrivateDhKey (SAlgorithm a) (PrivateKey a)++instance Eq APrivateDhKey where+  APrivateDhKey a k == APrivateDhKey a' k' = case testEquality a a' of+    Just Refl -> k == k'+    Nothing -> False++deriving instance Show APrivateDhKey++data APublicDhKey+  = forall a.+    (AlgorithmI a, DhAlgorithm a) =>+    APublicDhKey (SAlgorithm a) (PublicKey a)++instance Eq APublicDhKey where+  APublicDhKey a k == APublicDhKey a' k' = case testEquality a a' of+    Just Refl -> k == k'+    Nothing -> False++deriving instance Show APublicDhKey++data DhSecret (a :: Algorithm) where+  DhSecretX25519 :: X25519.DhSecret -> DhSecret X25519+  DhSecretX448 :: X448.DhSecret -> DhSecret X448++deriving instance Eq (DhSecret a)++deriving instance Show (DhSecret a)++data ADhSecret+  = forall a.+    (AlgorithmI a, DhAlgorithm a) =>+    ADhSecret (SAlgorithm a) (DhSecret a)++type DhSecretX25519 = DhSecret X25519++type family DhAlgorithm (a :: Algorithm) :: Constraint where+  DhAlgorithm X25519 = ()+  DhAlgorithm X448 = ()+  DhAlgorithm a =+    (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used for DH exchange"))++dhAlgorithm :: SAlgorithm a -> Maybe (Dict (DhAlgorithm a))+dhAlgorithm = \case+  SX25519 -> Just Dict+  SX448 -> Just Dict+  _ -> Nothing++dhBytes' :: DhSecret a -> ByteString+dhBytes' = \case+  DhSecretX25519 s -> BA.convert s+  DhSecretX448 s -> BA.convert s++instance AlgorithmI a => StrEncoding (DhSecret a) where+  strEncode = strEncode . dhBytes'+  strDecode = (\(ADhSecret _ s) -> checkAlgorithm s) <=< strDecode++instance StrEncoding ADhSecret where+  strEncode (ADhSecret _ s) = strEncode $ dhBytes' s+  strDecode = cryptoPassed . secret+    where+      secret bs+        | B.length bs == x25519_size = ADhSecret SX25519 . DhSecretX25519 <$> X25519.dhSecret bs+        | B.length bs == x448_size = ADhSecret SX448 . DhSecretX448 <$> X448.dhSecret bs+        | otherwise = CE.CryptoFailed CE.CryptoError_SharedSecretSizeInvalid+      cryptoPassed = \case+        CE.CryptoPassed s -> Right s+        CE.CryptoFailed e -> Left $ show e++instance AlgorithmI a => IsString (DhSecret a) where+  fromString = parseString strDecode++-- | Class for public key types+class CryptoPublicKey k where+  toPubKey :: (forall a. AlgorithmI a => PublicKey a -> b) -> k -> b+  pubKey :: APublicKey -> Either String k++instance CryptoPublicKey APublicKey where+  toPubKey f (APublicKey _ k) = f k+  pubKey = Right++instance CryptoPublicKey APublicVerifyKey where+  toPubKey f (APublicVerifyKey _ k) = f k+  pubKey (APublicKey a k) = case signatureAlgorithm a of+    Just Dict -> Right $ APublicVerifyKey a k+    _ -> Left "key does not support signature algorithms"++instance CryptoPublicKey APublicDhKey where+  toPubKey f (APublicDhKey _ k) = f k+  pubKey (APublicKey a k) = case dhAlgorithm a of+    Just Dict -> Right $ APublicDhKey a k+    _ -> Left "key does not support DH algorithms"++instance AlgorithmI a => CryptoPublicKey (PublicKey a) where+  toPubKey = id+  pubKey (APublicKey _ k) = checkAlgorithm k++instance Encoding APublicVerifyKey where+  smpEncode = smpEncode . encodePubKey+  {-# INLINE smpEncode #-}+  smpDecode = decodePubKey+  {-# INLINE smpDecode #-}++instance Encoding APublicDhKey where+  smpEncode = smpEncode . encodePubKey+  {-# INLINE smpEncode #-}+  smpDecode = decodePubKey+  {-# INLINE smpDecode #-}++instance AlgorithmI a => Encoding (PublicKey a) where+  smpEncode = smpEncode . encodePubKey+  {-# INLINE smpEncode #-}+  smpDecode = decodePubKey+  {-# INLINE smpDecode #-}++instance StrEncoding APublicVerifyKey where+  strEncode = strEncode . encodePubKey+  {-# INLINE strEncode #-}+  strDecode = decodePubKey+  {-# INLINE strDecode #-}++instance StrEncoding APublicDhKey where+  strEncode = strEncode . encodePubKey+  {-# INLINE strEncode #-}+  strDecode = decodePubKey+  {-# INLINE strDecode #-}++instance AlgorithmI a => StrEncoding (PublicKey a) where+  strEncode = strEncode . encodePubKey+  {-# INLINE strEncode #-}+  strDecode = decodePubKey+  {-# INLINE strDecode #-}++instance AlgorithmI a => ToJSON (PublicKey a) where+  toJSON = strToJSON+  toEncoding = strToJEncoding++instance AlgorithmI a => FromJSON (PublicKey a) where+  parseJSON = strParseJSON "PublicKey"++encodePubKey :: CryptoPublicKey k => k -> ByteString+encodePubKey = toPubKey $ encodeASNObj . publicToX509+{-# INLINE encodePubKey #-}++pubKeyBytes :: PublicKey a -> ByteString+pubKeyBytes = \case+  PublicKeyEd25519 k -> BA.convert k+  PublicKeyEd448 k -> BA.convert k+  PublicKeyX25519 k -> BA.convert k+  PublicKeyX448 k -> BA.convert k++class CryptoPrivateKey pk where+  type PublicKeyType pk+  toPrivKey :: (forall a. AlgorithmI a => PrivateKey a -> b) -> pk -> b+  privKey :: APrivateKey -> Either String pk++instance CryptoPrivateKey APrivateKey where+  type PublicKeyType APrivateKey = APublicKey+  toPrivKey f (APrivateKey _ k) = f k+  privKey = Right++instance CryptoPrivateKey APrivateSignKey where+  type PublicKeyType APrivateSignKey = APublicVerifyKey+  toPrivKey f (APrivateSignKey _ k) = f k+  privKey (APrivateKey a k) = case signatureAlgorithm a of+    Just Dict -> Right $ APrivateSignKey a k+    _ -> Left "key does not support signature algorithms"++instance CryptoPrivateKey APrivateDhKey where+  type PublicKeyType APrivateDhKey = APublicDhKey+  toPrivKey f (APrivateDhKey _ k) = f k+  privKey (APrivateKey a k) = case dhAlgorithm a of+    Just Dict -> Right $ APrivateDhKey a k+    _ -> Left "key does not support DH algorithm"++instance AlgorithmI a => CryptoPrivateKey (PrivateKey a) where+  type PublicKeyType (PrivateKey a) = PublicKey a+  toPrivKey = id+  privKey (APrivateKey _ k) = checkAlgorithm k++publicKey :: PrivateKey a -> PublicKey a+publicKey = \case+  PrivateKeyEd25519 _ k -> PublicKeyEd25519 k+  PrivateKeyEd448 _ k -> PublicKeyEd448 k+  PrivateKeyX25519 _ k -> PublicKeyX25519 k+  PrivateKeyX448 _ k -> PublicKeyX448 k++encodePrivKey :: CryptoPrivateKey pk => pk -> ByteString+encodePrivKey = toPrivKey $ encodeASNObj . privateToX509++instance AlgorithmI a => IsString (PrivateKey a) where+  fromString = parseString $ decode >=> decodePrivKey++instance AlgorithmI a => IsString (PublicKey a) where+  fromString = parseString $ decode >=> decodePubKey++instance AlgorithmI a => ToJSON (PrivateKey a) where+  toJSON = strToJSON . strEncode . encodePrivKey+  toEncoding = strToJEncoding . strEncode . encodePrivKey++instance AlgorithmI a => FromJSON (PrivateKey a) where+  parseJSON v = (decodePrivKey <=< U.decode) <$?> strParseJSON "PrivateKey" v++type KeyPairType pk = (PublicKeyType pk, pk)++type KeyPair a = KeyPairType (PrivateKey a)++type AKeyPair = KeyPairType APrivateKey++type ASignatureKeyPair = KeyPairType APrivateSignKey++type ADhKeyPair = KeyPairType APrivateDhKey++generateKeyPair :: AlgorithmI a => SAlgorithm a -> IO AKeyPair+generateKeyPair a = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair'++generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> IO ASignatureKeyPair+generateSignatureKeyPair a = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair'++generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> IO ADhKeyPair+generateDhKeyPair a = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair'++generateKeyPair' :: forall a. AlgorithmI a => IO (KeyPair a)+generateKeyPair' = case sAlgorithm @a of+  SEd25519 ->+    Ed25519.generateSecretKey >>= \pk ->+      let k = Ed25519.toPublic pk+       in pure (PublicKeyEd25519 k, PrivateKeyEd25519 pk k)+  SEd448 ->+    Ed448.generateSecretKey >>= \pk ->+      let k = Ed448.toPublic pk+       in pure (PublicKeyEd448 k, PrivateKeyEd448 pk k)+  SX25519 ->+    X25519.generateSecretKey >>= \pk ->+      let k = X25519.toPublic pk+       in pure (PublicKeyX25519 k, PrivateKeyX25519 pk k)+  SX448 ->+    X448.generateSecretKey >>= \pk ->+      let k = X448.toPublic pk+       in pure (PublicKeyX448 k, PrivateKeyX448 pk k)++instance ToField APrivateSignKey where toField = toField . encodePrivKey++instance ToField APublicVerifyKey where toField = toField . encodePubKey++instance ToField APrivateDhKey where toField = toField . encodePrivKey++instance ToField APublicDhKey where toField = toField . encodePubKey++instance AlgorithmI a => ToField (PrivateKey a) where toField = toField . encodePrivKey++instance AlgorithmI a => ToField (PublicKey a) where toField = toField . encodePubKey++instance ToField (DhSecret a) where toField = toField . dhBytes'++instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePrivKey++instance FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey++instance FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey++instance FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey++instance (Typeable a, AlgorithmI a) => FromField (PrivateKey a) where fromField = blobFieldDecoder decodePrivKey++instance (Typeable a, AlgorithmI a) => FromField (PublicKey a) where fromField = blobFieldDecoder decodePubKey++instance (Typeable a, AlgorithmI a) => FromField (DhSecret a) where fromField = blobFieldDecoder strDecode++instance IsString (Maybe ASignature) where+  fromString = parseString $ decode >=> decodeSignature++data Signature (a :: Algorithm) where+  SignatureEd25519 :: Ed25519.Signature -> Signature Ed25519+  SignatureEd448 :: Ed448.Signature -> Signature Ed448++deriving instance Eq (Signature a)++deriving instance Show (Signature a)++data ASignature+  = forall a.+    (AlgorithmI a, SignatureAlgorithm a) =>+    ASignature (SAlgorithm a) (Signature a)++instance Eq ASignature where+  ASignature a s == ASignature a' s' = case testEquality a a' of+    Just Refl -> s == s'+    _ -> False++deriving instance Show ASignature++class CryptoSignature s where+  serializeSignature :: s -> ByteString+  serializeSignature = encode . signatureBytes+  signatureBytes :: s -> ByteString+  decodeSignature :: ByteString -> Either String s++instance CryptoSignature ASignature where+  signatureBytes (ASignature _ sig) = signatureBytes sig+  decodeSignature s+    | B.length s == Ed25519.signatureSize =+      ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s+    | B.length s == Ed448.signatureSize =+      ASignature SEd448 . SignatureEd448 <$> ed Ed448.signature s+    | otherwise = Left "bad signature size"+    where+      ed alg = first show . CE.eitherCryptoError . alg++instance CryptoSignature (Maybe ASignature) where+  signatureBytes = maybe "" signatureBytes+  decodeSignature s+    | B.null s = Right Nothing+    | otherwise = Just <$> decodeSignature s++instance AlgorithmI a => CryptoSignature (Signature a) where+  signatureBytes = \case+    SignatureEd25519 s -> BA.convert s+    SignatureEd448 s -> BA.convert s+  decodeSignature s = do+    ASignature _ sig <- decodeSignature s+    checkAlgorithm sig++class SignatureSize s where signatureSize :: s -> Int++instance SignatureSize (Signature a) where+  signatureSize = \case+    SignatureEd25519 _ -> Ed25519.signatureSize+    SignatureEd448 _ -> Ed448.signatureSize++instance SignatureSize APrivateSignKey where+  signatureSize (APrivateSignKey _ k) = signatureSize k++instance SignatureSize APublicVerifyKey where+  signatureSize (APublicVerifyKey _ k) = signatureSize k++instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where+  signatureSize = \case+    PrivateKeyEd25519 _ _ -> Ed25519.signatureSize+    PrivateKeyEd448 _ _ -> Ed448.signatureSize++instance SignatureAlgorithm a => SignatureSize (PublicKey a) where+  signatureSize = \case+    PublicKeyEd25519 _ -> Ed25519.signatureSize+    PublicKeyEd448 _ -> Ed448.signatureSize++-- | Various cryptographic or related errors.+data CryptoError+  = -- | AES initialization error+    AESCipherError CE.CryptoError+  | -- | IV generation error+    CryptoIVError+  | -- | AES decryption error+    AESDecryptError+  | -- CryptoBox decryption error+    CBDecryptError+  | -- | message is larger that allowed padded length minus 2 (to prepend message length)+    -- (or required un-padded length is larger than the message length)+    CryptoLargeMsgError+  | -- | failure parsing message header+    CryptoHeaderError String+  | -- | no sending chain key in ratchet state+    CERatchetState+  | -- | header decryption error (could indicate that another key should be tried)+    CERatchetHeader+  | -- | too many skipped messages+    CERatchetTooManySkipped+  | -- | duplicate message number (or, possibly, skipped message that failed to decrypt?)+    CERatchetDuplicateMessage+  deriving (Eq, Show, Exception)++aesKeySize :: Int+aesKeySize = 256 `div` 8++authTagSize :: Int+authTagSize = 128 `div` 8++x25519_size :: Int+x25519_size = 32++x448_size :: Int+x448_size = 448 `quot` 8++validSignatureSize :: Int -> Bool+validSignatureSize n =+  n == Ed25519.signatureSize || n == Ed448.signatureSize++-- | AES key newtype.+newtype Key = Key {unKey :: ByteString}+  deriving (Eq, Ord, Show)++instance ToField Key where toField = toField . unKey++instance FromField Key where fromField f = Key <$> fromField f++instance ToJSON Key where+  toJSON = strToJSON . unKey+  toEncoding = strToJEncoding . unKey++instance FromJSON Key where+  parseJSON = fmap Key . strParseJSON "Key"++-- | IV bytes newtype.+newtype IV = IV {unIV :: ByteString}++instance Encoding IV where+  smpEncode = unIV+  smpP = IV <$> A.take (ivSize @AES256)++newtype AuthTag = AuthTag {unAuthTag :: AES.AuthTag}++instance Encoding AuthTag where+  smpEncode = B.pack . map w2c . BA.unpack . AES.unAuthTag . unAuthTag+  smpP = AuthTag . AES.AuthTag . BA.pack . map c2w . B.unpack <$> A.take authTagSize++-- | Certificate fingerpint newtype.+--+-- Previously was used for server's public key hash in ad-hoc transport scheme, kept as is for compatibility.+newtype KeyHash = KeyHash {unKeyHash :: ByteString} deriving (Eq, Ord, Show)++instance Encoding KeyHash where+  smpEncode = smpEncode . unKeyHash+  smpP = KeyHash <$> smpP++instance StrEncoding KeyHash where+  strEncode = strEncode . unKeyHash+  strP = KeyHash <$> strP++instance IsString KeyHash where+  fromString = parseString $ parseAll strP++instance ToField KeyHash where toField = toField . strEncode++instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP++-- | SHA256 digest.+sha256Hash :: ByteString -> ByteString+sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)++-- | AEAD-GCM encryption with empty associated data.+--+-- Used as part of hybrid E2E encryption scheme and for SMP transport blocks encryption.+encryptAES :: Key -> IV -> Int -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)+encryptAES key iv paddedLen = encryptAEAD key iv paddedLen ""++-- | AEAD-GCM encryption.+--+-- Used as part of hybrid E2E encryption scheme and for SMP transport blocks encryption.+encryptAEAD :: Key -> IV -> Int -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)+encryptAEAD aesKey ivBytes paddedLen ad msg = do+  aead <- initAEAD @AES256 aesKey ivBytes+  msg' <- liftEither $ pad msg paddedLen+  pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg' authTagSize++-- | AEAD-GCM decryption with empty associated data.+--+-- Used as part of hybrid E2E encryption scheme and for SMP transport blocks decryption.+decryptAES :: Key -> IV -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString+decryptAES key iv = decryptAEAD key iv ""++-- | AEAD-GCM decryption.+--+-- Used as part of hybrid E2E encryption scheme and for SMP transport blocks decryption.+decryptAEAD :: Key -> IV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString+decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do+  aead <- initAEAD @AES256 aesKey ivBytes+  liftEither . unPad =<< maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg authTag)++pad :: ByteString -> Int -> Either CryptoError ByteString+pad msg paddedLen+  | padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'+  | otherwise = Left CryptoLargeMsgError+  where+    len = B.length msg+    padLen = paddedLen - len - 2++unPad :: ByteString -> Either CryptoError ByteString+unPad padded+  | B.length rest >= len = Right $ B.take len rest+  | otherwise = Left CryptoLargeMsgError+  where+    (lenWrd, rest) = B.splitAt 2 padded+    len = fromIntegral $ decodeWord16 lenWrd++initAEAD :: forall c. AES.BlockCipher c => Key -> IV -> ExceptT CryptoError IO (AES.AEAD c)+initAEAD (Key aesKey) (IV ivBytes) = do+  iv <- makeIV @c ivBytes+  cryptoFailable $ do+    cipher <- AES.cipherInit aesKey+    AES.aeadInit AES.AEAD_GCM cipher iv++-- | Random AES256 key.+randomAesKey :: IO Key+randomAesKey = Key <$> getRandomBytes aesKeySize++-- | Random IV bytes for AES256 encryption.+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++maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a+maybeError e = maybe (throwE e) return++cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a+cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError++-- | Message signing.+--+-- Used by SMP clients to sign SMP commands and by SMP agents to sign messages.+sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> ExceptT CryptoError IO (Signature a)+sign' (PrivateKeyEd25519 pk k) msg = pure . SignatureEd25519 $ Ed25519.sign pk k msg+sign' (PrivateKeyEd448 pk k) msg = pure . SignatureEd448 $ Ed448.sign pk k msg++sign :: APrivateSignKey -> ByteString -> ExceptT CryptoError IO ASignature+sign (APrivateSignKey a k) = fmap (ASignature a) . sign' k++-- | Signature verification.+--+-- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages.+verify' :: SignatureAlgorithm a => PublicKey a -> Signature a -> ByteString -> Bool+verify' (PublicKeyEd25519 k) (SignatureEd25519 sig) msg = Ed25519.verify k msg sig+verify' (PublicKeyEd448 k) (SignatureEd448 sig) msg = Ed448.verify k msg sig++verify :: APublicVerifyKey -> ASignature -> ByteString -> Bool+verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' of+  Just Refl -> verify' k sig msg+  _ -> False++dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a+dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk+dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk++-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.+cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString+cbEncrypt secret (CbNonce nonce) msg paddedLen = cryptoBox <$> pad msg paddedLen+  where+    cryptoBox s = BA.convert tag <> c+      where+        (rs, c) = xSalsa20 secret nonce s+        tag = Poly1305.auth rs c++-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.+cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString+cbDecrypt secret (CbNonce nonce) packet+  | B.length packet < 16 = Left CBDecryptError+  | BA.constEq tag' tag = unPad msg+  | otherwise = Left CBDecryptError+  where+    (tag', c) = B.splitAt 16 packet+    (rs, msg) = xSalsa20 secret nonce c+    tag = Poly1305.auth rs c++newtype CbNonce = CbNonce {unCbNonce :: ByteString}+  deriving (Show)++cbNonce :: ByteString -> CbNonce+cbNonce s+  | len == 24 = CbNonce s+  | len > 24 = CbNonce . fst $ B.splitAt 24 s+  | otherwise = CbNonce $ s <> B.replicate (24 - len) (toEnum 0)+  where+    len = B.length s++randomCbNonce :: IO CbNonce+randomCbNonce = CbNonce <$> getRandomBytes 24++instance Encoding CbNonce where+  smpEncode = unCbNonce+  smpP = CbNonce <$> A.take 24++xSalsa20 :: DhSecret X25519 -> ByteString -> ByteString -> (ByteString, ByteString)+xSalsa20 (DhSecretX25519 shared) nonce msg = (rs, msg')+  where+    zero = B.replicate 16 $ toEnum 0+    (iv0, iv1) = B.splitAt 8 nonce+    state0 = XSalsa.initialize 20 shared (zero `B.append` iv0)+    state1 = XSalsa.derive state0 iv1+    (rs, state2) = XSalsa.generate state1 32+    (msg', _) = XSalsa.combine state2 msg++publicToX509 :: PublicKey a -> PubKey+publicToX509 = \case+  PublicKeyEd25519 k -> PubKeyEd25519 k+  PublicKeyEd448 k -> PubKeyEd448 k+  PublicKeyX25519 k -> PubKeyX25519 k+  PublicKeyX448 k -> PubKeyX448 k++privateToX509 :: PrivateKey a -> PrivKey+privateToX509 = \case+  PrivateKeyEd25519 k _ -> PrivKeyEd25519 k+  PrivateKeyEd448 k _ -> PrivKeyEd448 k+  PrivateKeyX25519 k _ -> PrivKeyX25519 k+  PrivateKeyX448 k _ -> PrivKeyX448 k++encodeASNObj :: ASN1Object a => a -> ByteString+encodeASNObj k = toStrict . encodeASN1 DER $ toASN1 k []++-- Decoding of binary X509 'CryptoPublicKey'.+decodePubKey :: CryptoPublicKey k => ByteString -> Either String k+decodePubKey = decodeKey >=> x509ToPublic >=> pubKey++-- Decoding of binary PKCS8 'PrivateKey'.+decodePrivKey :: CryptoPrivateKey k => ByteString -> Either String k+decodePrivKey = decodeKey >=> x509ToPrivate >=> privKey++x509ToPublic :: (PubKey, [ASN1]) -> Either String APublicKey+x509ToPublic = \case+  (PubKeyEd25519 k, []) -> Right . APublicKey SEd25519 $ PublicKeyEd25519 k+  (PubKeyEd448 k, []) -> Right . APublicKey SEd448 $ PublicKeyEd448 k+  (PubKeyX25519 k, []) -> Right . APublicKey SX25519 $ PublicKeyX25519 k+  (PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k+  r -> keyError r++x509ToPrivate :: (PrivKey, [ASN1]) -> Either String APrivateKey+x509ToPrivate = \case+  (PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k+  (PrivKeyEd448 k, []) -> Right . APrivateKey SEd448 . PrivateKeyEd448 k $ Ed448.toPublic k+  (PrivKeyX25519 k, []) -> Right . APrivateKey SX25519 . PrivateKeyX25519 k $ X25519.toPublic k+  (PrivKeyX448 k, []) -> Right . APrivateKey SX448 . PrivateKeyX448 k $ X448.toPublic k+  r -> keyError r++decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1])+decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict++keyError :: (a, [ASN1]) -> Either String b+keyError = \case+  (_, []) -> Left "unknown key algorithm"   _ -> Left "more than one key"
+ src/Simplex/Messaging/Crypto/Ratchet.hs view
@@ -0,0 +1,488 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Simplex.Messaging.Crypto.Ratchet where++import Control.Monad.Except+import Control.Monad.Trans.Except+import Crypto.Cipher.AES (AES256)+import Crypto.Hash (SHA512)+import qualified Crypto.KDF.HKDF as H+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as J+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as LB+import qualified Data.List.NonEmpty as L+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import Data.Typeable (Typeable)+import Data.Word (Word32)+import Database.SQLite.Simple.FromField (FromField (..))+import Database.SQLite.Simple.ToField (ToField (..))+import GHC.Generics+import Simplex.Messaging.Agent.QueryString+import Simplex.Messaging.Crypto+import Simplex.Messaging.Encoding+import Simplex.Messaging.Encoding.String+import Simplex.Messaging.Parsers (blobFieldDecoder, parseE, parseE')+import Simplex.Messaging.Util (tryE)+import Simplex.Messaging.Version++e2eEncryptVersion :: Version+e2eEncryptVersion = 1++e2eEncryptVRange :: VersionRange+e2eEncryptVRange = mkVersionRange 1 e2eEncryptVersion++data E2ERatchetParams (a :: Algorithm)+  = E2ERatchetParams Version (PublicKey a) (PublicKey a)+  deriving (Eq, Show)++instance AlgorithmI a => Encoding (E2ERatchetParams a) where+  smpEncode (E2ERatchetParams v k1 k2) = smpEncode (v, k1, k2)+  smpP = E2ERatchetParams <$> smpP <*> smpP <*> smpP++instance VersionI (E2ERatchetParams a) where+  type VersionRangeT (E2ERatchetParams a) = E2ERatchetParamsUri a+  version (E2ERatchetParams v _ _) = v+  toVersionRangeT (E2ERatchetParams _ k1 k2) vr = E2ERatchetParamsUri vr k1 k2++instance VersionRangeI (E2ERatchetParamsUri a) where+  type VersionT (E2ERatchetParamsUri a) = (E2ERatchetParams a)+  versionRange (E2ERatchetParamsUri vr _ _) = vr+  toVersionT (E2ERatchetParamsUri _ k1 k2) v = E2ERatchetParams v k1 k2++data E2ERatchetParamsUri (a :: Algorithm)+  = E2ERatchetParamsUri VersionRange (PublicKey a) (PublicKey a)+  deriving (Eq, Show)++instance AlgorithmI a => StrEncoding (E2ERatchetParamsUri a) where+  strEncode (E2ERatchetParamsUri vs key1 key2) =+    strEncode $+      QSP QNoEscaping [("v", strEncode vs), ("x3dh", strEncodeList [key1, key2])]+  strP = do+    query <- strP+    vs <- queryParam "v" query+    keys <- L.toList <$> queryParam "x3dh" query+    case keys of+      [key1, key2] -> pure $ E2ERatchetParamsUri vs key1 key2+      _ -> fail "bad e2e params"++generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => Version -> IO (PrivateKey a, PrivateKey a, E2ERatchetParams a)+generateE2EParams v = do+  (k1, pk1) <- generateKeyPair'+  (k2, pk2) <- generateKeyPair'+  pure (pk1, pk2, E2ERatchetParams v k1 k2)++data RatchetInitParams = RatchetInitParams+  { assocData :: Str,+    ratchetKey :: RatchetKey,+    sndHK :: HeaderKey,+    rcvNextHK :: HeaderKey+  }+  deriving (Eq, Show)++x3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams+x3dhSnd spk1 spk2 (E2ERatchetParams _ rk1 rk2) =+  x3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)++x3dhRcv :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams+x3dhRcv rpk1 rpk2 (E2ERatchetParams _ sk1 sk2) =+  x3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)++x3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams+x3dh (sk1, rk1) dh1 dh2 dh3 =+  RatchetInitParams {assocData, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk}+  where+    assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1+    (hk, rest) = B.splitAt 32 $ dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3+    (nhk, sk) = B.splitAt 32 rest++type RatchetX448 = Ratchet 'X448++data Ratchet a = Ratchet+  { -- ratchet version range sent in messages (current .. max supported ratchet version)+    rcVersion :: VersionRange,+    -- associated data - must be the same in both parties ratchets+    rcAD :: Str,+    rcDHRs :: PrivateKey a,+    rcRK :: RatchetKey,+    rcSnd :: Maybe (SndRatchet a),+    rcRcv :: Maybe RcvRatchet,+    rcNs :: Word32,+    rcNr :: Word32,+    rcPN :: Word32,+    rcNHKs :: HeaderKey,+    rcNHKr :: HeaderKey+  }+  deriving (Eq, Show, Generic, FromJSON)++instance AlgorithmI a => ToJSON (Ratchet a) where+  toEncoding = J.genericToEncoding J.defaultOptions++data SndRatchet a = SndRatchet+  { rcDHRr :: PublicKey a,+    rcCKs :: RatchetKey,+    rcHKs :: HeaderKey+  }+  deriving (Eq, Show, Generic, FromJSON)++instance AlgorithmI a => ToJSON (SndRatchet a) where+  toEncoding = J.genericToEncoding J.defaultOptions++data RcvRatchet = RcvRatchet+  { rcCKr :: RatchetKey,+    rcHKr :: HeaderKey+  }+  deriving (Eq, Show, Generic, FromJSON)++instance ToJSON RcvRatchet where+  toEncoding = J.genericToEncoding J.defaultOptions++type SkippedMsgKeys = Map HeaderKey SkippedHdrMsgKeys++type SkippedHdrMsgKeys = Map Word32 MessageKey++data SkippedMsgDiff+  = SMDNoChange+  | SMDRemove HeaderKey Word32+  | SMDAdd SkippedMsgKeys++-- | this function is only used in tests to apply changes in skipped messages,+-- in the agent the diff is persisted, and the whole state is loaded for the next message.+applySMDiff :: SkippedMsgKeys -> SkippedMsgDiff -> SkippedMsgKeys+applySMDiff smks = \case+  SMDNoChange -> smks+  SMDRemove hk msgN -> fromMaybe smks $ do+    mks <- M.lookup hk smks+    _ <- M.lookup msgN mks+    let mks' = M.delete msgN mks+    pure $+      if M.null mks'+        then M.delete hk smks+        else M.insert hk mks' smks+  SMDAdd smks' ->+    let merge hk mks = M.alter (Just . maybe mks (M.union mks)) hk+     in M.foldrWithKey merge smks smks'++type HeaderKey = Key++data MessageKey = MessageKey Key IV++instance Encoding MessageKey where+  smpEncode (MessageKey (Key key) (IV iv)) = smpEncode (key, iv)+  smpP = MessageKey <$> (Key <$> smpP) <*> (IV <$> smpP)++-- | Input key material for double ratchet HKDF functions+newtype RatchetKey = RatchetKey ByteString+  deriving (Eq, Show)++instance ToJSON RatchetKey where+  toJSON (RatchetKey k) = strToJSON k+  toEncoding (RatchetKey k) = strToJEncoding k++instance FromJSON RatchetKey where+  parseJSON = fmap RatchetKey . strParseJSON "Key"++instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode++instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict'++instance ToField MessageKey where toField = toField . smpEncode++instance FromField MessageKey where fromField = blobFieldDecoder smpDecode++-- | Sending ratchet initialization, equivalent to RatchetInitAliceHE in double ratchet spec+--+-- Please note that sPKey is not stored, and its public part together with random salt+-- is sent to the recipient.+initSndRatchet ::+  forall a. (AlgorithmI a, DhAlgorithm a) => PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a+initSndRatchet rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do+  -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr))+  let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs+   in Ratchet+        { rcVersion = e2eEncryptVRange,+          rcAD = assocData,+          rcDHRs,+          rcRK,+          rcSnd = Just SndRatchet {rcDHRr, rcCKs, rcHKs = sndHK},+          rcRcv = Nothing,+          rcPN = 0,+          rcNs = 0,+          rcNr = 0,+          rcNHKs,+          rcNHKr = rcvNextHK+        }++-- | Receiving ratchet initialization, equivalent to RatchetInitBobHE in double ratchet spec+--+-- Please note that the public part of rcDHRs was sent to the sender+-- as part of the connection request and random salt was received from the sender.+initRcvRatchet ::+  forall a. (AlgorithmI a, DhAlgorithm a) => PrivateKey a -> RatchetInitParams -> Ratchet a+initRcvRatchet rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =+  Ratchet+    { rcVersion = e2eEncryptVRange,+      rcAD = assocData,+      rcDHRs,+      rcRK = ratchetKey,+      rcSnd = Nothing,+      rcRcv = Nothing,+      rcPN = 0,+      rcNs = 0,+      rcNr = 0,+      rcNHKs = rcvNextHK,+      rcNHKr = sndHK+    }++data MsgHeader a = MsgHeader+  { -- | max supported ratchet version+    msgMaxVersion :: Version,+    msgDHRs :: PublicKey a,+    msgPN :: Word32,+    msgNs :: Word32+  }+  deriving (Eq, Show)++data AMsgHeader+  = forall a.+    (AlgorithmI a, DhAlgorithm a) =>+    AMsgHeader (SAlgorithm a) (MsgHeader a)++-- to allow extension without increasing the size, the actual header length is:+-- 69 = 2 (original size) + 2 + 1+56 (Curve448) + 4 + 4+paddedHeaderLen :: Int+paddedHeaderLen = 88++-- only used in tests to validate correct padding+-- (2 bytes - version size, 1 byte - header size, not to have it fixed or version-dependent)+fullHeaderLen :: Int+fullHeaderLen = 2 + 1 + paddedHeaderLen + authTagSize + ivSize @AES256++instance AlgorithmI a => Encoding (MsgHeader a) where+  smpEncode MsgHeader {msgMaxVersion, msgDHRs, msgPN, msgNs} =+    smpEncode (msgMaxVersion, msgDHRs, msgPN, msgNs)+  smpP = do+    msgMaxVersion <- smpP+    msgDHRs <- smpP+    msgPN <- smpP+    msgNs <- smpP+    pure MsgHeader {msgMaxVersion, msgDHRs, msgPN, msgNs}++data EncMessageHeader = EncMessageHeader+  { ehVersion :: Version,+    ehIV :: IV,+    ehAuthTag :: AuthTag,+    ehBody :: ByteString+  }++instance Encoding EncMessageHeader where+  smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} =+    smpEncode (ehVersion, ehIV, ehAuthTag, ehBody)+  smpP = do+    (ehVersion, ehIV, ehAuthTag, ehBody) <- smpP+    pure EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody}++data EncRatchetMessage = EncRatchetMessage+  { emHeader :: ByteString,+    emAuthTag :: AuthTag,+    emBody :: ByteString+  }++instance Encoding EncRatchetMessage where+  smpEncode EncRatchetMessage {emHeader, emBody, emAuthTag} =+    smpEncode (emHeader, emAuthTag, Tail emBody)+  smpP = do+    (emHeader, emAuthTag, Tail emBody) <- smpP+    pure EncRatchetMessage {emHeader, emBody, emAuthTag}++rcEncrypt :: AlgorithmI a => Ratchet a -> Int -> ByteString -> ExceptT CryptoError IO (ByteString, Ratchet a)+rcEncrypt Ratchet {rcSnd = Nothing} _ _ = throwE CERatchetState+rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcNs, rcPN, rcAD = Str rcAD, rcVersion} paddedMsgLen msg = do+  -- state.CKs, mk = KDF_CK(state.CKs)+  let (ck', mk, iv, ehIV) = chainKdf rcCKs+  -- enc_header = HENCRYPT(state.HKs, header)+  (ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV paddedHeaderLen rcAD msgHeader+  -- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))+  let emHeader = smpEncode EncMessageHeader {ehVersion = minVersion rcVersion, ehBody, ehAuthTag, ehIV}+  (emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (rcAD <> emHeader) msg+  let msg' = smpEncode EncRatchetMessage {emHeader, emBody, emAuthTag}+      -- state.Ns += 1+      rc' = rc {rcSnd = Just sr {rcCKs = ck'}, rcNs = rcNs + 1}+  pure (msg', rc')+  where+    -- header = HEADER(state.DHRs, state.PN, state.Ns)+    msgHeader =+      smpEncode+        MsgHeader+          { msgMaxVersion = maxVersion rcVersion,+            msgDHRs = publicKey rcDHRs,+            msgPN = rcPN,+            msgNs = rcNs+          }++data SkippedMessage a+  = SMMessage (DecryptResult a)+  | SMHeader (Maybe RatchetStep) (MsgHeader a)+  | SMNone++data RatchetStep = AdvanceRatchet | SameRatchet+  deriving (Eq)++type DecryptResult a = (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff)++maxSkip :: Word32+maxSkip = 512++rcDecrypt ::+  forall a.+  (AlgorithmI a, DhAlgorithm a) =>+  Ratchet a ->+  SkippedMsgKeys ->+  ByteString ->+  ExceptT CryptoError IO (DecryptResult a)+rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do+  encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError smpP msg'+  encHdr <- parseE CryptoHeaderError smpP emHeader+  -- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD)+  decryptSkipped encHdr encMsg >>= \case+    SMNone -> do+      (rcStep, hdr) <- decryptRcHeader rcRcv encHdr+      decryptRcMessage rcStep hdr encMsg+    SMHeader rcStep_ hdr ->+      case rcStep_ of+        Just rcStep -> decryptRcMessage rcStep hdr encMsg+        Nothing -> throwE CERatchetHeader+    SMMessage r -> pure r+  where+    decryptRcMessage :: RatchetStep -> MsgHeader a -> EncRatchetMessage -> ExceptT CryptoError IO (DecryptResult a)+    decryptRcMessage rcStep MsgHeader {msgDHRs, msgPN, msgNs} encMsg = do+      -- if dh_ratchet:+      (rc', smks1) <- ratchetStep rcStep+      case skipMessageKeys msgNs rc' of+        Left e -> pure (Left e, rc', smkDiff smks1)+        Right (rc''@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr}, rcNr}, smks2) -> do+          -- state.CKr, mk = KDF_CK(state.CKr)+          let (rcCKr', mk, iv, _) = chainKdf rcCKr+          -- return DECRYPT (mk, cipher-text, CONCAT (AD, enc_header))+          msg <- decryptMessage (MessageKey mk iv) encMsg+          -- state . Nr += 1+          pure (msg, rc'' {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr + 1}, smkDiff $ smks1 <> smks2)+        Right (rc'', smks2) -> do+          pure (Left CERatchetState, rc'', smkDiff $ smks1 <> smks2)+      where+        smkDiff :: SkippedMsgKeys -> SkippedMsgDiff+        smkDiff smks = if M.null smks then SMDNoChange else SMDAdd smks+        ratchetStep :: RatchetStep -> ExceptT CryptoError IO (Ratchet a, SkippedMsgKeys)+        ratchetStep SameRatchet = pure (rc, M.empty)+        ratchetStep AdvanceRatchet =+          -- SkipMessageKeysHE(state, header.pn)+          case skipMessageKeys msgPN rc of+            Left e -> throwE e+            Right (rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr}, hmks) -> do+              -- DHRatchetHE(state, header)+              (_, rcDHRs') <- liftIO $ generateKeyPair' @a+              -- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))+              let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs+                  -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))+                  (rcRK'', rcCKs', rcNHKs') = rootKdf rcRK' msgDHRs rcDHRs'+                  rc'' =+                    rc'+                      { rcDHRs = rcDHRs',+                        rcRK = rcRK'',+                        rcSnd = Just SndRatchet {rcDHRr = msgDHRs, rcCKs = rcCKs', rcHKs = rcNHKs},+                        rcRcv = Just RcvRatchet {rcCKr = rcCKr', rcHKr = rcNHKr},+                        rcPN = rcNs rc,+                        rcNs = 0,+                        rcNr = 0,+                        rcNHKs = rcNHKs',+                        rcNHKr = rcNHKr'+                      }+              pure (rc'', hmks)+    skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)+    skipMessageKeys _ r@Ratchet {rcRcv = Nothing} = Right (r, M.empty)+    skipMessageKeys untilN r@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr, rcHKr}, rcNr}+      | rcNr > untilN = Left CERatchetDuplicateMessage+      | rcNr + maxSkip < untilN = Left CERatchetTooManySkipped+      | rcNr == untilN = Right (r, M.empty)+      | otherwise =+        let (rcCKr', rcNr', mks) = advanceRcvRatchet (untilN - rcNr) rcCKr rcNr M.empty+            r' = r {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr'}+         in Right (r', M.singleton rcHKr mks)+    advanceRcvRatchet :: Word32 -> RatchetKey -> Word32 -> SkippedHdrMsgKeys -> (RatchetKey, Word32, SkippedHdrMsgKeys)+    advanceRcvRatchet 0 ck msgNs mks = (ck, msgNs, mks)+    advanceRcvRatchet n ck msgNs mks =+      let (ck', mk, iv, _) = chainKdf ck+          mks' = M.insert msgNs (MessageKey mk iv) mks+       in advanceRcvRatchet (n - 1) ck' (msgNs + 1) mks'+    decryptSkipped :: EncMessageHeader -> EncRatchetMessage -> ExceptT CryptoError IO (SkippedMessage a)+    decryptSkipped encHdr encMsg = tryDecryptSkipped SMNone $ M.assocs rcMKSkipped+      where+        tryDecryptSkipped :: SkippedMessage a -> [(HeaderKey, SkippedHdrMsgKeys)] -> ExceptT CryptoError IO (SkippedMessage a)+        tryDecryptSkipped SMNone ((hk, mks) : hks) = do+          tryE (decryptHeader hk encHdr) >>= \case+            Left CERatchetHeader -> tryDecryptSkipped SMNone hks+            Left e -> throwE e+            Right hdr@MsgHeader {msgNs} ->+              case M.lookup msgNs mks of+                Nothing ->+                  let nextRc+                        | maybe False ((== hk) . rcHKr) rcRcv = Just SameRatchet+                        | hk == rcNHKr rc = Just AdvanceRatchet+                        | otherwise = Nothing+                   in pure $ SMHeader nextRc hdr+                Just mk -> do+                  msg <- decryptMessage mk encMsg+                  pure $ SMMessage (msg, rc, SMDRemove hk msgNs)+        tryDecryptSkipped r _ = pure r+    decryptRcHeader :: Maybe RcvRatchet -> EncMessageHeader -> ExceptT CryptoError IO (RatchetStep, MsgHeader a)+    decryptRcHeader Nothing hdr = decryptNextHeader hdr+    decryptRcHeader (Just RcvRatchet {rcHKr}) hdr =+      -- header = HDECRYPT(state.HKr, enc_header)+      ((SameRatchet,) <$> decryptHeader rcHKr hdr) `catchE` \case+        CERatchetHeader -> decryptNextHeader hdr+        e -> throwE e+    -- header = HDECRYPT(state.NHKr, enc_header)+    decryptNextHeader hdr = (AdvanceRatchet,) <$> decryptHeader (rcNHKr rc) hdr+    decryptHeader k EncMessageHeader {ehBody, ehAuthTag, ehIV} = do+      header <- decryptAEAD k ehIV rcAD ehBody ehAuthTag `catchE` \_ -> throwE CERatchetHeader+      parseE' CryptoHeaderError smpP header+    decryptMessage :: MessageKey -> EncRatchetMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)+    decryptMessage (MessageKey mk iv) EncRatchetMessage {emHeader, emBody, emAuthTag} =+      -- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))+      -- TODO add associated data+      tryE $ decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag++rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> (RatchetKey, RatchetKey, Key)+rootKdf (RatchetKey rk) k pk =+  let dhOut = dhBytes' $ dh' k pk+      (rk', ck, nhk) = hkdf3 rk dhOut "SimpleXRootRatchet"+   in (RatchetKey rk', RatchetKey ck, Key nhk)++chainKdf :: RatchetKey -> (RatchetKey, Key, IV, IV)+chainKdf (RatchetKey ck) =+  let (ck', mk, ivs) = hkdf3 "" ck "SimpleXChainRatchet"+      (iv1, iv2) = B.splitAt 16 ivs+   in (RatchetKey ck', Key mk, IV iv1, IV iv2)++hkdf3 :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString)+hkdf3 salt ikm info = (s1, s2, s3)+  where+    prk = H.extract salt ikm :: H.PRK SHA512+    out = H.expand prk info 96+    (s1, rest) = B.splitAt 32 out+    (s2, s3) = B.splitAt 32 rest
+ src/Simplex/Messaging/Encoding.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Simplex.Messaging.Encoding+  ( Encoding (..),+    Tail (..),+    Large (..),+    smpEncodeList,+    smpListP,+  )+where++import Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.Bits (shiftL, shiftR, (.|.))+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Internal (c2w, w2c)+import Data.Int (Int64)+import qualified Data.List.NonEmpty as L+import Data.Time.Clock.System (SystemTime (..))+import Data.Word (Word16, Word32)+import Network.Transport.Internal (decodeWord16, decodeWord32, encodeWord16, encodeWord32)+import Simplex.Messaging.Parsers (parseAll)+import Simplex.Messaging.Util ((<$?>))++-- | SMP protocol encoding+class Encoding a where+  {-# MINIMAL smpEncode, (smpDecode | smpP) #-}++  -- | protocol encoding of type (default implementation uses protocol ByteString encoding)+  smpEncode :: a -> ByteString++  -- | decoding of type (default implementation uses parser)+  smpDecode :: ByteString -> Either String a+  smpDecode = parseAll smpP++  -- | protocol parser of type (default implementation parses protocol ByteString encoding)+  smpP :: Parser a+  smpP = smpDecode <$?> smpP++instance Encoding Char where+  smpEncode = B.singleton+  smpP = A.anyChar++instance Encoding Word16 where+  smpEncode = encodeWord16+  smpP = decodeWord16 <$> A.take 2++instance Encoding Word32 where+  smpEncode = encodeWord32+  smpP = decodeWord32 <$> A.take 4++instance Encoding Int64 where+  smpEncode i = w32 (i `shiftR` 32) <> w32 i+  smpP = do+    l <- w32P+    r <- w32P+    pure $ (l `shiftL` 32) .|. r++w32 :: Int64 -> ByteString+w32 = smpEncode @Word32 . fromIntegral++w32P :: Parser Int64+w32P = fromIntegral <$> smpP @Word32++-- ByteStrings are assumed no longer than 255 bytes+instance Encoding ByteString where+  smpEncode s = B.cons (lenEncode $ B.length s) s+  smpP = A.take =<< lenP++lenEncode :: Int -> Char+lenEncode = w2c . fromIntegral++lenP :: Parser Int+lenP = fromIntegral . c2w <$> A.anyChar++instance Encoding a => Encoding (Maybe a) where+  smpEncode s = maybe "0" (("1" <>) . smpEncode) s+  smpP =+    smpP >>= \case+      '0' -> pure Nothing+      '1' -> Just <$> smpP+      _ -> fail "invalid Maybe tag"++newtype Tail = Tail {unTail :: ByteString}++instance Encoding Tail where+  smpEncode = unTail+  smpP = Tail <$> A.takeByteString++-- newtype for encoding/decoding ByteStrings over 255 bytes with 2-bytes length prefix+newtype Large = Large {unLarge :: ByteString}++instance Encoding Large where+  smpEncode (Large s) = smpEncode @Word16 (fromIntegral $ B.length s) <> s+  smpP = do+    len <- fromIntegral <$> smpP @Word16+    Large <$> A.take len++instance Encoding SystemTime where+  smpEncode = smpEncode . systemSeconds+  smpP = MkSystemTime <$> smpP <*> pure 0++-- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)+smpEncodeList :: Encoding a => [a] -> ByteString+smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs++smpListP :: Encoding a => Parser [a]+smpListP = (`A.count` smpP) =<< lenP++instance Encoding String where+  smpEncode = smpEncode . B.pack+  smpP = B.unpack <$> smpP++instance Encoding a => Encoding (L.NonEmpty a) where+  smpEncode = smpEncodeList . L.toList+  smpP =+    lenP >>= \case+      0 -> fail "empty list"+      n -> L.fromList <$> A.count n smpP++instance (Encoding a, Encoding b) => Encoding (a, b) where+  smpEncode (a, b) = smpEncode a <> smpEncode b+  smpP = (,) <$> smpP <*> smpP++instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where+  smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c+  smpP = (,,) <$> smpP <*> smpP <*> smpP++instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where+  smpEncode (a, b, c, d) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d+  smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP++instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where+  smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e+  smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
+ src/Simplex/Messaging/Encoding/String.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Simplex.Messaging.Encoding.String+  ( StrEncoding (..),+    Str (..),+    strP_,+    strToJSON,+    strToJEncoding,+    strParseJSON,+    base64urlP,+    strEncodeList,+    strListP,+  )+where++import Control.Applicative (optional)+import Data.Aeson (FromJSON (..), ToJSON (..))+import qualified Data.Aeson as J+import qualified Data.Aeson.Encoding as JE+import qualified Data.Aeson.Types as JT+import Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as A+import qualified Data.ByteString.Base64.URL as U+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Char (isAlphaNum)+import qualified Data.List.NonEmpty as L+import Data.Text.Encoding (decodeLatin1, encodeUtf8)+import Data.Word (Word16)+import Simplex.Messaging.Parsers (parseAll)+import Simplex.Messaging.Util ((<$?>))++-- | Serializing human-readable and (where possible) URI-friendly strings for SMP and SMP agent protocols+class StrEncoding a where+  {-# MINIMAL strEncode, (strDecode | strP) #-}+  strEncode :: a -> ByteString++  -- Please note - if you only specify strDecode, it will use base64urlP as default parser before decoding the string+  strDecode :: ByteString -> Either String a+  strDecode = parseAll strP+  strP :: Parser a+  strP = strDecode <$?> base64urlP++-- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings+instance StrEncoding ByteString where+  strEncode = U.encode+  strDecode = U.decode+  strP = base64urlP++base64urlP :: Parser ByteString+base64urlP = do+  str <- A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')+  pad <- A.takeWhile (== '=')+  either fail pure $ U.decode (str <> pad)++newtype Str = Str {unStr :: ByteString}+  deriving (Eq, Show)++instance StrEncoding Str where+  strEncode = unStr+  strP = Str <$> A.takeTill (== ' ') <* optional A.space++instance ToJSON Str where+  toJSON (Str s) = strToJSON s+  toEncoding (Str s) = strToJEncoding s++instance FromJSON Str where+  parseJSON = fmap Str . strParseJSON "Str"++instance StrEncoding a => StrEncoding (Maybe a) where+  strEncode = maybe "" strEncode+  strP = optional strP++instance StrEncoding Word16 where+  strEncode = B.pack . show+  strP = A.decimal++-- lists encode/parse as comma-separated strings+strEncodeList :: StrEncoding a => [a] -> ByteString+strEncodeList = B.intercalate "," . map strEncode++strListP :: StrEncoding a => Parser [a]+strListP = listItem `A.sepBy'` A.char ','++-- relies on sepBy1 never returning an empty list+instance StrEncoding a => StrEncoding (L.NonEmpty a) where+  strEncode = strEncodeList . L.toList+  strP = L.fromList <$> listItem `A.sepBy1'` A.char ','++listItem :: StrEncoding a => Parser a+listItem = parseAll strP <$?> A.takeTill (== ',')++instance (StrEncoding a, StrEncoding b) => StrEncoding (a, b) where+  strEncode (a, b) = B.unwords [strEncode a, strEncode b]+  strP = (,) <$> strP_ <*> strP++instance (StrEncoding a, StrEncoding b, StrEncoding c) => StrEncoding (a, b, c) where+  strEncode (a, b, c) = B.unwords [strEncode a, strEncode b, strEncode c]+  strP = (,,) <$> strP_ <*> strP_ <*> strP++instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d) => StrEncoding (a, b, c, d) where+  strEncode (a, b, c, d) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d]+  strP = (,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP++instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncoding e) => StrEncoding (a, b, c, d, e) where+  strEncode (a, b, c, d, e) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d, strEncode e]+  strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP++strP_ :: StrEncoding a => Parser a+strP_ = strP <* A.space++strToJSON :: StrEncoding a => a -> J.Value+strToJSON = J.String . decodeLatin1 . strEncode++strToJEncoding :: StrEncoding a => a -> J.Encoding+strToJEncoding = JE.text . decodeLatin1 . strEncode++strParseJSON :: StrEncoding a => String -> J.Value -> JT.Parser a+strParseJSON name = J.withText name $ either fail pure . parseAll strP . encodeUtf8
src/Simplex/Messaging/Parsers.hs view
@@ -3,11 +3,11 @@  module Simplex.Messaging.Parsers where +import Control.Monad.Trans.Except import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import Data.ByteString.Base64-import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isAlphaNum)@@ -22,16 +22,7 @@ import Text.Read (readMaybe)  base64P :: Parser ByteString-base64P = decode <$?> base64StringP--base64StringP :: Parser ByteString-base64StringP = paddedBase64 rawBase64P--base64UriP :: Parser ByteString-base64UriP = U.decode <$?> base64UriStringP--base64UriStringP :: Parser ByteString-base64UriStringP = paddedBase64 rawBase64UriP+base64P = decode <$?> paddedBase64 rawBase64P  paddedBase64 :: Parser ByteString -> Parser ByteString paddedBase64 raw = (<>) <$> raw <*> pad@@ -41,8 +32,8 @@ rawBase64P :: Parser ByteString rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/') -rawBase64UriP :: Parser ByteString-rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')+-- rawBase64UriP :: Parser ByteString+-- rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')  tsISO8601P :: Parser UTCTime tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd@@ -53,6 +44,12 @@ parseAll :: Parser a -> (ByteString -> Either String a) parseAll parser = A.parseOnly (parser <* A.endOfInput) +parseE :: (String -> e) -> Parser a -> (ByteString -> ExceptT e IO a)+parseE err parser = except . first err . parseAll parser++parseE' :: (String -> e) -> Parser a -> (ByteString -> ExceptT e IO a)+parseE' err parser = except . first err . A.parseOnly parser+ parseRead :: Read a => Parser ByteString -> Parser a parseRead = (>>= maybe (fail "cannot read") pure . readMaybe . B.unpack) @@ -72,9 +69,12 @@ parseString p = either error id . p . B.pack  blobFieldParser :: Typeable k => Parser k -> FieldParser k-blobFieldParser p = \case+blobFieldParser = blobFieldDecoder . parseAll++blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k+blobFieldDecoder dec = \case   f@(Field (SQLBlob b) _) ->-    case parseAll p b of+    case dec b of       Right k -> Ok k       Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)   f -> returnError ConversionFailed f "expecting SQLBlob column type"
src/Simplex/Messaging/Protocol.hs view
@@ -1,11 +1,17 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}@@ -23,163 +29,428 @@ -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md module Simplex.Messaging.Protocol-  ( -- * SMP protocol types+  ( -- * SMP protocol parameters+    smpClientVersion,+    smpClientVRange,+    maxMessageLength,+    e2eEncConfirmationLength,+    e2eEncMessageLength,++    -- * SMP protocol types+    Protocol,     Command (..),     Party (..),     Cmd (..),+    BrokerMsg (..),     SParty (..),+    PartyI (..),+    QueueIdsKeys (..),     ErrorType (..),     CommandError (..),     Transmission,     SignedTransmission,-    SignedTransmissionOrError,-    RawTransmission,+    SentRawTransmission,     SignedRawTransmission,+    ClientMsgEnvelope (..),+    PubHeader (..),+    ClientMessage (..),+    PrivHeader (..),+    SMPServer (..),+    SrvLoc (..),     CorrId (..),     QueueId,     RecipientId,     SenderId,-    RecipientPrivateKey,-    RecipientPublicKey,-    SenderPrivateKey,-    SenderPublicKey,-    Encoded,+    NotifierId,+    RcvPrivateSignKey,+    RcvPublicVerifyKey,+    RcvPublicDhKey,+    RcvDhSecret,+    SndPrivateSignKey,+    SndPublicVerifyKey,+    NtfPrivateSignKey,+    NtfPublicVerifyKey,     MsgId,     MsgBody,      -- * Parse and serialize-    serializeTransmission,-    serializeCommand,-    serializeErrorType,+    encodeTransmission,     transmissionP,-    commandP,-    errorTypeP,+    encodeProtocol,      -- * TCP transport functions     tPut,     tGet,-    fromClient,-    fromServer,++    -- * exports for tests+    CommandTag (..),+    BrokerMsgTag (..),   ) where -import Control.Applicative ((<|>))-import Control.Monad+import Control.Applicative (optional, (<|>)) import Control.Monad.Except import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A-import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B-import Data.Functor (($>)) import Data.Kind+import Data.Maybe (isNothing) import Data.String-import Data.Time.Clock-import Data.Time.ISO8601+import Data.Time.Clock.System (SystemTime)+import Data.Type.Equality import GHC.Generics (Generic) import Generic.Random (genericArbitraryU)+import Network.Socket (HostName, ServiceName) import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Encoding+import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers-import Simplex.Messaging.Transport (THandle, Transport, TransportError (..), tGetEncrypted, tPutEncrypted)-import Simplex.Messaging.Util+import Simplex.Messaging.Transport (THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock)+import Simplex.Messaging.Util ((<$?>))+import Simplex.Messaging.Version import Test.QuickCheck (Arbitrary (..)) --- | SMP protocol participants.-data Party = Broker | Recipient | Sender+smpClientVersion :: Version+smpClientVersion = 1++smpClientVRange :: VersionRange+smpClientVRange = mkVersionRange 1 smpClientVersion++maxMessageLength :: Int+maxMessageLength = 16088++-- it is shorter to allow per-queue e2e encryption DH key in the "public" header+e2eEncConfirmationLength :: Int+e2eEncConfirmationLength = 15936++e2eEncMessageLength :: Int+e2eEncMessageLength = 16032++-- | SMP protocol clients+data Party = Recipient | Sender | Notifier   deriving (Show) --- | Singleton types for SMP protocol participants.+-- | Singleton types for SMP protocol clients data SParty :: Party -> Type where-  SBroker :: SParty Broker   SRecipient :: SParty Recipient   SSender :: SParty Sender+  SNotifier :: SParty Notifier -deriving instance Show (SParty a)+instance TestEquality SParty where+  testEquality SRecipient SRecipient = Just Refl+  testEquality SSender SSender = Just Refl+  testEquality SNotifier SNotifier = Just Refl+  testEquality _ _ = Nothing --- | Type for command or response of any participant.-data Cmd = forall a. Cmd (SParty a) (Command a)+deriving instance Show (SParty p) -deriving instance Show Cmd+class PartyI (p :: Party) where sParty :: SParty p --- | SMP transmission without signature.-type Transmission = (CorrId, QueueId, Cmd)+instance PartyI Recipient where sParty = SRecipient --- | SMP transmission with signature.-type SignedTransmission = (C.Signature, Transmission)+instance PartyI Sender where sParty = SSender -type TransmissionOrError = (CorrId, QueueId, Either ErrorType Cmd)+instance PartyI Notifier where sParty = SNotifier --- | signed parsed transmission, with parsing error.-type SignedTransmissionOrError = (C.Signature, TransmissionOrError)+-- | Type for client command of any participant.+data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p) --- | unparsed SMP transmission with signature.-type RawTransmission = (ByteString, ByteString, ByteString, ByteString)+deriving instance Show Cmd +-- | Parsed SMP transmission without signature, size and session ID.+type Transmission c = (CorrId, QueueId, c)++-- | signed parsed transmission, with original raw bytes and parsing error.+type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c))++type Signed = ByteString+ -- | unparsed SMP transmission with signature.-type SignedRawTransmission = (C.Signature, ByteString)+data RawTransmission = RawTransmission+  { signature :: ByteString,+    signed :: ByteString,+    sessId :: ByteString,+    corrId :: ByteString,+    queueId :: ByteString,+    command :: ByteString+  } +-- | unparsed sent SMP transmission with signature, without session ID.+type SignedRawTransmission = (Maybe C.ASignature, ByteString, ByteString, ByteString)++-- | unparsed sent SMP transmission with signature.+type SentRawTransmission = (Maybe C.ASignature, ByteString)+ -- | SMP queue ID for the recipient. type RecipientId = QueueId  -- | SMP queue ID for the sender. type SenderId = QueueId +-- | SMP queue ID for notifications.+type NotifierId = QueueId+ -- | SMP queue ID on the server.-type QueueId = Encoded+type QueueId = ByteString --- | Parameterized type for SMP protocol commands from all participants.-data Command (a :: Party) where+-- | Parameterized type for SMP protocol commands from all clients.+data Command (p :: Party) where   -- SMP recipient commands-  NEW :: RecipientPublicKey -> Command Recipient+  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient   SUB :: Command Recipient-  KEY :: SenderPublicKey -> Command Recipient+  KEY :: SndPublicVerifyKey -> Command Recipient+  NKEY :: NtfPublicVerifyKey -> Command Recipient   ACK :: Command Recipient   OFF :: Command Recipient   DEL :: Command Recipient   -- SMP sender commands   SEND :: MsgBody -> Command Sender   PING :: Command Sender-  -- SMP broker commands (responses, messages, notifications)-  IDS :: RecipientId -> SenderId -> Command Broker-  MSG :: MsgId -> UTCTime -> MsgBody -> Command Broker-  END :: Command Broker-  OK :: Command Broker-  ERR :: ErrorType -> Command Broker-  PONG :: Command Broker+  -- SMP notification subscriber commands+  NSUB :: Command Notifier -deriving instance Show (Command a)+deriving instance Show (Command p) -deriving instance Eq (Command a)+deriving instance Eq (Command p) --- | Base-64 encoded string.-type Encoded = ByteString+data BrokerMsg where+  -- SMP broker messages (responses, client messages, notifications)+  IDS :: QueueIdsKeys -> BrokerMsg+  MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg+  NID :: NotifierId -> BrokerMsg+  NMSG :: BrokerMsg+  END :: BrokerMsg+  OK :: BrokerMsg+  ERR :: ErrorType -> BrokerMsg+  PONG :: BrokerMsg+  deriving (Eq, Show) +-- * SMP command tags++data CommandTag (p :: Party) where+  NEW_ :: CommandTag Recipient+  SUB_ :: CommandTag Recipient+  KEY_ :: CommandTag Recipient+  NKEY_ :: CommandTag Recipient+  ACK_ :: CommandTag Recipient+  OFF_ :: CommandTag Recipient+  DEL_ :: CommandTag Recipient+  SEND_ :: CommandTag Sender+  PING_ :: CommandTag Sender+  NSUB_ :: CommandTag Notifier++data CmdTag = forall p. PartyI p => CT (SParty p) (CommandTag p)++deriving instance Show (CommandTag p)++deriving instance Show CmdTag++data BrokerMsgTag+  = IDS_+  | MSG_+  | NID_+  | NMSG_+  | END_+  | OK_+  | ERR_+  | PONG_+  deriving (Show)++class ProtocolMsgTag t where+  decodeTag :: ByteString -> Maybe t++messageTagP :: ProtocolMsgTag t => Parser t+messageTagP =+  maybe (fail "bad command") pure . decodeTag+    =<< (A.takeTill (== ' ') <* optional A.space)++instance PartyI p => Encoding (CommandTag p) where+  smpEncode = \case+    NEW_ -> "NEW"+    SUB_ -> "SUB"+    KEY_ -> "KEY"+    NKEY_ -> "NKEY"+    ACK_ -> "ACK"+    OFF_ -> "OFF"+    DEL_ -> "DEL"+    SEND_ -> "SEND"+    PING_ -> "PING"+    NSUB_ -> "NSUB"+  smpP = messageTagP++instance ProtocolMsgTag CmdTag where+  decodeTag = \case+    "NEW" -> Just $ CT SRecipient NEW_+    "SUB" -> Just $ CT SRecipient SUB_+    "KEY" -> Just $ CT SRecipient KEY_+    "NKEY" -> Just $ CT SRecipient NKEY_+    "ACK" -> Just $ CT SRecipient ACK_+    "OFF" -> Just $ CT SRecipient OFF_+    "DEL" -> Just $ CT SRecipient DEL_+    "SEND" -> Just $ CT SSender SEND_+    "PING" -> Just $ CT SSender PING_+    "NSUB" -> Just $ CT SNotifier NSUB_+    _ -> Nothing++instance Encoding CmdTag where+  smpEncode (CT _ t) = smpEncode t+  smpP = messageTagP++instance PartyI p => ProtocolMsgTag (CommandTag p) where+  decodeTag s = decodeTag s >>= (\(CT _ t) -> checkParty' t)++instance Encoding BrokerMsgTag where+  smpEncode = \case+    IDS_ -> "IDS"+    MSG_ -> "MSG"+    NID_ -> "NID"+    NMSG_ -> "NMSG"+    END_ -> "END"+    OK_ -> "OK"+    ERR_ -> "ERR"+    PONG_ -> "PONG"+  smpP = messageTagP++instance ProtocolMsgTag BrokerMsgTag where+  decodeTag = \case+    "IDS" -> Just IDS_+    "MSG" -> Just MSG_+    "NID" -> Just NID_+    "NMSG" -> Just NMSG_+    "END" -> Just END_+    "OK" -> Just OK_+    "ERR" -> Just ERR_+    "PONG" -> Just PONG_+    _ -> Nothing++-- | SMP message body format+data ClientMsgEnvelope = ClientMsgEnvelope+  { cmHeader :: PubHeader,+    cmNonce :: C.CbNonce,+    cmEncBody :: ByteString+  }+  deriving (Show)++data PubHeader = PubHeader+  { phVersion :: Version,+    phE2ePubDhKey :: Maybe C.PublicKeyX25519+  }+  deriving (Show)++instance Encoding PubHeader where+  smpEncode (PubHeader v k) = smpEncode (v, k)+  smpP = PubHeader <$> smpP <*> smpP++instance Encoding ClientMsgEnvelope where+  smpEncode ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody} =+    smpEncode (cmHeader, cmNonce, Tail cmEncBody)+  smpP = do+    (cmHeader, cmNonce, Tail cmEncBody) <- smpP+    pure ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}++data ClientMessage = ClientMessage PrivHeader ByteString++data PrivHeader+  = PHConfirmation C.APublicVerifyKey+  | PHEmpty+  deriving (Show)++instance Encoding PrivHeader where+  smpEncode = \case+    PHConfirmation k -> "K" <> smpEncode k+    PHEmpty -> "_"+  smpP =+    A.anyChar >>= \case+      'K' -> PHConfirmation <$> smpP+      '_' -> pure PHEmpty+      _ -> fail "invalid PrivHeader"++instance Encoding ClientMessage where+  smpEncode (ClientMessage h msg) = smpEncode h <> msg+  smpP = ClientMessage <$> smpP <*> A.takeByteString++-- | SMP server location and transport key digest (hash).+data SMPServer = SMPServer+  { host :: HostName,+    port :: ServiceName,+    keyHash :: C.KeyHash+  }+  deriving (Eq, Ord, Show)++instance IsString SMPServer where+  fromString = parseString strDecode++instance Encoding SMPServer where+  smpEncode SMPServer {host, port, keyHash} =+    smpEncode (host, port, keyHash)+  smpP = do+    (host, port, keyHash) <- smpP+    pure SMPServer {host, port, keyHash}++instance StrEncoding SMPServer where+  strEncode SMPServer {host, port, keyHash} =+    "smp://" <> strEncode keyHash <> "@" <> strEncode (SrvLoc host port)+  strP = do+    _ <- "smp://"+    keyHash <- strP <* A.char '@'+    SrvLoc host port <- strP+    pure SMPServer {host, port, keyHash}++data SrvLoc = SrvLoc HostName ServiceName+  deriving (Eq, Ord, Show)++instance StrEncoding SrvLoc where+  strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port+  strP = SrvLoc <$> host <*> (port <|> pure "")+    where+      host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")+      port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)+ -- | Transmission correlation ID.------ A newtype to avoid accidentally changing order of transmission parts. newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)  instance IsString CorrId where   fromString = CorrId . fromString +-- | Queue IDs and keys+data QueueIdsKeys = QIK+  { rcvId :: RecipientId,+    sndId :: SenderId,+    rcvPublicDhKey :: RcvPublicDhKey+  }+  deriving (Eq, Show)+ -- | Recipient's private key used by the recipient to authorize (sign) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key.-type RecipientPrivateKey = C.SafePrivateKey+type RcvPrivateSignKey = C.APrivateSignKey  -- | Recipient's public key used by SMP server to verify authorization of SMP commands.-type RecipientPublicKey = C.PublicKey+type RcvPublicVerifyKey = C.APublicVerifyKey +-- | Public key used for DH exchange to encrypt message bodies from server to recipient+type RcvPublicDhKey = C.PublicKeyX25519++-- | DH Secret used to encrypt message bodies from server to recipient+type RcvDhSecret = C.DhSecretX25519+ -- | Sender's private key used by the recipient to authorize (sign) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key.-type SenderPrivateKey = C.SafePrivateKey+type SndPrivateSignKey = C.APrivateSignKey  -- | Sender's public key used by SMP server to verify authorization of SMP commands.-type SenderPublicKey = C.PublicKey+type SndPublicVerifyKey = C.APublicVerifyKey +-- | Private key used by push notifications server to authorize (sign) LSTN command.+type NtfPrivateSignKey = C.APrivateSignKey++-- | Public key used by SMP server to verify authorization of LSTN command sent by push notifications server.+type NtfPublicVerifyKey = C.APublicVerifyKey+ -- | SMP message server ID.-type MsgId = Encoded+type MsgId = ByteString  -- | SMP message body. type MsgBody = ByteString@@ -188,6 +459,8 @@ data ErrorType   = -- | incorrect block format, encoding or signature size     BLOCK+  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)+    SESSION   | -- | SMP command is unknown or has invalid syntax     CMD CommandError   | -- | command authorization error - bad signature or non-existing SMP queue@@ -196,6 +469,8 @@     QUOTA   | -- | ACK command is sent without message to be acknowledged     NO_MSG+  | -- | sent message is too large (> maxMessageLength = 16078 bytes)+    LARGE_MSG   | -- | internal server error     INTERNAL   | -- | used internally, never returned by the server (to be removed)@@ -204,10 +479,8 @@  -- | SMP command error type. data CommandError-  = -- | server response sent from client or vice versa-    PROHIBITED-  | -- | bad RSA key size in NEW or KEY commands (only 1024, 2048 and 4096 bits keys are allowed)-    KEY_SIZE+  = -- | unknown command+    UNKNOWN   | -- | error parsing command     SYNTAX   | -- | transmission has no required credentials (signature or queue ID)@@ -225,156 +498,217 @@ -- | SMP transmission parser. transmissionP :: Parser RawTransmission transmissionP = do-  signature <- segment-  corrId <- segment-  queueId <- segment-  command <- A.takeByteString-  return (signature, corrId, queueId, command)+  signature <- smpP+  signed <- A.takeByteString+  either fail pure $ parseAll (trn signature signed) signed   where-    segment = A.takeTill (== ' ') <* " "+    trn signature signed = do+      sessId <- smpP+      corrId <- smpP+      queueId <- smpP+      command <- A.takeByteString+      pure RawTransmission {signature, signed, sessId, corrId, queueId, command} --- | SMP command parser.-commandP :: Parser Cmd-commandP =-  "NEW " *> newCmd-    <|> "IDS " *> idsResp-    <|> "SUB" $> Cmd SRecipient SUB-    <|> "KEY " *> keyCmd-    <|> "ACK" $> Cmd SRecipient ACK-    <|> "OFF" $> Cmd SRecipient OFF-    <|> "DEL" $> Cmd SRecipient DEL-    <|> "SEND " *> sendCmd-    <|> "PING" $> Cmd SSender PING-    <|> "MSG " *> message-    <|> "END" $> Cmd SBroker END-    <|> "OK" $> Cmd SBroker OK-    <|> "ERR " *> serverError-    <|> "PONG" $> Cmd SBroker PONG-  where-    newCmd = Cmd SRecipient . NEW <$> C.pubKeyP-    idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P)-    keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP-    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-      size <- A.decimal <* A.space-      Cmd SBroker . MSG msgId ts <$> A.take size <* A.space-    serverError = Cmd SBroker . ERR <$> errorTypeP+class Protocol msg where+  type Tag msg+  encodeProtocol :: msg -> ByteString+  protocolP :: Tag msg -> Parser msg+  checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg --- TODO ignore the end of block, no need to parse it+instance PartyI p => Protocol (Command p) where+  type Tag (Command p) = CommandTag p+  encodeProtocol = \case+    NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)+    SUB -> e SUB_+    KEY k -> e (KEY_, ' ', k)+    NKEY k -> e (NKEY_, ' ', k)+    ACK -> e ACK_+    OFF -> e OFF_+    DEL -> e DEL_+    SEND msg -> e (SEND_, ' ', Tail msg)+    PING -> e PING_+    NSUB -> e NSUB_+    where+      e :: Encoding a => a -> ByteString+      e = smpEncode --- | Parse SMP command.-parseCommand :: ByteString -> Either ErrorType Cmd-parseCommand = parse (commandP <* " " <* A.takeByteString) $ CMD SYNTAX+  protocolP tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP (CT (sParty @p) tag) --- | Serialize SMP command.-serializeCommand :: Cmd -> ByteString-serializeCommand = \case-  Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializePubKey rKey-  Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializePubKey sKey-  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]-  Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId]-  Cmd SBroker (ERR err) -> "ERR " <> serializeErrorType err-  Cmd SBroker resp -> bshow resp-  where-    serializeMsg msgBody = bshow (B.length msgBody) <> " " <> msgBody <> " "+  checkCredentials (sig, _, queueId, _) cmd = case cmd of+    -- NEW must have signature but NOT queue ID+    NEW {}+      | isNothing sig -> Left $ CMD NO_AUTH+      | not (B.null queueId) -> Left $ CMD HAS_AUTH+      | otherwise -> Right cmd+    -- SEND must have queue ID, signature is not always required+    SEND _+      | B.null queueId -> Left $ CMD NO_QUEUE+      | otherwise -> Right cmd+    -- PING must not have queue ID or signature+    PING+      | isNothing sig && B.null queueId -> Right cmd+      | otherwise -> Left $ CMD HAS_AUTH+    -- other client commands must have both signature and queue ID+    _+      | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH+      | otherwise -> Right cmd --- | SMP error parser.-errorTypeP :: Parser ErrorType-errorTypeP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1+instance Protocol Cmd where+  type Tag Cmd = CmdTag+  encodeProtocol (Cmd _ c) = encodeProtocol c --- | Serialize SMP error.-serializeErrorType :: ErrorType -> ByteString-serializeErrorType = bshow+  protocolP = \case+    CT SRecipient tag ->+      Cmd SRecipient <$> case tag of+        NEW_ -> NEW <$> _smpP <*> smpP+        SUB_ -> pure SUB+        KEY_ -> KEY <$> _smpP+        NKEY_ -> NKEY <$> _smpP+        ACK_ -> pure ACK+        OFF_ -> pure OFF+        DEL_ -> pure DEL+    CT SSender tag ->+      Cmd SSender <$> case tag of+        SEND_ -> SEND . unTail <$> _smpP+        PING_ -> pure PING+    CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB --- | Send signed SMP transmission to TCP transport.-tPut :: Transport c => THandle c -> SignedRawTransmission -> IO (Either TransportError ())-tPut th (C.Signature sig, t) =-  tPutEncrypted th $ encode sig <> " " <> t <> " "+  checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c --- | Serialize SMP transmission.-serializeTransmission :: Transmission -> ByteString-serializeTransmission (CorrId corrId, queueId, command) =-  B.intercalate " " [corrId, encode queueId, serializeCommand command]+instance Protocol BrokerMsg where+  type Tag BrokerMsg = BrokerMsgTag+  encodeProtocol = \case+    IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)+    MSG msgId ts msgBody -> e (MSG_, ' ', msgId, ts, Tail msgBody)+    NID nId -> e (NID_, ' ', nId)+    NMSG -> e NMSG_+    END -> e END_+    OK -> e OK_+    ERR err -> e (ERR_, ' ', err)+    PONG -> e PONG_+    where+      e :: Encoding a => a -> ByteString+      e = smpEncode --- | Validate that it is an SMP client command, used with 'tGet' by 'Simplex.Messaging.Server'.-fromClient :: Cmd -> Either ErrorType Cmd-fromClient = \case-  Cmd SBroker _ -> Left $ CMD PROHIBITED-  cmd -> Right cmd+  protocolP = \case+    MSG_ -> MSG <$> _smpP <*> smpP <*> (unTail <$> smpP)+    IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP)+    NID_ -> NID <$> _smpP+    NMSG_ -> pure NMSG+    END_ -> pure END+    OK_ -> pure OK+    ERR_ -> ERR <$> _smpP+    PONG_ -> pure PONG --- | Validate that it is an SMP server command, used with 'tGet' by 'Simplex.Messaging.Client'.-fromServer :: Cmd -> Either ErrorType Cmd-fromServer = \case-  cmd@(Cmd SBroker _) -> Right cmd-  _ -> Left $ CMD PROHIBITED+  checkCredentials (_, _, queueId, _) cmd = case cmd of+    -- IDS response must not have queue ID+    IDS _ -> Right cmd+    -- ERR response does not always have queue ID+    ERR _ -> Right cmd+    -- PONG response must not have queue ID+    PONG+      | B.null queueId -> Right cmd+      | otherwise -> Left $ CMD HAS_AUTH+    -- other broker responses must have queue ID+    _+      | B.null queueId -> Left $ CMD NO_QUEUE+      | otherwise -> Right cmd --- | Receive and parse transmission from the TCP transport.+_smpP :: Encoding a => Parser a+_smpP = A.space *> smpP++-- | Parse SMP protocol commands and broker messages+parseProtocol :: (Protocol msg, ProtocolMsgTag (Tag msg)) => ByteString -> Either ErrorType msg+parseProtocol s =+  let (tag, params) = B.break (== ' ') s+   in case decodeTag tag of+        Just cmd -> parse (protocolP cmd) (CMD SYNTAX) params+        Nothing -> Left $ CMD UNKNOWN++checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)+checkParty c = case testEquality (sParty @p) (sParty @p') of+  Just Refl -> Right c+  Nothing -> Left "bad command party"++checkParty' :: forall t p p'. (PartyI p, PartyI p') => t p' -> Maybe (t p)+checkParty' c = case testEquality (sParty @p) (sParty @p') of+  Just Refl -> Just c+  _ -> Nothing++instance Encoding ErrorType where+  smpEncode = \case+    BLOCK -> "BLOCK"+    SESSION -> "SESSION"+    CMD err -> "CMD " <> smpEncode err+    AUTH -> "AUTH"+    QUOTA -> "QUOTA"+    NO_MSG -> "NO_MSG"+    LARGE_MSG -> "LARGE_MSG"+    INTERNAL -> "INTERNAL"+    DUPLICATE_ -> "DUPLICATE_"++  smpP =+    A.takeTill (== ' ') >>= \case+      "BLOCK" -> pure BLOCK+      "SESSION" -> pure SESSION+      "CMD" -> CMD <$> _smpP+      "AUTH" -> pure AUTH+      "QUOTA" -> pure QUOTA+      "NO_MSG" -> pure NO_MSG+      "LARGE_MSG" -> pure LARGE_MSG+      "INTERNAL" -> pure INTERNAL+      "DUPLICATE_" -> pure DUPLICATE_+      _ -> fail "bad error type"++instance Encoding CommandError where+  smpEncode e = case e of+    UNKNOWN -> "UNKNOWN"+    SYNTAX -> "SYNTAX"+    NO_AUTH -> "NO_AUTH"+    HAS_AUTH -> "HAS_AUTH"+    NO_QUEUE -> "NO_QUEUE"+  smpP =+    A.takeTill (== ' ') >>= \case+      "UNKNOWN" -> pure UNKNOWN+      "SYNTAX" -> pure SYNTAX+      "NO_AUTH" -> pure NO_AUTH+      "HAS_AUTH" -> pure HAS_AUTH+      "NO_QUEUE" -> pure NO_QUEUE+      _ -> fail "bad command error type"++-- | Send signed SMP transmission to TCP transport.+tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())+tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t++encodeTransmission :: Protocol c => ByteString -> Transmission c -> ByteString+encodeTransmission sessionId (CorrId corrId, queueId, command) =+  smpEncode (sessionId, corrId, queueId) <> encodeProtocol command++-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding). tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)-tGetParse th = (>>= parse transmissionP TEBadBlock) <$> tGetEncrypted th+tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th --- | Receive client and server transmissions.------ The first argument is used to limit allowed senders.--- 'fromClient' or 'fromServer' should be used here.-tGet :: forall c m. (Transport c, MonadIO m) => (Cmd -> Either ErrorType Cmd) -> THandle c -> m SignedTransmissionOrError-tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate+-- | Receive client and server transmissions (determined by `cmd` type).+tGet ::+  forall cmd c m.+  (Protocol cmd, ProtocolMsgTag (Tag cmd), Transport c, MonadIO m) =>+  THandle c ->+  m (SignedTransmission cmd)+tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate   where-    decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError+    decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)     decodeParseValidate = \case-      Right (signature, corrId, queueId, command) ->-        let decodedTransmission = liftM2 (,corrId,,command) (validSig =<< decode signature) (decode queueId)-         in either (const $ tError corrId) tParseValidate decodedTransmission+      Right RawTransmission {signature, signed, sessId, corrId, queueId, command}+        | sessId == sessionId ->+          let decodedTransmission = (,corrId,queueId,command) <$> C.decodeSignature signature+           in either (const $ tError corrId) (tParseValidate signed) decodedTransmission+        | otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION))       Left _ -> tError "" -    validSig :: ByteString -> Either String ByteString-    validSig sig-      | B.null sig || C.validKeySize (B.length sig) = Right sig-      | otherwise = Left "invalid signature size"--    tError :: ByteString -> m SignedTransmissionOrError-    tError corrId = return (C.Signature "", (CorrId corrId, "", Left BLOCK))--    tParseValidate :: RawTransmission -> m SignedTransmissionOrError-    tParseValidate t@(sig, corrId, queueId, command) = do-      let cmd = parseCommand command >>= fromParty >>= tCredentials t-      return (C.Signature sig, (CorrId corrId, queueId, cmd))+    tError :: ByteString -> m (SignedTransmission cmd)+    tError corrId = pure (Nothing, "", (CorrId corrId, "", Left BLOCK)) -    tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd-    tCredentials (signature, _, queueId, _) cmd = case cmd of-      -- IDS response must not have queue ID-      Cmd SBroker (IDS _ _) -> Right cmd-      -- ERR response does not always have queue ID-      Cmd SBroker (ERR _) -> Right cmd-      -- PONG response must not have queue ID-      Cmd SBroker PONG-        | B.null queueId -> Right cmd-        | otherwise -> Left $ CMD HAS_AUTH-      -- other responses must have queue ID-      Cmd SBroker _-        | B.null queueId -> Left $ CMD NO_QUEUE-        | otherwise -> Right cmd-      -- NEW must have signature but NOT queue ID-      Cmd SRecipient (NEW _)-        | B.null signature -> Left $ CMD NO_AUTH-        | not (B.null queueId) -> Left $ CMD HAS_AUTH-        | otherwise -> Right cmd-      -- SEND must have queue ID, signature is not always required-      Cmd SSender (SEND _)-        | B.null queueId -> Left $ CMD NO_QUEUE-        | otherwise -> Right cmd-      -- PING must not have queue ID or signature-      Cmd SSender PING-        | B.null queueId && B.null signature -> Right cmd-        | otherwise -> Left $ CMD HAS_AUTH-      -- other client commands must have both signature and queue ID-      Cmd SRecipient _-        | B.null signature || B.null queueId -> Left $ CMD NO_AUTH-        | otherwise -> Right cmd+    tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd)+    tParseValidate signed t@(sig, corrId, queueId, command) = do+      let cmd = parseProtocol command >>= checkCredentials t+      pure (sig, signed, (CorrId corrId, queueId, cmd))
src/Simplex/Messaging/Server.hs view
@@ -35,7 +35,9 @@ import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import qualified Data.Map.Strict as M-import Data.Time.Clock+import Data.Maybe (isNothing)+import Data.Time.Clock.System (getSystemTime)+import Data.Type.Equality import Network.Socket (ServiceName) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol@@ -72,46 +74,61 @@     smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' ()     smpServer = do       s <- asks server-      raceAny_ (serverThread s : map runServer transports)+      raceAny_+        ( serverThread s subscribedQ subscribers subscriptions cancelSub :+          serverThread s ntfSubscribedQ notifiers ntfSubscriptions (\_ -> pure ()) :+          map runServer transports+        )         `finally` withLog closeStoreLog      runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()-    runServer (tcpPort, ATransport t) = runTransportServer started tcpPort (runClient t)+    runServer (tcpPort, ATransport t) = do+      serverParams <- asks tlsServerParams+      runTransportServer started tcpPort serverParams (runClient t) -    serverThread :: MonadUnliftIO m' => Server -> m' ()-    serverThread Server {subscribedQ, subscribers} = forever $ do-      atomically updateSubscribers >>= \case-        Just (rId, Client {rcvQ}) ->-          void . forkIO . atomically $-            writeTBQueue rcvQ (CorrId "", rId, Cmd SBroker END)-        _ -> pure ()+    serverThread ::+      forall m' s.+      MonadUnliftIO m' =>+      Server ->+      (Server -> TBQueue (QueueId, Client)) ->+      (Server -> TVar (M.Map QueueId Client)) ->+      (Client -> TVar (M.Map QueueId s)) ->+      (s -> m' ()) ->+      m' ()+    serverThread s subQ subs clientSubs unsub = forever $ do+      atomically updateSubscribers+        >>= fmap join . mapM endPreviousSubscriptions+        >>= mapM_ unsub       where-        updateSubscribers :: STM (Maybe (RecipientId, Client))+        updateSubscribers :: STM (Maybe (QueueId, Client))         updateSubscribers = do-          (rId, c) <- readTBQueue subscribedQ-          stateTVar subscribers (\cs -> (M.lookup rId cs, M.insert rId c cs)) >>= \case-            Just c' -> clientToBeNotified rId c c'-            _ -> pure Nothing-        clientToBeNotified :: RecipientId -> Client -> Client -> STM (Maybe (RecipientId, Client))-        clientToBeNotified rId c c'@Client {connected}-          | clientId c /= clientId c' = do-            yes <- readTVar connected-            pure $ if yes then Just (rId, c') else Nothing-          | otherwise = pure Nothing+          (qId, clnt) <- readTBQueue $ subQ s+          let clientToBeNotified = \c' ->+                if sameClientSession clnt c'+                  then pure Nothing+                  else do+                    yes <- readTVar $ connected c'+                    pure $ if yes then Just (qId, c') else Nothing+          stateTVar (subs s) (\cs -> (M.lookup qId cs, M.insert qId clnt cs))+            >>= fmap join . mapM clientToBeNotified+        endPreviousSubscriptions :: (QueueId, Client) -> m' (Maybe s)+        endPreviousSubscriptions (qId, c) = do+          void . forkIO . atomically $+            writeTBQueue (sndQ c) (CorrId "", qId, END)+          atomically . stateTVar (clientSubs c) $ \ss -> (M.lookup qId ss, M.delete qId ss) -runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()-runClient _ h = do-  keyPair <- asks serverKeyPair-  ServerConfig {blockSize} <- asks config-  liftIO (runExceptT $ serverHandshake h blockSize keyPair) >>= \case-    Right th -> runClientTransport th-    Left _ -> pure ()+    runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()+    runClient _ h = do+      kh <- asks serverIdentity+      liftIO (runExceptT $ serverHandshake h kh) >>= \case+        Right th -> runClientTransport th+        Left _ -> pure ()  runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()-runClientTransport th = do+runClientTransport th@THandle {sessionId} = do   q <- asks $ tbqSize . config+  c <- atomically $ newClient q sessionId   s <- asks server-  c <- atomically $ newClient s q   raceAny_ [send th c, client c s, receive th c]     `finally` clientDisconnected c @@ -125,122 +142,130 @@   where     deleteCurrentClient :: Client -> Maybe Client     deleteCurrentClient c'-      | clientId c == clientId c' = Nothing+      | sameClientSession c c' = Nothing       | otherwise = Just c' +sameClientSession :: Client -> Client -> Bool+sameClientSession Client {sessionId} Client {sessionId = s'} = sessionId == s'+ cancelSub :: MonadUnliftIO m => Sub -> m () cancelSub = \case   Sub {subThread = SubThread t} -> killThread t   _ -> return ()  receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()-receive h Client {rcvQ} = forever $ do-  (signature, (corrId, queueId, cmdOrError)) <- tGet fromClient h-  t <- case cmdOrError of-    Left e -> return . mkResp corrId queueId $ ERR e-    Right cmd -> verifyTransmission (signature, (corrId, queueId, cmd))-  atomically $ writeTBQueue rcvQ t+receive th Client {rcvQ, sndQ} = forever $ do+  (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th+  case cmdOrError of+    Left e -> write sndQ (corrId, queueId, ERR e)+    Right cmd -> do+      verified <- verifyTransmission sig signed queueId cmd+      if verified+        then write rcvQ (corrId, queueId, cmd)+        else write sndQ (corrId, queueId, ERR AUTH)+  where+    write q t = atomically $ writeTBQueue q t  send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()-send h Client {sndQ} = forever $ do+send h Client {sndQ, sessionId} = forever $ do   t <- atomically $ readTBQueue sndQ-  liftIO $ tPut h ("", serializeTransmission t)--mkResp :: CorrId -> QueueId -> Command 'Broker -> Transmission-mkResp corrId queueId command = (corrId, queueId, Cmd SBroker command)+  liftIO $ tPut h (Nothing, encodeTransmission sessionId t) -verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => SignedTransmission -> m Transmission-verifyTransmission (sig, t@(corrId, queueId, cmd)) = do-  (corrId,queueId,) <$> case cmd of-    Cmd SBroker _ -> return $ smpErr INTERNAL -- it can only be client command, because `fromClient` was used-    Cmd SRecipient (NEW k) -> pure $ verifySignature k+verifyTransmission ::+  forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool+verifyTransmission sig_ signed queueId cmd = do+  case cmd of+    Cmd SRecipient (NEW k _) -> pure $ verifySignature k     Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey-    Cmd SSender (SEND _) -> verifyCmd SSender $ verifySend sig . senderKey-    Cmd SSender PING -> return cmd+    Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey+    Cmd SSender PING -> pure True+    Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier   where-    verifyCmd :: SParty p -> (QueueRec -> Cmd) -> m Cmd+    verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool     verifyCmd party f = do       st <- asks queueStore       q <- atomically $ getQueue st party queueId-      pure $ either (const $ dummyVerify authErr) f q-    verifySend :: C.Signature -> Maybe SenderPublicKey -> Cmd-    verifySend "" = maybe cmd (const authErr)-    verifySend _ = maybe authErr verifySignature-    verifySignature :: C.PublicKey -> Cmd-    verifySignature key = if verify key then cmd else authErr-    verify key-      | C.publicKeySize key == sigLen = cryptoVerify key-      | otherwise = dummyVerify False-    cryptoVerify key = C.verify key sig (serializeTransmission t)-    smpErr = Cmd SBroker . ERR-    authErr = smpErr AUTH-    dummyVerify :: a -> a-    dummyVerify = seq $-      cryptoVerify $ case sigLen of-        128 -> dummyKey128-        256 -> dummyKey256-        384 -> dummyKey384-        512 -> dummyKey512-        _ -> dummyKey256-    sigLen = B.length $ C.unSignature sig+      pure $ either (const $ maybe False dummyVerify sig_ `seq` False) f q+    verifyMaybe :: Maybe C.APublicVerifyKey -> Bool+    verifyMaybe = maybe (isNothing sig_) verifySignature+    verifySignature :: C.APublicVerifyKey -> Bool+    verifySignature key = maybe False (verify key) sig_+    verify :: C.APublicVerifyKey -> C.ASignature -> Bool+    verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) =+      case (testEquality a a', C.signatureSize k == C.signatureSize s) of+        (Just Refl, True) -> C.verify' k s signed+        _ -> dummyVerify sig `seq` False+    dummyVerify :: C.ASignature -> Bool+    dummyVerify (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed  -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes-dummyKey128 :: C.PublicKey-dummyKey128 = "MIIBIDANBgkqhkiG9w0BAQEFAAOCAQ0AMIIBCAKBgQC2oeA7s4roXN5K2N6022I1/2CTeMKjWH0m00bSZWa4N8LDKeFcShh8YUxZea5giAveViTRNOOVLgcuXbKvR3u24szN04xP0+KnYUuUUIIoT3YSjX0IlomhDhhSyup4BmA0gAZ+D1OaIKZFX6J8yQ1Lr/JGLEfSRsBjw8l+4hs9OwKBgQDKA+YlZvGb3BcpDwKmatiCXN7ZRDWkjXbj8VAW5zV95tSRCCVN48hrFM1H4Ju2QMMUc6kPUVX+eW4ZjdCl5blIqIHMcTmsdcmsDDCg3PjUNrwc6bv/1TcirbAKcmnKt9iurIt6eerxSO7TZUXXMUVsi7eRwb/RUNhpCrpJ/hpIOw=="--dummyKey256 :: C.PublicKey-dummyKey256 = "MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAxwmTvaqmdTbkfUGNi8Yu0L/T4cxuOlQlx3zGZ9X9Qx0+oZjknWK+QHrdWTcpS+zH4Hi7fP6kanOQoQ90Hj6Ghl57VU1GEdUPywSw4i1/7t0Wv9uT9Q2ktHp2rqVo3xkC9IVIpL7EZAxdRviIN2OsOB3g4a/F1ZpjxcAaZeOMUugiAX1+GtkLuE0Xn4neYjCaOghLxQTdhybN70VtnkiQLx/X9NjkDIl/spYGm3tQFMyYKkP6IWoEpj0926hJ0fmlmhy8tAOhlZsb/baW5cgkEZ3E9jVVrySCgQzoLQgma610FIISRpRJbSyv26jU7MkMxiyuBiDaFOORkXFttoKbtQKBgEbDS9II2brsz+vfI7uP8atFcawkE52cx4M1UWQhqb1H3tBiRl+qO+dMq1pPQF2bW7dlZAWYzS4W/367bTAuALHBDGB8xi1P4Njhh9vaOgTvuqrHG9NJQ85BLy0qGw8rjIWSIXVmVpfrXFJ8po5l04UE258Ll2yocv3QRQmddQW9"+dummyPublicKey :: C.Signature a -> C.PublicKey a+dummyPublicKey = \case+  C.SignatureEd25519 _ -> dummyKeyEd25519+  C.SignatureEd448 _ -> dummyKeyEd448 -dummyKey384 :: C.PublicKey-dummyKey384 = "MIICITANBgkqhkiG9w0BAQEFAAOCAg4AMIICCQKCAYEAthExp77lSFBMB0RedjgKIU+oNH5lMGdMqDCG0E5Ly7X49rFpfDMMN08GDIgvzg9kcwV3ScbPcjUE19wmAShX9f9k3w38KM3wmIBKSiuCREQl0V3xAYp1SYwiAkMNSSwxuIkDEeSOR56WdEcZvqbB4lY9MQlUv70KriPDxZaqKCTKslUezXHQuYPQX6eMnGFK7hxz5Kl5MajV52d+5iXsa8CA+m/e1KVnbelCO+xhN89xG8ALt0CJ9k5Wwo3myLgXi4dmNankCmg8jkh+7y2ywkzxMwH1JydDtV/FLzkbZsbPR2w93TNrTq1RJOuqMyh0VtdBSpxNW/Ft988TkkX2BAWzx82INw7W6/QbHGNtHNB995R4sgeYy8QbEpNGBhQnfQh7yRWygLTVXWKApQzzfCeIoDDWUS7dMv/zXoasAnpDBj+6UhHv3BHrps7kBvRyZQ2d/nUuAqiGd43ljJ++n6vNyFLgZoiV7HLia/FOGMkdt7j92CNmFHxiT6Xl7kRHAoGBAPNoWny2O7LBxzAKMLmQVHBAiKp6RMx+7URvtQDHDHPaZ7F3MvtvmYWwGzund3cQFAaV1EkJoYeI3YRuj6xdXgMyMaP54On++btArb6jUtZuvlC98qE8dEEHQNh+7TsCiMU+ivbeKFxS9A/B7OVedoMnPoJWhatbA9zB/6L1GNPh"+dummyKeyEd25519 :: C.PublicKey 'C.Ed25519+dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" -dummyKey512 :: C.PublicKey-dummyKey512 = "MIICoDANBgkqhkiG9w0BAQEFAAOCAo0AMIICiAKCAgEArkCY9DuverJ4mmzDektv9aZMFyeRV46WZK9NsOBKEc+1ncqMs+LhLti9asKNgUBRbNzmbOe0NYYftrUpwnATaenggkTFxxbJ4JGJuGYbsEdFWkXSvrbWGtM8YUmn5RkAGme12xQ89bSM4VoJAGnrYPHwmcQd+KYCPZvTUsxaxgrJTX65ejHN9BsAn8XtGViOtHTDJO9yUMD2WrJvd7wnNa+0ugEteDLzMU++xS98VC+uA1vfauUqi3yXVchdfrLdVUuM+JE0gUEXCgzjuHkaoHiaGNiGhdPYoAJJdOKQOIHAKdk7Th6OPhirPhc9XYNB4O8JDthKhNtfokvFIFlC4QBRzJhpLIENaEBDt08WmgpOnecZB/CuxkqqOrNa8j5K5jNrtXAI67W46VEC2jeQy/gZwb64Zit2A4D00xXzGbQTPGj4ehcEMhLx5LSCygViEf0w0tN3c3TEyUcgPzvECd2ZVpQLr9Z4a07Ebr+YSuxcHhjg4Rg1VyJyOTTvaCBGm5X2B3+tI4NUttmikIHOYpBnsLmHY2BgfH2KcrIsDyAhInXmTFr/L2+erFarUnlfATd2L8Ti43TNHDedO6k6jI5Gyi62yPwjqPLEIIK8l+pIeNfHJ3pPmjhHBfzFcQLMMMXffHWNK8kWklrQXK+4j4HiPcTBvlO1FEtG9nEIZhUCgYA4a6WtI2k5YNli1C89GY5rGUY7RP71T6RWri/D3Lz9T7GvU+FemAyYmsvCQwqijUOur0uLvwSP8VdxpSUcrjJJSWur2hrPWzWlu0XbNaeizxpFeKbQP+zSrWJ1z8RwfAeUjShxt8q1TuqGqY10wQyp3nyiTGvS+KwZVj5h5qx8NQ=="+dummyKeyEd448 :: C.PublicKey 'C.Ed448+dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"  client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()-client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =+client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =   forever $     atomically (readTBQueue rcvQ)       >>= processCommand       >>= atomically . writeTBQueue sndQ   where-    processCommand :: Transmission -> m Transmission+    processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)     processCommand (corrId, queueId, cmd) = do       st <- asks queueStore       case cmd of-        Cmd SBroker END -> unsubscribeQueue $> (corrId, queueId, cmd)-        Cmd SBroker _ -> return (corrId, queueId, cmd)-        Cmd SSender command -> case command of-          SEND msgBody -> sendMessage st msgBody-          PING -> return (corrId, queueId, Cmd SBroker PONG)-        Cmd SRecipient command -> case command of-          NEW rKey -> createQueue st rKey-          SUB -> subscribeQueue queueId-          ACK -> acknowledgeMsg-          KEY sKey -> secureQueue_ st sKey-          OFF -> suspendQueue_ st-          DEL -> delQueueAndMsgs st+        Cmd SSender command ->+          case command of+            SEND msgBody -> sendMessage st msgBody+            PING -> pure (corrId, "", PONG)+        Cmd SNotifier NSUB -> subscribeNotifications+        Cmd SRecipient command ->+          case command of+            NEW rKey dhKey -> createQueue st rKey dhKey+            SUB -> subscribeQueue queueId+            ACK -> acknowledgeMsg+            KEY sKey -> secureQueue_ st sKey+            NKEY nKey -> addQueueNotifier_ st nKey+            OFF -> suspendQueue_ st+            DEL -> delQueueAndMsgs st       where-        createQueue :: QueueStore -> RecipientPublicKey -> m Transmission-        createQueue st rKey =-          checkKeySize rKey addSubscribe+        createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m (Transmission BrokerMsg)+        createQueue st recipientKey dhKey = do+          (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'+          let rcvDhSecret = C.dh' dhKey privDhKey+              qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}+              qRec (recipientId, senderId) =+                QueueRec+                  { recipientId,+                    senderId,+                    recipientKey,+                    rcvDhSecret,+                    senderKey = Nothing,+                    notifier = Nothing,+                    status = QueueActive+                  }+          (corrId,queueId,) <$> addQueueRetry 3 qik qRec           where-            addSubscribe =-              addQueueRetry 3 >>= \case-                Left e -> return $ ERR e-                Right (rId, sId) -> do+            addQueueRetry ::+              Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> m BrokerMsg+            addQueueRetry 0 _ _ = pure $ ERR INTERNAL+            addQueueRetry n qik qRec = do+              ids@(rId, _) <- getIds+              -- create QueueRec record with these ids and keys+              atomically (addQueue st $ qRec ids) >>= \case+                Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec+                Left e -> pure $ ERR e+                Right _ -> do                   withLog (`logCreateById` rId)-                  subscribeQueue rId $> IDS rId sId--            addQueueRetry :: Int -> m (Either ErrorType (RecipientId, SenderId))-            addQueueRetry 0 = return $ Left INTERNAL-            addQueueRetry n = do-              ids <- getIds-              atomically (addQueue st rKey ids) >>= \case-                Left DUPLICATE_ -> addQueueRetry $ n - 1-                Left e -> return $ Left e-                Right _ -> return $ Right ids+                  subscribeQueue rId $> IDS (qik ids)              logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()             logCreateById s rId =@@ -253,24 +278,31 @@               n <- asks $ queueIdBytes . config               liftM2 (,) (randomId n) (randomId n) -        secureQueue_ :: QueueStore -> SenderPublicKey -> m Transmission+        secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg)         secureQueue_ st sKey = do           withLog $ \s -> logSecureQueue s queueId sKey-          atomically . checkKeySize sKey $ either ERR (const OK) <$> secureQueue st queueId sKey+          atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey -        checkKeySize :: Monad m' => C.PublicKey -> m' (Command 'Broker) -> m' Transmission-        checkKeySize key action =-          mkResp corrId queueId-            <$> if C.validKeySize $ C.publicKeySize key-              then action-              else pure . ERR $ CMD KEY_SIZE+        addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg)+        addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3+          where+            addNotifierRetry :: Int -> m BrokerMsg+            addNotifierRetry 0 = pure $ ERR INTERNAL+            addNotifierRetry n = do+              nId <- randomId =<< asks (queueIdBytes . config)+              atomically (addQueueNotifier st queueId nId nKey) >>= \case+                Left DUPLICATE_ -> addNotifierRetry $ n - 1+                Left e -> pure $ ERR e+                Right _ -> do+                  withLog $ \s -> logAddNotifier s queueId nId nKey+                  pure $ NID nId -        suspendQueue_ :: QueueStore -> m Transmission+        suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg)         suspendQueue_ st = do           withLog (`logDeleteQueue` queueId)           okResp <$> atomically (suspendQueue st queueId) -        subscribeQueue :: RecipientId -> m Transmission+        subscribeQueue :: RecipientId -> m (Transmission BrokerMsg)         subscribeQueue rId =           atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId @@ -285,13 +317,15 @@               writeTVar subscriptions $ M.insert rId s subs               return s -        unsubscribeQueue :: m ()-        unsubscribeQueue = do-          sub <- atomically . stateTVar subscriptions $-            \cs -> (M.lookup queueId cs, M.delete queueId cs)-          mapM_ cancelSub sub+        subscribeNotifications :: m (Transmission BrokerMsg)+        subscribeNotifications = atomically $ do+          subs <- readTVar ntfSubscriptions+          when (isNothing $ M.lookup queueId subs) $ do+            writeTBQueue ntfSubscribedQ (queueId, clnt)+            writeTVar ntfSubscriptions $ M.insert queueId () subs+          pure ok -        acknowledgeMsg :: m Transmission+        acknowledgeMsg :: m (Transmission BrokerMsg)         acknowledgeMsg =           atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))             >>= \case@@ -301,31 +335,47 @@         withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)         withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId -        sendMessage :: QueueStore -> MsgBody -> m Transmission-        sendMessage st msgBody = do-          qr <- atomically $ getQueue st SSender queueId-          either (return . err) storeMessage qr+        sendMessage :: QueueStore -> MsgBody -> m (Transmission BrokerMsg)+        sendMessage st msgBody+          | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG+          | otherwise = do+            qr <- atomically $ getQueue st SSender queueId+            either (return . err) storeMessage qr           where-            mkMessage :: m Message-            mkMessage = do-              msgId <- asks (msgIdBytes . config) >>= randomId-              ts <- liftIO getCurrentTime-              return $ Message {msgId, ts, msgBody}--            storeMessage :: QueueRec -> m Transmission+            storeMessage :: QueueRec -> m (Transmission BrokerMsg)             storeMessage qr = case status qr of               QueueOff -> return $ err AUTH-              QueueActive -> do-                ms <- asks msgStore-                msg <- mkMessage-                quota <- asks $ msgQueueQuota . config-                atomically $ do-                  q <- getMsgQueue ms (recipientId qr) quota-                  isFull q >>= \case-                    False -> writeMsg q msg $> ok-                    True -> pure $ err QUOTA+              QueueActive ->+                mkMessage >>= \case+                  Left _ -> pure $ err LARGE_MSG+                  Right msg -> do+                    ms <- asks msgStore+                    quota <- asks $ msgQueueQuota . config+                    atomically $ do+                      q <- getMsgQueue ms (recipientId qr) quota+                      ifM (isFull q) (pure $ err QUOTA) $ do+                        trySendNotification+                        writeMsg q msg+                        pure ok+              where+                mkMessage :: m (Either C.CryptoError Message)+                mkMessage = do+                  msgId <- randomId =<< asks (msgIdBytes . config)+                  ts <- liftIO getSystemTime+                  let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2)+                  pure $ Message msgId ts <$> c -        deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m Transmission+                trySendNotification :: STM ()+                trySendNotification =+                  forM_ (notifier qr) $ \(nId, _) ->+                    mapM_ (writeNtf nId) . M.lookup nId =<< readTVar notifiers++                writeNtf :: NotifierId -> Client -> STM ()+                writeNtf nId Client {sndQ = q} =+                  unlessM (isFullTBQueue sndQ) $+                    writeTBQueue q (CorrId "", nId, NMSG)++        deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m (Transmission BrokerMsg)         deliverMessage tryPeek rId = \case           Sub {subThread = NoSub} -> do             ms <- asks msgStore@@ -333,8 +383,8 @@             q <- atomically $ getMsgQueue ms rId quota             atomically (tryPeek q) >>= \case               Nothing -> forkSub q $> ok-              Just msg -> atomically setDelivered $> mkResp corrId rId (msgCmd msg)-          _ -> return ok+              Just msg -> atomically setDelivered $> (corrId, rId, msgCmd msg)+          _ -> pure ok           where             forkSub :: MsgQueue -> m ()             forkSub q = do@@ -347,7 +397,7 @@             subscriber :: MsgQueue -> m ()             subscriber q = atomically $ do               msg <- peekMsg q-              writeTBQueue sndQ $ mkResp (CorrId "") rId (msgCmd msg)+              writeTBQueue sndQ (CorrId "", rId, msgCmd msg)               setSub (\s -> s {subThread = NoSub})               void setDelivered @@ -357,33 +407,33 @@             setDelivered :: STM (Maybe Bool)             setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) () -        delQueueAndMsgs :: QueueStore -> m Transmission+            msgCmd :: Message -> BrokerMsg+            msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody++        delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg)         delQueueAndMsgs st = do           withLog (`logDeleteQueue` queueId)           ms <- asks msgStore           atomically $             deleteQueue st queueId >>= \case-              Left e -> return $ err e+              Left e -> pure $ err e               Right _ -> delMsgQueue ms queueId $> ok -        ok :: Transmission-        ok = mkResp corrId queueId OK+        ok :: Transmission BrokerMsg+        ok = (corrId, queueId, OK) -        err :: ErrorType -> Transmission-        err = mkResp corrId queueId . ERR+        err :: ErrorType -> Transmission BrokerMsg+        err e = (corrId, queueId, ERR e) -        okResp :: Either ErrorType () -> Transmission+        okResp :: Either ErrorType () -> Transmission BrokerMsg         okResp = either err $ const ok -        msgCmd :: Message -> Command 'Broker-        msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody- withLog :: (MonadUnliftIO m, MonadReader Env m) => (StoreLog 'WriteMode -> IO a) -> m () withLog action = do   env <- ask   liftIO . mapM_ action $ storeLog (env :: Env) -randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m Encoded+randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString randomId n = do   gVar <- asks idsDrg   atomically (randomBytes n gVar)
src/Simplex/Messaging/Server/Env/STM.hs view
@@ -6,20 +6,22 @@ module Simplex.Messaging.Server.Env.STM where  import Control.Concurrent (ThreadId)-import Control.Concurrent.STM (stateTVar) import Control.Monad.IO.Unlift import Crypto.Random+import Data.ByteString.Char8 (ByteString) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M+import Data.X509.Validation (Fingerprint (..)) import Network.Socket (ServiceName)+import qualified Network.TLS as T import Numeric.Natural-import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Crypto (KeyHash (..)) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.QueueStore (QueueRec (..)) import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.StoreLog-import Simplex.Messaging.Transport (ATransport)+import Simplex.Messaging.Transport (ATransport, loadFingerprint, loadTLSServerParams) import System.IO (IOMode (..)) import UnliftIO.STM @@ -31,32 +33,36 @@     queueIdBytes :: Int,     msgIdBytes :: Int,     storeLog :: Maybe (StoreLog 'ReadMode),-    blockSize :: Int,-    serverPrivateKey :: C.FullPrivateKey-    -- serverId :: ByteString+    -- CA certificate private key is not needed for initialization+    caCertificateFile :: FilePath,+    privateKeyFile :: FilePath,+    certificateFile :: FilePath   }  data Env = Env   { config :: ServerConfig,     server :: Server,+    serverIdentity :: KeyHash,     queueStore :: QueueStore,     msgStore :: STMMsgStore,     idsDrg :: TVar ChaChaDRG,-    serverKeyPair :: C.FullKeyPair,-    storeLog :: Maybe (StoreLog 'WriteMode)+    storeLog :: Maybe (StoreLog 'WriteMode),+    tlsServerParams :: T.ServerParams   }  data Server = Server   { subscribedQ :: TBQueue (RecipientId, Client),     subscribers :: TVar (Map RecipientId Client),-    nextClientId :: TVar Natural+    ntfSubscribedQ :: TBQueue (NotifierId, Client),+    notifiers :: TVar (Map NotifierId Client)   }  data Client = Client   { subscriptions :: TVar (Map RecipientId Sub),-    rcvQ :: TBQueue Transmission,-    sndQ :: TBQueue Transmission,-    clientId :: Natural,+    ntfSubscriptions :: TVar (Map NotifierId ()),+    rcvQ :: TBQueue (Transmission Cmd),+    sndQ :: TBQueue (Transmission BrokerMsg),+    sessionId :: ByteString,     connected :: TVar Bool   } @@ -71,17 +77,18 @@ newServer qSize = do   subscribedQ <- newTBQueue qSize   subscribers <- newTVar M.empty-  nextClientId <- newTVar 0-  return Server {subscribedQ, subscribers, nextClientId}+  ntfSubscribedQ <- newTBQueue qSize+  notifiers <- newTVar M.empty+  return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers} -newClient :: Server -> Natural -> STM Client-newClient Server {nextClientId} qSize = do+newClient :: Natural -> ByteString -> STM Client+newClient qSize sessionId = do   subscriptions <- newTVar M.empty+  ntfSubscriptions <- newTVar M.empty   rcvQ <- newTBQueue qSize   sndQ <- newTBQueue qSize-  clientId <- stateTVar nextClientId $ \i -> (i, i + 1)   connected <- newTVar True-  return Client {subscriptions, rcvQ, sndQ, clientId, connected}+  return Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, connected}  newSubscription :: STM Sub newSubscription = do@@ -89,20 +96,31 @@   return Sub {subThread = NoSub, delivered}  newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env-newEnv config = do+newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile} = do   server <- atomically $ newServer (serverTbqSize config)   queueStore <- atomically newQueueStore   msgStore <- atomically newMsgStore   idsDrg <- drgNew >>= newTVarIO   s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig)-  let pk = serverPrivateKey config-      serverKeyPair = (C.publicKey' pk, pk)-  return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s'}+  tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile+  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile+  let serverIdentity = KeyHash fp+  return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog = s', tlsServerParams}   where     restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode)     restoreQueues queueStore s = do       (queues, s') <- liftIO $ readWriteStoreLog s-      atomically $ modifyTVar queueStore $ \d -> d {queues, senders = M.foldr' addSender M.empty queues}+      atomically $+        modifyTVar queueStore $ \d ->+          d+            { queues,+              senders = M.foldr' addSender M.empty queues,+              notifiers = M.foldr' addNotifier M.empty queues+            }       pure s'     addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId     addSender q = M.insert (senderId q) (recipientId q)+    addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId+    addNotifier q = case notifier q of+      Nothing -> id+      Just (nId, _) -> M.insert nId (recipientId q)
src/Simplex/Messaging/Server/MsgStore.hs view
@@ -2,13 +2,13 @@  module Simplex.Messaging.Server.MsgStore where -import Data.Time.Clock+import Data.Time.Clock.System (SystemTime) import Numeric.Natural-import Simplex.Messaging.Protocol (Encoded, MsgBody, RecipientId)+import Simplex.Messaging.Protocol (MsgBody, MsgId, RecipientId)  data Message = Message-  { msgId :: Encoded,-    ts :: UTCTime,+  { msgId :: MsgId,+    ts :: SystemTime,     msgBody :: MsgBody   }
src/Simplex/Messaging/Server/QueueStore.hs view
@@ -1,35 +1,27 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}  module Simplex.Messaging.Server.QueueStore where  import Simplex.Messaging.Protocol  data QueueRec = QueueRec-  { recipientId :: QueueId,-    senderId :: QueueId,-    recipientKey :: RecipientPublicKey,-    senderKey :: Maybe SenderPublicKey,+  { recipientId :: RecipientId,+    recipientKey :: RcvPublicVerifyKey,+    rcvDhSecret :: RcvDhSecret,+    senderId :: SenderId,+    senderKey :: Maybe SndPublicVerifyKey,+    notifier :: Maybe (NotifierId, NtfPublicVerifyKey),     status :: QueueStatus   } -data QueueStatus = QueueActive | QueueOff deriving (Eq)+data QueueStatus = QueueActive | QueueOff deriving (Eq, Show)  class MonadQueueStore s m where-  addQueue :: s -> RecipientPublicKey -> (RecipientId, SenderId) -> m (Either ErrorType ())-  getQueue :: s -> SParty (a :: Party) -> QueueId -> m (Either ErrorType QueueRec)-  secureQueue :: s -> RecipientId -> SenderPublicKey -> m (Either ErrorType ())+  addQueue :: s -> QueueRec -> m (Either ErrorType ())+  getQueue :: s -> SParty p -> QueueId -> m (Either ErrorType QueueRec)+  secureQueue :: s -> RecipientId -> SndPublicVerifyKey -> m (Either ErrorType QueueRec)+  addQueueNotifier :: s -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> m (Either ErrorType QueueRec)   suspendQueue :: s -> RecipientId -> m (Either ErrorType ())   deleteQueue :: s -> RecipientId -> m (Either ErrorType ())--mkQueueRec :: RecipientPublicKey -> (RecipientId, SenderId) -> QueueRec-mkQueueRec recipientKey (recipientId, senderId) =-  QueueRec-    { recipientId,-      senderId,-      recipientKey,-      senderKey = Nothing,-      status = QueueActive-    }
src/Simplex/Messaging/Server/QueueStore/STM.hs view
@@ -19,45 +19,70 @@  data QueueStoreData = QueueStoreData   { queues :: Map RecipientId QueueRec,-    senders :: Map SenderId RecipientId+    senders :: Map SenderId RecipientId,+    notifiers :: Map NotifierId RecipientId   }  type QueueStore = TVar QueueStoreData  newQueueStore :: STM QueueStore-newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty}+newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty, notifiers = M.empty}  instance MonadQueueStore QueueStore STM where-  addQueue :: QueueStore -> RecipientPublicKey -> (RecipientId, SenderId) -> STM (Either ErrorType ())-  addQueue store rKey ids@(rId, sId) = do+  addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())+  addQueue store qRec@QueueRec {recipientId = rId, senderId = sId} = do     cs@QueueStoreData {queues, senders} <- readTVar store     if M.member rId queues || M.member sId senders       then return $ Left DUPLICATE_       else do         writeTVar store $           cs-            { queues = M.insert rId (mkQueueRec rKey ids) queues,+            { queues = M.insert rId qRec queues,               senders = M.insert sId rId senders             }         return $ Right () -  getQueue :: QueueStore -> SParty (p :: Party) -> QueueId -> STM (Either ErrorType QueueRec)-  getQueue store SRecipient rId = do-    cs <- readTVar store-    return $ getRcpQueue cs rId-  getQueue store SSender sId = do-    cs <- readTVar store-    let rId = M.lookup sId $ senders cs-    return $ maybe (Left AUTH) (getRcpQueue cs) rId-  getQueue _ SBroker _ =-    return $ Left INTERNAL+  getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)+  getQueue st party qId = do+    cs <- readTVar st+    pure $ case party of+      SRecipient -> getRcpQueue cs qId+      SSender -> getPartyQueue cs senders+      SNotifier -> getPartyQueue cs notifiers+    where+      getPartyQueue ::+        QueueStoreData ->+        (QueueStoreData -> Map QueueId RecipientId) ->+        Either ErrorType QueueRec+      getPartyQueue cs recipientIds =+        case M.lookup qId $ recipientIds cs of+          Just rId -> getRcpQueue cs rId+          Nothing -> Left AUTH +  secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec)   secureQueue store rId sKey =     updateQueues store rId $ \cs c ->       case senderKey c of         Just _ -> (Left AUTH, cs)-        _ -> (Right (), cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)})+        _ -> (Right c, cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)}) +  addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> STM (Either ErrorType QueueRec)+  addQueueNotifier store rId nId nKey = do+    cs@QueueStoreData {queues, notifiers} <- readTVar store+    if M.member nId notifiers+      then pure $ Left DUPLICATE_+      else case M.lookup rId queues of+        Nothing -> pure $ Left AUTH+        Just q -> case notifier q of+          Just _ -> pure $ Left AUTH+          _ -> do+            writeTVar store $+              cs+                { queues = M.insert rId q {notifier = Just (nId, nKey)} queues,+                  notifiers = M.insert nId rId notifiers+                }+            pure $ Right q+   suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())   suspendQueue store rId =     updateQueues store rId $ \cs c ->@@ -76,8 +101,8 @@ updateQueues ::   QueueStore ->   RecipientId ->-  (QueueStoreData -> QueueRec -> (Either ErrorType (), QueueStoreData)) ->-  STM (Either ErrorType ())+  (QueueStoreData -> QueueRec -> (Either ErrorType a, QueueStoreData)) ->+  STM (Either ErrorType a) updateQueues store rId update = do   cs <- readTVar store   let conn = getRcpQueue cs rId
src/Simplex/Messaging/Server/StoreLog.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Simplex.Messaging.Server.StoreLog   ( StoreLog, -- constructors are not exported@@ -14,6 +15,7 @@     closeStoreLog,     logCreateQueue,     logSecureQueue,+    logAddNotifier,     logDeleteQueue,     readWriteStoreLog,   )@@ -21,10 +23,7 @@  import Control.Applicative (optional, (<|>)) import Control.Monad (unless)-import Data.Attoparsec.ByteString.Char8 (Parser)-import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first, second)-import Data.ByteString.Base64 (encode) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB@@ -33,8 +32,7 @@ import Data.List (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as M-import qualified Simplex.Messaging.Crypto as C-import Simplex.Messaging.Parsers (base64P, parseAll)+import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore (QueueRec (..), QueueStatus (..)) import Simplex.Messaging.Transport (trimCR)@@ -49,38 +47,45 @@  data StoreLogRecord   = CreateQueue QueueRec-  | SecureQueue QueueId SenderPublicKey+  | SecureQueue QueueId SndPublicVerifyKey+  | AddNotifier QueueId NotifierId NtfPublicVerifyKey   | DeleteQueue QueueId -storeLogRecordP :: Parser StoreLogRecord-storeLogRecordP =-  "CREATE " *> createQueueP-    <|> "SECURE " *> secureQueueP-    <|> "DELETE " *> (DeleteQueue <$> base64P)-  where-    createQueueP = CreateQueue <$> queueRecP-    secureQueueP = SecureQueue <$> base64P <* A.space <*> C.pubKeyP-    queueRecP = do-      recipientId <- "rid=" *> base64P <* A.space-      senderId <- "sid=" *> base64P <* A.space-      recipientKey <- "rk=" *> C.pubKeyP <* A.space-      senderKey <- "sk=" *> optional C.pubKeyP-      pure QueueRec {recipientId, senderId, recipientKey, senderKey, status = QueueActive}+instance StrEncoding QueueRec where+  strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} =+    B.unwords+      [ "rid=" <> strEncode recipientId,+        "rk=" <> strEncode recipientKey,+        "rdh=" <> strEncode rcvDhSecret,+        "sid=" <> strEncode senderId,+        "sk=" <> strEncode senderKey+      ]+      <> maybe "" notifierStr notifier+    where+      notifierStr (nId, nKey) = " nid=" <> strEncode nId <> " nk=" <> strEncode nKey -serializeStoreLogRecord :: StoreLogRecord -> ByteString-serializeStoreLogRecord = \case-  CreateQueue q -> "CREATE " <> serializeQueue q-  SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializePubKey sKey-  DeleteQueue rId -> "DELETE " <> encode rId-  where-    serializeQueue QueueRec {recipientId, senderId, recipientKey, senderKey} =-      B.unwords-        [ "rid=" <> encode recipientId,-          "sid=" <> encode senderId,-          "rk=" <> C.serializePubKey recipientKey,-          "sk=" <> maybe "" C.serializePubKey senderKey-        ]+  strP = do+    recipientId <- "rid=" *> strP_+    recipientKey <- "rk=" *> strP_+    rcvDhSecret <- "rdh=" *> strP_+    senderId <- "sid=" *> strP_+    senderKey <- "sk=" *> strP+    notifier <- optional $ (,) <$> (" nid=" *> strP_) <*> ("nk=" *> strP)+    pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive} +instance StrEncoding StoreLogRecord where+  strEncode = \case+    CreateQueue q -> strEncode (Str "CREATE", q)+    SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey)+    AddNotifier rId nId nKey -> strEncode (Str "NOTIFIER", rId, nId, nKey)+    DeleteQueue rId -> strEncode (Str "DELETE", rId)++  strP =+    "CREATE " *> (CreateQueue <$> strP)+      <|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)+      <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP_ <*> strP)+      <|> "DELETE " *> (DeleteQueue <$> strP)+ openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode) openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode @@ -101,15 +106,18 @@  writeStoreLogRecord :: StoreLog 'WriteMode -> StoreLogRecord -> IO () writeStoreLogRecord (WriteStoreLog _ h) r = do-  B.hPutStrLn h $ serializeStoreLogRecord r+  B.hPutStrLn h $ strEncode r   hFlush h  logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO () logCreateQueue s = writeStoreLogRecord s . CreateQueue -logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SenderPublicKey -> IO ()+logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey +logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NotifierId -> NtfPublicVerifyKey -> IO ()+logAddNotifier s qId nId nKey = writeStoreLogRecord s $ AddNotifier qId nId nKey+ logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO () logDeleteQueue s = writeStoreLogRecord s . DeleteQueue @@ -136,11 +144,12 @@     returnResult :: ([LogParsingError], Map RecipientId QueueRec) -> IO (Map RecipientId QueueRec)     returnResult (errs, res) = mapM_ printError errs $> res     parseLogRecord :: LB.ByteString -> Either LogParsingError StoreLogRecord-    parseLogRecord = (\s -> first (,s) $ parseAll storeLogRecordP s) . trimCR . LB.toStrict+    parseLogRecord = (\s -> first (,s) $ strDecode s) . trimCR . LB.toStrict     procLogRecord :: Map RecipientId QueueRec -> StoreLogRecord -> Map RecipientId QueueRec     procLogRecord m = \case       CreateQueue q -> M.insert (recipientId q) q m       SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m+      AddNotifier qId nId nKey -> M.adjust (\q -> q {notifier = Just (nId, nKey)}) qId m       DeleteQueue qId -> M.delete qId m     printError :: LogParsingError -> IO ()     printError (e, s) = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
src/Simplex/Messaging/Transport.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -24,28 +25,37 @@ -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a module Simplex.Messaging.Transport-  ( -- * Transport connection class+  ( -- * SMP transport parameters+    smpBlockSize,+    supportedSMPVersions,+    simplexMQVersion,++    -- * Transport connection class     Transport (..),     TProxy (..),     ATransport (..),+    TransportPeer (..), -    -- * Transport over TCP+    -- * Transport over TLS 1.2     runTransportServer,     runTransportClient,+    loadTLSServerParams,+    loadFingerprint, -    -- * TCP transport-    TCP (..),+    -- * TLS 1.2 Transport+    TLS (..),+    closeTLS,+    withTlsUnique, -    -- * SMP encrypted transport+    -- * SMP transport     THandle (..),     TransportError (..),     serverHandshake,     clientHandshake,-    tPutEncrypted,-    tGetEncrypted,+    tPutBlock,+    tGetBlock,     serializeTransportError,     transportErrorP,-    currentSMPVersionStr,      -- * Trim trailing CR     trimCR,@@ -56,29 +66,34 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except (throwE)-import Crypto.Cipher.Types (AuthTag)+import qualified Crypto.Store.X509 as SX import Data.Attoparsec.ByteString.Char8 (Parser)-import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first)-import Data.ByteArray (xor)+import Data.Bitraversable (bimapM) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BL+import Data.Default (def) import Data.Functor (($>))-import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S-import Data.String-import Data.Word (Word32)+import qualified Data.X509 as X+import qualified Data.X509.CertificateStore as XS+import Data.X509.Validation (Fingerprint (..))+import qualified Data.X509.Validation as XV import GHC.Generics (Generic) import GHC.IO.Exception (IOErrorType (..)) import GHC.IO.Handle.Internals (ioe_EOF) import Generic.Random (genericArbitraryU) import Network.Socket-import Network.Transport.Internal (decodeNum16, decodeNum32, encodeEnum16, encodeEnum32, encodeWord32)+import qualified Network.TLS as T+import qualified Network.TLS.Extra as TE import qualified Simplex.Messaging.Crypto as C-import Simplex.Messaging.Parsers (parse, parseAll, parseRead1, parseString)-import Simplex.Messaging.Util (bshow, liftError)-import System.IO+import Simplex.Messaging.Encoding+import Simplex.Messaging.Parsers (parse, parseRead1)+import Simplex.Messaging.Util (bshow)+import Simplex.Messaging.Version+import System.Exit (exitFailure) import System.IO.Error import Test.QuickCheck (Arbitrary (..)) import UnliftIO.Concurrent@@ -86,6 +101,17 @@ import qualified UnliftIO.Exception as E import UnliftIO.STM +-- * Transport parameters++smpBlockSize :: Int+smpBlockSize = 16384++supportedSMPVersions :: VersionRange+supportedSMPVersions = mkVersionRange 1 1++simplexMQVersion :: String+simplexMQVersion = "1.0.0"+ -- * Transport connection class  class Transport c where@@ -94,12 +120,17 @@    transportName :: TProxy c -> String -  -- | Upgrade client socket to connection (used in the server)-  getServerConnection :: Socket -> IO c+  transportPeer :: c -> TransportPeer -  -- | Upgrade server socket to connection (used in the client)-  getClientConnection :: Socket -> IO c+  -- | Upgrade server TLS context to connection (used in the server)+  getServerConnection :: T.Context -> IO c +  -- | Upgrade client TLS context to connection (used in the client)+  getClientConnection :: T.Context -> IO c++  -- | tls-unique channel binding per RFC5929+  tlsUnique :: c -> ByteString+   -- | Close connection   closeConnection :: c -> IO () @@ -116,30 +147,41 @@   putLn :: c -> ByteString -> IO ()   putLn c = cPut c . (<> "\r\n") +data TransportPeer = TClient | TServer+  deriving (Eq, Show)+ data TProxy c = TProxy  data ATransport = forall c. Transport c => ATransport (TProxy c) --- * Transport over TCP+-- * Transport over TLS 1.2  -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar. -- -- All accepted connections are passed to the passed function.-runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> (c -> m ()) -> m ()-runTransportServer started port server = do+runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m ()+runTransportServer started port serverParams server = do   clients <- newTVarIO S.empty-  E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) \sock -> forever $ do-    c <- liftIO $ acceptConnection sock-    tid <- forkFinally (server c) (const $ liftIO $ closeConnection c)-    atomically . modifyTVar clients $ S.insert tid+  E.bracket+    (liftIO $ startTCPServer started port)+    (liftIO . closeServer clients)+    $ \sock -> forever $ connectClients sock clients `E.catch` \(_ :: E.SomeException) -> pure ()   where+    connectClients :: Socket -> TVar (Set ThreadId) -> m ()+    connectClients sock clients = do+      c <- liftIO $ acceptConnection sock+      tid <- server c `forkFinally` const (liftIO $ closeConnection c)+      atomically . modifyTVar clients $ S.insert tid     closeServer :: TVar (Set ThreadId) -> Socket -> IO ()     closeServer clients sock = do       readTVarIO clients >>= mapM_ killThread       close sock       void . atomically $ tryPutTMVar started False-    acceptConnection :: Transport c => Socket -> IO c-    acceptConnection sock = accept sock >>= getServerConnection . fst+    acceptConnection :: Socket -> IO c+    acceptConnection sock = do+      (newSock, _) <- accept sock+      ctx <- connectTLS serverParams newSock+      getServerConnection ctx  startTCPServer :: TMVar Bool -> ServiceName -> IO Socket startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted@@ -157,13 +199,14 @@     setStarted sock = atomically (tryPutTMVar started True) >> pure sock  -- | Connect to passed TCP host:port and pass handle to the client.-runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> (c -> m a) -> m a-runTransportClient host port client = do-  c <- liftIO $ startTCPClient host port+runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> C.KeyHash -> (c -> m a) -> m a+runTransportClient host port keyHash client = do+  let clientParams = mkTLSClientParams host port keyHash+  c <- liftIO $ startTCPClient host port clientParams   client c `E.finally` liftIO (closeConnection c) -startTCPClient :: forall c. Transport c => HostName -> ServiceName -> IO c-startTCPClient host port = withSocketsDo $ resolve >>= tryOpen err+startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> IO c+startTCPClient host port clientParams = withSocketsDo $ resolve >>= tryOpen err   where     err :: IOException     err = mkIOError NoSuchThing "no address" Nothing Nothing@@ -182,111 +225,216 @@     open addr = do       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)       connect sock $ addrAddress addr-      getClientConnection sock+      ctx <- connectTLS clientParams sock+      getClientConnection ctx --- * TCP transport+loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams+loadTLSServerParams caCertificateFile certificateFile privateKeyFile =+  fromCredential <$> loadServerCredential+  where+    loadServerCredential :: IO T.Credential+    loadServerCredential =+      T.credentialLoadX509Chain certificateFile [caCertificateFile] privateKeyFile >>= \case+        Right credential -> pure credential+        Left _ -> putStrLn "invalid credential" >> exitFailure+    fromCredential :: T.Credential -> T.ServerParams+    fromCredential credential =+      def+        { T.serverWantClientCert = False,+          T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},+          T.serverHooks = def,+          T.serverSupported = supportedParameters+        } -newtype TCP = TCP {tcpHandle :: Handle}+loadFingerprint :: FilePath -> IO Fingerprint+loadFingerprint certificateFile = do+  (cert : _) <- SX.readSignedObject certificateFile+  pure $ XV.getFingerprint (cert :: X.SignedExact X.Certificate) X.HashSHA256 -instance Transport TCP where-  transportName _ = "TCP"-  getServerConnection = fmap TCP . getSocketHandle-  getClientConnection = getServerConnection-  closeConnection = hClose . tcpHandle-  cGet = B.hGet . tcpHandle-  cPut = B.hPut . tcpHandle-  getLn = fmap trimCR . B.hGetLine . tcpHandle+-- * TLS 1.2 Transport -getSocketHandle :: Socket -> IO Handle-getSocketHandle conn = do-  h <- socketToHandle conn ReadWriteMode-  hSetBinaryMode h True-  hSetNewlineMode h NewlineMode {inputNL = CRLF, outputNL = CRLF}-  hSetBuffering h LineBuffering-  return h+data TLS = TLS+  { tlsContext :: T.Context,+    tlsPeer :: TransportPeer,+    tlsUniq :: ByteString,+    buffer :: TVar ByteString,+    getLock :: TMVar ()+  } --- | Trim trailing CR from ByteString.-trimCR :: ByteString -> ByteString-trimCR "" = ""-trimCR s = if B.last s == '\r' then B.init s else s+connectTLS :: T.TLSParams p => p -> Socket -> IO T.Context+connectTLS params sock =+  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do+    T.handshake ctx+      `E.catch` \(e :: E.SomeException) -> putStrLn ("exception: " <> show e) >> E.throwIO e+    pure ctx --- * SMP encrypted transport+getTLS :: TransportPeer -> T.Context -> IO TLS+getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS+  where+    newTLS tlsUniq = do+      buffer <- newTVarIO ""+      getLock <- newTMVarIO ()+      pure TLS {tlsContext = cxt, tlsPeer, tlsUniq, buffer, getLock} -data SMPVersion = SMPVersion Int Int Int Int-  deriving (Eq, Ord)+withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c+withTlsUnique peer cxt f =+  cxtFinished peer cxt+    >>= maybe (closeTLS cxt >> ioe_EOF) f+  where+    cxtFinished TServer = T.getPeerFinished+    cxtFinished TClient = T.getFinished -instance IsString SMPVersion where-  fromString = parseString $ parseAll smpVersionP+closeTLS :: T.Context -> IO ()+closeTLS ctx =+  (T.bye ctx >> T.contextClose ctx) -- sometimes socket was closed before 'TLS.bye'+    `E.catch` (\(_ :: E.SomeException) -> pure ()) -- so we catch the 'Broken pipe' error here -major :: SMPVersion -> (Int, Int)-major (SMPVersion a b _ _) = (a, b)+mkTLSClientParams :: HostName -> ServiceName -> C.KeyHash -> T.ClientParams+mkTLSClientParams host port keyHash = do+  let p = B.pack port+  (T.defaultParamsClient host p)+    { T.clientShared = def,+      T.clientHooks = def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p},+      T.clientSupported = supportedParameters+    } -currentSMPVersion :: SMPVersion-currentSMPVersion = "0.5.1.0"+validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]+validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]+validateCertificateChain _ _ _ (X.CertificateChain [_]) = pure [XV.EmptyChain]+validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_, caCert]) =+  if Fingerprint kh == XV.getFingerprint caCert X.HashSHA256+    then x509validate+    else pure [XV.UnknownCA]+  where+    x509validate :: IO [XV.FailedReason]+    x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc+      where+        hooks = XV.defaultHooks+        checks = XV.defaultChecks+        certStore = XS.makeCertificateStore sc+        cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)+        serviceID = (host, port)+validateCertificateChain _ _ _ _ = pure [XV.AuthorityTooDeep] -currentSMPVersionStr :: ByteString-currentSMPVersionStr = serializeSMPVersion currentSMPVersion+supportedParameters :: T.Supported+supportedParameters =+  def+    { T.supportedVersions = [T.TLS12],+      T.supportedCiphers = [TE.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256],+      T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)],+      T.supportedSecureRenegotiation = False,+      T.supportedGroups = [T.X448, T.X25519]+    } -serializeSMPVersion :: SMPVersion -> ByteString-serializeSMPVersion (SMPVersion a b c d) = B.intercalate "." [bshow a, bshow b, bshow c, bshow d]+instance Transport TLS where+  transportName _ = "TLS 1.2"+  transportPeer = tlsPeer+  getServerConnection = getTLS TServer+  getClientConnection = getTLS TClient+  tlsUnique = tlsUniq+  closeConnection tls = closeTLS $ tlsContext tls -smpVersionP :: Parser SMPVersion-smpVersionP =-  let ver = A.decimal <* A.char '.'-   in SMPVersion <$> ver <*> ver <*> ver <*> A.decimal+  cGet :: TLS -> Int -> IO ByteString+  cGet TLS {tlsContext, buffer, getLock} n =+    E.bracket_+      (atomically $ takeTMVar getLock)+      (atomically $ putTMVar getLock ())+      $ do+        b <- readChunks =<< readTVarIO buffer+        let (s, b') = B.splitAt n b+        atomically $ writeTVar buffer b'+        pure s+    where+      readChunks :: ByteString -> IO ByteString+      readChunks b+        | B.length b >= n = pure b+        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF+      handleEOF = \case+        T.Error_EOF -> E.throwIO TEBadBlock+        e -> E.throwIO e +  cPut :: TLS -> ByteString -> IO ()+  cPut tls = T.sendData (tlsContext tls) . BL.fromStrict++  getLn :: TLS -> IO ByteString+  getLn TLS {tlsContext, buffer, getLock} = do+    E.bracket_+      (atomically $ takeTMVar getLock)+      (atomically $ putTMVar getLock ())+      $ do+        b <- readChunks =<< readTVarIO buffer+        let (s, b') = B.break (== '\n') b+        atomically $ writeTVar buffer (B.drop 1 b') -- drop '\n' we made a break at+        pure $ trimCR s+    where+      readChunks :: ByteString -> IO ByteString+      readChunks b+        | B.elem '\n' b = pure b+        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF+      handleEOF = \case+        T.Error_EOF -> E.throwIO TEBadBlock+        e -> E.throwIO e++-- | Trim trailing CR from ByteString.+trimCR :: ByteString -> ByteString+trimCR "" = ""+trimCR s = if B.last s == '\r' then B.init s else s++-- * SMP transport+ -- | The handle for SMP encrypted transport connection over Transport . data THandle c = THandle   { connection :: c,-    sndKey :: SessionKey,-    rcvKey :: SessionKey,-    blockSize :: Int+    sessionId :: ByteString,+    -- | agreed SMP server protocol version+    smpVersion :: Version   } -data SessionKey = SessionKey-  { aesKey :: C.Key,-    baseIV :: C.IV,-    counter :: TVar Word32+data ServerHandshake = ServerHandshake+  { smpVersionRange :: VersionRange,+    sessionId :: ByteString   }  data ClientHandshake = ClientHandshake-  { blockSize :: Int,-    sndKey :: SessionKey,-    rcvKey :: SessionKey+  { -- | agreed SMP server protocol version+    smpVersion :: Version,+    -- | server identity - CA certificate fingerprint+    keyHash :: C.KeyHash   } +instance Encoding ClientHandshake where+  smpEncode ClientHandshake {smpVersion, keyHash} = smpEncode (smpVersion, keyHash)+  smpP = do+    (smpVersion, keyHash) <- smpP+    pure ClientHandshake {smpVersion, keyHash}++instance Encoding ServerHandshake where+  smpEncode ServerHandshake {smpVersionRange, sessionId} =+    smpEncode (smpVersionRange, sessionId)+  smpP = do+    (smpVersionRange, sessionId) <- smpP+    pure ServerHandshake {smpVersionRange, sessionId}+ -- | Error of SMP encrypted transport over TCP. data TransportError   = -- | error parsing transport block     TEBadBlock-  | -- | block encryption error-    TEEncrypt-  | -- | block decryption error-    TEDecrypt+  | -- | message does not fit in transport block+    TELargeMsg+  | -- | incorrect session ID+    TEBadSession   | -- | transport handshake error     TEHandshake HandshakeError   deriving (Eq, Generic, Read, Show, Exception)  -- | Transport handshake error. data HandshakeError-  = -- | encryption error-    ENCRYPT-  | -- | decryption error-    DECRYPT-  | -- | error parsing protocol version+  = -- | parsing error+    PARSE+  | -- | incompatible peer version     VERSION-  | -- | error parsing RSA key-    RSA_KEY-  | -- | error parsing server transport header or invalid block size-    HEADER-  | -- | error parsing AES keys-    AES_KEYS-  | -- | not matching RSA key hash-    BAD_HASH-  | -- | lower major agent version than protocol version-    MAJOR_VERSION-  | -- | TCP transport terminated-    TERMINATED+  | -- | incorrect server identity+    IDENTITY   deriving (Eq, Generic, Read, Show, Exception)  instance Arbitrary TransportError where arbitrary = genericArbitraryU@@ -297,202 +445,67 @@ transportErrorP :: Parser TransportError transportErrorP =   "BLOCK" $> TEBadBlock-    <|> "AES_ENCRYPT" $> TEEncrypt-    <|> "AES_DECRYPT" $> TEDecrypt+    <|> "LARGE_MSG" $> TELargeMsg+    <|> "SESSION" $> TEBadSession     <|> TEHandshake <$> parseRead1  -- | Serialize SMP encrypted transport error. serializeTransportError :: TransportError -> ByteString serializeTransportError = \case-  TEEncrypt -> "AES_ENCRYPT"-  TEDecrypt -> "AES_DECRYPT"   TEBadBlock -> "BLOCK"+  TELargeMsg -> "LARGE_MSG"+  TEBadSession -> "SESSION"   TEHandshake e -> bshow e --- | Encrypt and send block to SMP encrypted transport.-tPutEncrypted :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())-tPutEncrypted THandle {connection = c, sndKey, blockSize} block =-  encryptBlock sndKey (blockSize - C.authTagSize) block >>= \case-    Left _ -> pure $ Left TEEncrypt-    Right (authTag, msg) -> Right <$> cPut c (C.authTagToBS authTag <> msg)---- | Receive and decrypt block from SMP encrypted transport.-tGetEncrypted :: Transport c => THandle c -> IO (Either TransportError ByteString)-tGetEncrypted THandle {connection = c, rcvKey, blockSize} =-  cGet c blockSize >>= decryptBlock rcvKey >>= \case-    Left _ -> pure $ Left TEDecrypt-    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)+-- | Pad and send block to SMP transport.+tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())+tPutBlock THandle {connection = c} block =+  bimapM (const $ pure TELargeMsg) (cPut c) $+    C.pad block smpBlockSize -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+-- | Receive block from SMP transport.+tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)+tGetBlock THandle {connection = c} =+  cGet c smpBlockSize >>= \case+    "" -> ioe_EOF+    msg -> pure . first (const TELargeMsg) $ C.unPad msg --- | Server SMP encrypted transport handshake.+-- | Server SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a------ The numbers in function names refer to the steps in the document.-serverHandshake :: forall c. Transport c => c -> Int -> C.FullKeyPair -> ExceptT TransportError IO (THandle c)-serverHandshake c srvBlockSize (k, pk) = do-  checkValidBlockSize srvBlockSize-  liftIO sendHeaderAndPublicKey_1-  encryptedKeys <- receiveEncryptedKeys_4-  ClientHandshake {blockSize, sndKey, rcvKey} <- decryptParseKeys_5 encryptedKeys-  checkValidBlockSize blockSize-  th <- liftIO $ transportHandle c rcvKey sndKey blockSize -- keys are swapped here-  sendWelcome_6 th-  pure th-  where-    sendHeaderAndPublicKey_1 :: IO ()-    sendHeaderAndPublicKey_1 = do-      let sKey = C.encodePubKey k-          header = ServerHeader {blockSize = srvBlockSize, keySize = B.length sKey}-      cPut c $ binaryServerHeader header-      cPut c sKey-    receiveEncryptedKeys_4 :: ExceptT TransportError IO ByteString-    receiveEncryptedKeys_4 =-      liftIO (cGet c $ C.publicKeySize k) >>= \case-        "" -> throwE $ TEHandshake TERMINATED-        ks -> pure ks-    decryptParseKeys_5 :: ByteString -> ExceptT TransportError IO ClientHandshake-    decryptParseKeys_5 encKeys =-      liftError (const $ TEHandshake DECRYPT) (C.decryptOAEP pk encKeys)-        >>= liftEither . parseClientHandshake-    sendWelcome_6 :: THandle c -> ExceptT TransportError IO ()-    sendWelcome_6 th = ExceptT . tPutEncrypted th $ currentSMPVersionStr <> " "+serverHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)+serverHandshake c kh = do+  let th@THandle {sessionId} = tHandle c+  sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions}+  getHandshake th >>= \case+    ClientHandshake {smpVersion, keyHash}+      | keyHash /= kh ->+        throwE $ TEHandshake IDENTITY+      | smpVersion `isCompatible` supportedSMPVersions -> do+        pure (th :: THandle c) {smpVersion}+      | otherwise -> throwE $ TEHandshake VERSION --- | Client SMP encrypted transport handshake.+-- | Client SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a------ The numbers in function names refer to the steps in the document.-clientHandshake :: forall c. Transport c => c -> Maybe Int -> Maybe C.KeyHash -> ExceptT TransportError IO (THandle c)-clientHandshake c blkSize_ keyHash = do-  mapM_ checkValidBlockSize blkSize_-  (k, blkSize) <- getHeaderAndPublicKey_1_2-  let clientBlkSize = fromMaybe blkSize blkSize_-  chs@ClientHandshake {sndKey, rcvKey} <- liftIO $ generateKeys_3 clientBlkSize-  sendEncryptedKeys_4 k chs-  th <- liftIO $ transportHandle c sndKey rcvKey clientBlkSize-  getWelcome_6 th >>= checkVersion-  pure th-  where-    getHeaderAndPublicKey_1_2 :: ExceptT TransportError IO (C.PublicKey, Int)-    getHeaderAndPublicKey_1_2 = do-      header <- liftIO (cGet c serverHeaderSize)-      ServerHeader {blockSize, keySize} <- liftEither $ parse serverHeaderP (TEHandshake HEADER) header-      checkValidBlockSize blockSize-      s <- liftIO $ cGet c keySize-      maybe (pure ()) (validateKeyHash_2 s) keyHash-      key <- liftEither $ parseKey s-      pure (key, blockSize)-    parseKey :: ByteString -> Either TransportError C.PublicKey-    parseKey = first (const $ TEHandshake RSA_KEY) . parseAll C.binaryPubKeyP-    validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO ()-    validateKeyHash_2 k (C.KeyHash kHash)-      | C.sha256Hash k == kHash = pure ()-      | otherwise = throwE $ TEHandshake BAD_HASH-    generateKeys_3 :: Int -> IO ClientHandshake-    generateKeys_3 blkSize = ClientHandshake blkSize <$> generateKey <*> generateKey-    generateKey :: IO SessionKey-    generateKey = do-      aesKey <- C.randomAesKey-      baseIV <- C.randomIV-      pure SessionKey {aesKey, baseIV, counter = undefined}-    sendEncryptedKeys_4 :: C.PublicKey -> ClientHandshake -> ExceptT TransportError IO ()-    sendEncryptedKeys_4 k chs =-      liftError (const $ TEHandshake ENCRYPT) (C.encryptOAEP k $ serializeClientHandshake chs)-        >>= liftIO . cPut c-    getWelcome_6 :: THandle c -> ExceptT TransportError IO SMPVersion-    getWelcome_6 th = ExceptT $ (>>= parseSMPVersion) <$> tGetEncrypted th-    parseSMPVersion :: ByteString -> Either TransportError SMPVersion-    parseSMPVersion = first (const $ TEHandshake VERSION) . A.parseOnly (smpVersionP <* A.space)-    checkVersion :: SMPVersion -> ExceptT TransportError IO ()-    checkVersion smpVersion =-      when (major smpVersion > major currentSMPVersion) . throwE $-        TEHandshake MAJOR_VERSION--checkValidBlockSize :: Int -> ExceptT TransportError IO ()-checkValidBlockSize blkSize =-  when (blkSize `notElem` transportBlockSizes) . throwError $ TEHandshake HEADER--data ServerHeader = ServerHeader {blockSize :: Int, keySize :: Int}-  deriving (Eq, Show)--binaryRsaTransport :: Int-binaryRsaTransport = 0--transportBlockSizes :: [Int]-transportBlockSizes = map (* 1024) [4, 8, 16, 32, 64]--serverHeaderSize :: Int-serverHeaderSize = 8--binaryServerHeader :: ServerHeader -> ByteString-binaryServerHeader ServerHeader {blockSize, keySize} =-  encodeEnum32 blockSize <> encodeEnum16 binaryRsaTransport <> encodeEnum16 keySize--serverHeaderP :: Parser ServerHeader-serverHeaderP = ServerHeader <$> int32 <* binaryRsaTransportP <*> int16--serializeClientHandshake :: ClientHandshake -> ByteString-serializeClientHandshake ClientHandshake {blockSize, sndKey, rcvKey} =-  encodeEnum32 blockSize <> encodeEnum16 binaryRsaTransport <> serializeKey sndKey <> serializeKey rcvKey-  where-    serializeKey :: SessionKey -> ByteString-    serializeKey SessionKey {aesKey, baseIV} = C.unKey aesKey <> C.unIV baseIV--clientHandshakeP :: Parser ClientHandshake-clientHandshakeP = ClientHandshake <$> int32 <* binaryRsaTransportP <*> keyP <*> keyP-  where-    keyP :: Parser SessionKey-    keyP = do-      aesKey <- C.aesKeyP-      baseIV <- C.ivP-      pure SessionKey {aesKey, baseIV, counter = undefined}--int32 :: Parser Int-int32 = decodeNum32 <$> A.take 4--int16 :: Parser Int-int16 = decodeNum16 <$> A.take 2+clientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)+clientHandshake c keyHash = do+  let th@THandle {sessionId} = tHandle c+  ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th+  if sessionId /= sessId+    then throwE TEBadSession+    else case smpVersionRange `compatibleVersion` supportedSMPVersions of+      Just (Compatible smpVersion) -> do+        sendHandshake th $ ClientHandshake {smpVersion, keyHash}+        pure (th :: THandle c) {smpVersion}+      Nothing -> throwE $ TEHandshake VERSION -binaryRsaTransportP :: Parser ()-binaryRsaTransportP = binaryRsa =<< int16-  where-    binaryRsa :: Int -> Parser ()-    binaryRsa n-      | n == binaryRsaTransport = pure ()-      | otherwise = fail "unknown transport mode"+sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()+sendHandshake th = ExceptT . tPutBlock th . smpEncode -parseClientHandshake :: ByteString -> Either TransportError ClientHandshake-parseClientHandshake = parse clientHandshakeP $ TEHandshake AES_KEYS+getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp+getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th -transportHandle :: c -> SessionKey -> SessionKey -> Int -> IO (THandle c)-transportHandle c sk rk blockSize = do-  sndCounter <- newTVarIO 0-  rcvCounter <- newTVarIO 0-  pure-    THandle-      { connection = c,-        sndKey = sk {counter = sndCounter},-        rcvKey = rk {counter = rcvCounter},-        blockSize-      }+tHandle :: Transport c => c -> THandle c+tHandle c =+  THandle {connection = c, sessionId = tlsUnique c, smpVersion = 0}
src/Simplex/Messaging/Transport/WebSockets.hs view
@@ -1,23 +1,39 @@ {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}  module Simplex.Messaging.Transport.WebSockets (WS (..)) where  import qualified Control.Exception as E import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B-import Network.Socket (Socket)+import qualified Data.ByteString.Lazy as BL+import qualified Network.TLS as T import Network.WebSockets import Network.WebSockets.Stream (Stream) import qualified Network.WebSockets.Stream as S-import Simplex.Messaging.Transport (TProxy, Transport (..), TransportError (..), trimCR)+import Simplex.Messaging.Transport+  ( TProxy,+    Transport (..),+    TransportError (..),+    TransportPeer (..),+    closeTLS,+    trimCR,+    withTlsUnique,+  ) -data WS = WS {wsStream :: Stream, wsConnection :: Connection}+data WS = WS+  { wsPeer :: TransportPeer,+    tlsUniq :: ByteString,+    wsStream :: Stream,+    wsConnection :: Connection+  }  websocketsOpts :: ConnectionOptions websocketsOpts =   defaultConnectionOptions     { connectionCompressionOptions = NoCompression,-      connectionFramePayloadSizeLimit = SizeLimit 8192,+      connectionFramePayloadSizeLimit = SizeLimit $ 16 * 1024, -- TODO move to Protocol       connectionMessageDataSizeLimit = SizeLimit 65536     } @@ -25,22 +41,18 @@   transportName :: TProxy WS -> String   transportName _ = "WebSockets" -  getServerConnection :: Socket -> IO WS-  getServerConnection sock = do-    s <- S.makeSocketStream sock-    WS s <$> acceptClientRequest s-    where-      acceptClientRequest :: Stream -> IO Connection-      acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest+  transportPeer :: WS -> TransportPeer+  transportPeer = wsPeer -  getClientConnection :: Socket -> IO WS-  getClientConnection sock = do-    s <- S.makeSocketStream sock-    WS s <$> sendClientRequest s-    where-      sendClientRequest :: Stream -> IO Connection-      sendClientRequest s = newClientConnection s "" "/" websocketsOpts []+  getServerConnection :: T.Context -> IO WS+  getServerConnection = getWS TServer +  getClientConnection :: T.Context -> IO WS+  getClientConnection = getWS TClient++  tlsUnique :: WS -> ByteString+  tlsUnique = tlsUniq+   closeConnection :: WS -> IO ()   closeConnection = S.close . wsStream @@ -60,3 +72,28 @@     if B.null s || B.last s /= '\n'       then E.throwIO TEBadBlock       else pure $ B.init s++getWS :: TransportPeer -> T.Context -> IO WS+getWS wsPeer cxt = withTlsUnique wsPeer cxt connectWS+  where+    connectWS tlsUniq = do+      s <- makeTLSContextStream cxt+      wsConnection <- connectPeer wsPeer s+      pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection}+    connectPeer :: TransportPeer -> Stream -> IO Connection+    connectPeer TServer = acceptClientRequest+    connectPeer TClient = sendClientRequest+    acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest+    sendClientRequest s = newClientConnection s "" "/" websocketsOpts []++makeTLSContextStream :: T.Context -> IO Stream+makeTLSContextStream cxt =+  S.makeStream readStream writeStream+  where+    readStream :: IO (Maybe ByteString)+    readStream =+      (Just <$> T.recvData cxt) `E.catch` \case+        T.Error_EOF -> pure Nothing+        e -> E.throwIO e+    writeStream :: Maybe BL.ByteString -> IO ()+    writeStream = maybe (closeTLS cxt) (T.sendData cxt)
src/Simplex/Messaging/Util.hs view
@@ -1,30 +1,15 @@-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}  module Simplex.Messaging.Util where  import Control.Monad.Except import Control.Monad.IO.Unlift+import Control.Monad.Trans.Except import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import UnliftIO.Async-import UnliftIO.Exception (Exception)-import qualified UnliftIO.Exception as E -newtype InternalException e = InternalException {unInternalException :: e}-  deriving (Eq, Show)--instance Exception e => Exception (InternalException e)--instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where-  withRunInIO :: ((forall a. ExceptT e m a -> IO a) -> IO b) -> ExceptT e m b-  withRunInIO exceptToIO =-    withExceptT unInternalException . ExceptT . E.try $-      withRunInIO $ \run ->-        exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT)- raceAny_ :: MonadUnliftIO m => [m a] -> m () raceAny_ = r []   where@@ -35,24 +20,39 @@  (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (<$$>) = fmap . fmap+{-# INLINE (<$$>) #-}  (<$?>) :: MonadFail m => (a -> Either String b) -> m a -> m b-f <$?> m = m >>= either fail pure . f+f <$?> m = either fail pure . f =<< m+{-# INLINE (<$?>) #-}  bshow :: Show a => a -> ByteString bshow = B.pack . show+{-# INLINE bshow #-} +maybeWord :: (a -> ByteString) -> Maybe a -> ByteString+maybeWord f = maybe "" $ B.cons ' ' . f+{-# INLINE maybeWord #-}+ liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a liftIOEither a = liftIO a >>= liftEither+{-# INLINE liftIOEither #-}  liftError :: (MonadIO m, MonadError e' m) => (e -> e') -> ExceptT e IO a -> m a liftError f = liftEitherError f . runExceptT+{-# INLINE liftError #-}  liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a) -> m a liftEitherError f a = liftIOEither (first f <$> a)+{-# INLINE liftEitherError #-}  tryError :: MonadError e m => m a -> m (Either e a) tryError action = (Right <$> action) `catchError` (pure . Left)+{-# INLINE tryError #-}++tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a)+tryE m = (Right <$> m) `catchE` (pure . Left)+{-# INLINE tryE #-}  ifM :: Monad m => m Bool -> m a -> m a -> m a ifM ba t f = ba >>= \b -> if b then t else f
+ src/Simplex/Messaging/Version.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Simplex.Messaging.Version+  ( Version,+    VersionRange (minVersion, maxVersion),+    pattern VersionRange,+    VersionI (..),+    VersionRangeI (..),+    Compatible,+    pattern Compatible,+    mkVersionRange,+    safeVersionRange,+    isCompatible,+    proveCompatible,+    compatibleVersion,+  )+where++import Control.Applicative (optional)+import Data.Aeson (FromJSON (..), ToJSON (..))+import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.Word (Word16)+import Simplex.Messaging.Encoding+import Simplex.Messaging.Encoding.String+import Simplex.Messaging.Util ((<$?>))++pattern VersionRange :: Word16 -> Word16 -> VersionRange+pattern VersionRange v1 v2 <- VRange v1 v2++{-# COMPLETE VersionRange #-}++type Version = Word16++data VersionRange = VRange+  { minVersion :: Version,+    maxVersion :: Version+  }+  deriving (Eq, Show)++-- | construct valid version range, to be used in constants+mkVersionRange :: Version -> Version -> VersionRange+mkVersionRange v1 v2+  | v1 <= v2 = VRange v1 v2+  | otherwise = error "invalid version range"++safeVersionRange :: Version -> Version -> Maybe VersionRange+safeVersionRange v1 v2+  | v1 <= v2 = Just $ VRange v1 v2+  | otherwise = Nothing++instance Encoding VersionRange where+  smpEncode (VRange v1 v2) = smpEncode (v1, v2)+  smpP =+    maybe (fail "invalid version range") pure+      =<< safeVersionRange <$> smpP <*> smpP++instance StrEncoding VersionRange where+  strEncode (VRange v1 v2)+    | v1 == v2 = strEncode v1+    | otherwise = strEncode v1 <> "-" <> strEncode v2+  strP = do+    v1 <- strP+    v2 <- maybe (pure v1) (const strP) =<< optional (A.char '-')+    maybe (fail "invalid version range") pure $ safeVersionRange v1 v2++instance ToJSON VersionRange where+  toJSON (VRange v1 v2) = toJSON (v1, v2)+  toEncoding (VRange v1 v2) = toEncoding (v1, v2)++instance FromJSON VersionRange where+  parseJSON v =+    (\(v1, v2) -> maybe (Left "bad VersionRange") Right $ safeVersionRange v1 v2)+      <$?> parseJSON v++class VersionI a where+  type VersionRangeT a+  version :: a -> Version+  toVersionRangeT :: a -> VersionRange -> VersionRangeT a++class VersionRangeI a where+  type VersionT a+  versionRange :: a -> VersionRange+  toVersionT :: a -> Version -> VersionT a++instance VersionI Version where+  type VersionRangeT Version = VersionRange+  version = id+  toVersionRangeT _ vr = vr++instance VersionRangeI VersionRange where+  type VersionT VersionRange = Version+  versionRange = id+  toVersionT _ v = v++newtype Compatible a = Compatible_ a++pattern Compatible :: a -> Compatible a+pattern Compatible a <- Compatible_ a++{-# COMPLETE Compatible #-}++isCompatible :: VersionI a => a -> VersionRange -> Bool+isCompatible x (VRange v1 v2) = let v = version x in v1 <= v && v <= v2++isCompatibleRange :: VersionRangeI a => a -> VersionRange -> Bool+isCompatibleRange x (VRange min2 max2) = min1 <= max2 && min2 <= max1+  where+    VRange min1 max1 = versionRange x++proveCompatible :: VersionI a => a -> VersionRange -> Maybe (Compatible a)+proveCompatible x vr = x `mkCompatibleIf` (x `isCompatible` vr)++compatibleVersion :: VersionRangeI a => a -> VersionRange -> Maybe (Compatible (VersionT a))+compatibleVersion x vr =+  toVersionT x (min max1 max2) `mkCompatibleIf` isCompatibleRange x vr+  where+    max1 = maxVersion $ versionRange x+    max2 = maxVersion vr++mkCompatibleIf :: a -> Bool -> Maybe (Compatible a)+x `mkCompatibleIf` cond = if cond then Just $ Compatible_ x else Nothing
tests/AgentTests.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}@@ -11,6 +10,7 @@ module AgentTests (agentTests) where  import AgentTests.ConnectionRequestTests+import AgentTests.DoubleRatchetTests (doubleRatchetTests) import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.SQLiteTests (storeTests) import Control.Concurrent@@ -22,6 +22,7 @@ import SMPClient (testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as A+import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..)) import Simplex.Messaging.Util (bshow)@@ -32,10 +33,11 @@ agentTests :: ATransport -> Spec agentTests (ATransport t) = do   describe "Connection request" connectionRequestTests+  describe "Double ratchet tests" doubleRatchetTests   describe "Functional API" $ functionalAPITests (ATransport t)   describe "SQLite store" storeTests   describe "SMP agent protocol syntax" $ syntaxTests t-  describe "Establishing duplex connection" do+  describe "Establishing duplex connection" $ do     it "should connect via one server and one agent" $       smpAgentTest2_1_1 $ testDuplexConnection t     it "should connect via one server and one agent (random IDs)" $@@ -48,19 +50,19 @@       smpAgentTest2_2_2 $ testDuplexConnection t     it "should connect via 2 servers and 2 agents (random IDs)" $       smpAgentTest2_2_2 $ testDuplexConnRandomIds t-  describe "Establishing connections via `contact connection`" do+  describe "Establishing connections via `contact connection`" $ do     it "should connect via contact connection with one server and 3 agents" $       smpAgentTest3 $ testContactConnection t     it "should connect via contact connection with one server and 2 agents (random IDs)" $       smpAgentTest2_2_1 $ testContactConnRandomIds t     it "should support rejecting contact request" $       smpAgentTest2_2_1 $ testRejectContactRequest t-  describe "Connection subscriptions" do+  describe "Connection subscriptions" $ do     it "should connect via one server and one agent" $       smpAgentTest3_1_1 $ testSubscription t     it "should send notifications to client when server disconnects" $       smpAgentServerTest $ testSubscrNotification t-  describe "Message delivery" do+  describe "Message delivery" $ do     it "should deliver messages after losing server connection and re-connecting" $       smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t     it "should deliver pending messages after agent restarting" $@@ -81,7 +83,7 @@ -- | action and expected response -- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r` (#>) :: IO (ATransmissionOrError 'Agent) -> ATransmission 'Agent -> Expectation-action #> (corrId, cAlias, cmd) = action `shouldReturn` (corrId, cAlias, Right cmd)+action #> (corrId, connId, cmd) = action `shouldReturn` (corrId, connId, Right cmd)  -- | action and predicate for the response -- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p`@@ -89,13 +91,13 @@ action =#> p = action >>= (`shouldSatisfy` p . correctTransmission)  correctTransmission :: ATransmissionOrError a -> ATransmission a-correctTransmission (corrId, cAlias, cmdOrErr) = case cmdOrErr of-  Right cmd -> (corrId, cAlias, cmd)+correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of+  Right cmd -> (corrId, connId, cmd)   Left e -> error $ show e  -- | receive message to handle `h` and validate that it is the expected one (<#) :: Transport c => c -> ATransmission 'Agent -> Expectation-h <# (corrId, cAlias, cmd) = (h <#:) `shouldReturn` (corrId, cAlias, Right cmd)+h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, Right cmd)  -- | receive message to handle `h` and validate it using predicate `p` (<#=) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation@@ -116,39 +118,40 @@ testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO () testDuplexConnection _ alice bob = do   ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")-  let cReq' = serializeConnReq cReq+  let cReq' = strEncode cReq   bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)   ("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)   alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)   bob <# ("", "alice", INFO "alice's connInfo")   bob <# ("", "alice", CON)   alice <# ("", "bob", CON)-  alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 1)-  alice <# ("", "bob", SENT 1)+  -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4+  alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 4)+  alice <# ("", "bob", SENT 4)   bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False-  bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)-  alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 2)-  alice <# ("", "bob", SENT 2)+  bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)+  alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 5)+  alice <# ("", "bob", SENT 5)   bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False-  bob #: ("13", "alice", "ACK 2") #> ("13", "alice", OK)-  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 3)-  bob <# ("", "alice", SENT 3)+  bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)+  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)+  bob <# ("", "alice", SENT 6)   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False-  alice #: ("3a", "bob", "ACK 3") #> ("3a", "bob", OK)-  bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 4)-  bob <# ("", "alice", SENT 4)+  alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)+  bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 7)+  bob <# ("", "alice", SENT 7)   alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False-  alice #: ("4a", "bob", "ACK 4") #> ("4a", "bob", OK)+  alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)   alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)-  bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 5)-  bob <# ("", "alice", MERR 5 (SMP AUTH))+  bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 8)+  bob <# ("", "alice", MERR 8 (SMP AUTH))   alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)   alice #:# "nothing else should be delivered to alice"  testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO () testDuplexConnRandomIds _ alice bob = do   ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")-  let cReq' = serializeConnReq cReq+  let cReq' = strEncode cReq   ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")   ("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:)   bobConn' `shouldBe` bobConn@@ -156,32 +159,32 @@   bob <# ("", aliceConn, INFO "alice's connInfo")   bob <# ("", aliceConn, CON)   alice <# ("", bobConn, CON)-  alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 1)-  alice <# ("", bobConn, SENT 1)+  alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 4)+  alice <# ("", bobConn, SENT 4)   bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False-  bob #: ("12", aliceConn, "ACK 1") #> ("12", aliceConn, OK)-  alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 2)-  alice <# ("", bobConn, SENT 2)+  bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)+  alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 5)+  alice <# ("", bobConn, SENT 5)   bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False-  bob #: ("13", aliceConn, "ACK 2") #> ("13", aliceConn, OK)-  bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 3)-  bob <# ("", aliceConn, SENT 3)+  bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)+  bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 6)+  bob <# ("", aliceConn, SENT 6)   alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False-  alice #: ("3a", bobConn, "ACK 3") #> ("3a", bobConn, OK)-  bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 4)-  bob <# ("", aliceConn, SENT 4)+  alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)+  bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 7)+  bob <# ("", aliceConn, SENT 7)   alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False-  alice #: ("4a", bobConn, "ACK 4") #> ("4a", bobConn, OK)+  alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)   alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)-  bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 5)-  bob <# ("", aliceConn, MERR 5 (SMP AUTH))+  bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 8)+  bob <# ("", aliceConn, MERR 8 (SMP AUTH))   alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)   alice #:# "nothing else should be delivered to alice"  testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO () testContactConnection _ alice bob tom = do   ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW CON")-  let cReq' = serializeConnReq cReq+  let cReq' = strEncode cReq    bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)   ("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)@@ -191,10 +194,10 @@   alice <# ("", "bob", INFO "bob's connInfo 2")   alice <# ("", "bob", CON)   bob <# ("", "alice", CON)-  alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 1)-  alice <# ("", "bob", SENT 1)+  alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 4)+  alice <# ("", "bob", SENT 4)   bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False-  bob #: ("13", "alice", "ACK 1") #> ("13", "alice", OK)+  bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)    tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)   ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)@@ -204,15 +207,15 @@   alice <# ("", "tom", INFO "tom's connInfo 2")   alice <# ("", "tom", CON)   tom <# ("", "alice", CON)-  alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 1)-  alice <# ("", "tom", SENT 1)+  alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 4)+  alice <# ("", "tom", SENT 4)   tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False-  tom #: ("23", "alice", "ACK 1") #> ("23", "alice", OK)+  tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)  testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO () testContactConnRandomIds _ alice bob = do   ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW CON")-  let cReq' = serializeConnReq cReq+  let cReq' = strEncode cReq    ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")   ("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)@@ -227,15 +230,15 @@   alice <# ("", bobConn, CON)   bob <# ("", aliceConn, CON) -  alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 1)-  alice <# ("", bobConn, SENT 1)+  alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 4)+  alice <# ("", bobConn, SENT 4)   bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False-  bob #: ("13", aliceConn, "ACK 1") #> ("13", aliceConn, OK)+  bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)  testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO () testRejectContactRequest _ alice bob = do   ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW CON")-  let cReq' = serializeConnReq cReq+  let cReq' = strEncode cReq   bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)   ("", "a_contact", Right (REQ aInvId "bob's info")) <- (alice <#:)   -- RJCT must use correct contact connection@@ -247,20 +250,20 @@ testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO () testSubscription _ alice1 alice2 bob = do   (alice1, "alice") `connect` (bob, "bob")-  bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 1)-  bob <# ("", "alice", SENT 1)+  bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 4)+  bob <# ("", "alice", SENT 4)   alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False-  alice1 #: ("1", "bob", "ACK 1") #> ("1", "bob", OK)-  bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 2)-  bob <# ("", "alice", SENT 2)+  alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)+  bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 5)+  bob <# ("", "alice", SENT 5)   alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False-  alice1 #: ("2", "bob", "ACK 2") #> ("2", "bob", OK)+  alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)   alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)   alice1 <# ("", "bob", END)-  bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 3)-  bob <# ("", "alice", SENT 3)+  bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 6)+  bob <# ("", "alice", SENT 6)   alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False-  alice2 #: ("22", "bob", "ACK 3") #> ("22", "bob", OK)+  alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)   alice1 #:# "nothing else should be delivered to alice1"  testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()@@ -276,22 +279,22 @@ testMsgDeliveryServerRestart t alice bob = do   withServer $ do     connect (alice, "alice") (bob, "bob")-    bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 1)-    bob <# ("", "alice", SENT 1)+    bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 4)+    bob <# ("", "alice", SENT 4)     alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False-    alice #: ("11", "bob", "ACK 1") #> ("11", "bob", OK)+    alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)     alice #:# "nothing else delivered before the server is killed"    alice <# ("", "bob", DOWN)-  bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 2)+  bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 5)   bob #:# "nothing else delivered before the server is restarted"   alice #:# "nothing else delivered before the server is restarted"    withServer $ do-    bob <# ("", "alice", SENT 2)+    bob <# ("", "alice", SENT 5)     alice <# ("", "bob", UP)     alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False-    alice #: ("12", "bob", "ACK 2") #> ("12", "bob", OK)+    alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)    removeFile testStoreLogFile   where@@ -302,14 +305,14 @@   withAgent $ \alice -> do     withServer $ do       connect (bob, "bob") (alice, "alice")-      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 1)-      alice <# ("", "bob", SENT 1)+      alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 4)+      alice <# ("", "bob", SENT 4)       bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False-      bob #: ("11", "alice", "ACK 1") #> ("11", "alice", OK)+      bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)       bob #:# "nothing else delivered before the server is down"      bob <# ("", "alice", DOWN)-    alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 2)+    alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 5)     alice #:# "nothing else delivered before the server is restarted"     bob #:# "nothing else delivered before the server is restarted" @@ -319,11 +322,11 @@       alice <#= \case         (corrId, "bob", cmd) ->           (corrId == "3" && cmd == OK)-            || (corrId == "" && cmd == SENT 2)+            || (corrId == "" && cmd == SENT 5)         _ -> False       bob <# ("", "alice", UP)       bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False-      bob #: ("12", "alice", "ACK 2") #> ("12", "alice", OK)+      bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)    removeFile testStoreLogFile   removeFile testDB@@ -336,7 +339,7 @@   connect (alice, "alice") (bob, "bob")    ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW INV")-  let cReq' = serializeConnReq cReq+  let cReq' = strEncode cReq   bob #: ("11", "alice2", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)   ("", "bob2", Right (CONF _confId "bob's connInfo")) <- (alice <#:)   -- below commands would be needed to accept bob's connection, but alice does not@@ -351,11 +354,11 @@   -- alice <# ("", "bob", SENT 1)   -- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False   -- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)-  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 2)-  bob <# ("", "alice", SENT 2)+  bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 5)+  bob <# ("", "alice", SENT 5)   -- if delivery is blocked it won't go further   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False-  alice #: ("3", "bob", "ACK 2") #> ("3", "bob", OK)+  alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)  testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO () testMsgDeliveryQuotaExceeded _ alice bob = do@@ -368,14 +371,14 @@     alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False   (_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND :over quota") -  alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 1)+  alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 4)   -- if delivery is blocked it won't go further-  alice <# ("", "bob2", SENT 1)+  alice <# ("", "bob2", SENT 4)  connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO () connect (h1, name1) (h2, name2) = do   ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")-  let cReq' = serializeConnReq cReq+  let cReq' = strEncode cReq   h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)   ("", _, Right (CONF connId "info2")) <- (h1 <#:)   h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)@@ -396,7 +399,7 @@ -- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString) -- connect' h1 h2 = do --   ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW INV")---   let cReq' = serializeConnReq cReq+--   let cReq' = strEncode cReq --   ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2") --   ("", _, Right (REQ connId "info2")) <- (h1 <#:) --   h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False@@ -405,28 +408,35 @@ --   h1 <# ("", conn2, CON) --   pure (conn1, conn2) -samplePublicKey :: ByteString-samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj-toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP-Tm4sokaFDTIG3QJFzOjC-_9nW4MUjAOFll9PCp9kaEFHJ_YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju_f6kAayvYKW3_lbJNXCmyinAccBosO08_0sUxvtuniIo18kfYJE0UmP1ReCjhMP-O-yOmwZJini_QelJk_Pez8IIDDWnY1qYQsN_q7ocjakOYrpGG7mig6JMFpDJtD6istR"+sampleDhKey :: ByteString+sampleDhKey = "MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="  syntaxTests :: forall c. Transport c => TProxy c -> Spec syntaxTests t = do   it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")-  describe "NEW" do-    describe "valid" do-      -- TODO: add tests with defined connection alias+  describe "NEW" $ do+    describe "valid" $ do+      -- TODO: add tests with defined connection id       it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False-    describe "invalid" do-      -- TODO: add tests with defined connection alias+    describe "invalid" $ do+      -- TODO: add tests with defined connection id       it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX") -  describe "JOIN" do-    describe "valid" do-      -- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided)-      -- TODO: add tests with defined connection alias+  describe "JOIN" $ do+    describe "valid" $ do       it "using same server as in invitation" $-        ("311", "a", "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2Flocalhost%3A5000%2F1234-w%3D%3D%23&e2e=" <> urlEncode True samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH")-    describe "invalid" do-      -- TODO: JOIN is not merged yet - to be added+        ( "311",+          "a",+          "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"+            <> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="+            <> "%40localhost%3A5001%2F3456-w%3D%3D%23"+            <> urlEncode True sampleDhKey+            <> "&v=1"+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"+            <> " 14\nbob's connInfo"+        )+          >#> ("311", "a", "ERR SMP AUTH")+    describe "invalid" $ do       it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")   where     -- simple test for one command with the expected response@@ -435,4 +445,4 @@      -- simple test for one command with a predicate for the expected response     (>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation-    command >#>= p = smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, cAlias, cmd) -> (cId, cAlias, B.words cmd))+    command >#>= p = smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, connId, cmd) -> (cId, connId, B.words cmd))
tests/AgentTests/ConnectionRequestTests.hs view
@@ -1,11 +1,18 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}  module AgentTests.ConnectionRequestTests where +import Data.ByteString (ByteString)+import Network.HTTP.Types (urlEncode) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C-import Simplex.Messaging.Parsers (parseAll)+import Simplex.Messaging.Crypto.Ratchet+import Simplex.Messaging.Encoding.String+import Simplex.Messaging.Protocol (smpClientVRange)+import Simplex.Messaging.Version import Test.Hspec  uri :: String@@ -15,54 +22,118 @@ srv =   SMPServer     { host = "smp.simplex.im",-      port = Just "5223",-      keyHash = Just (C.KeyHash "\215m\248\251")+      port = "5223",+      keyHash = C.KeyHash "\215m\248\251"     }  queue :: SMPQueueUri queue =   SMPQueueUri     { smpServer = srv,-      senderId = "\215m\248\251",-      serverVerifyKey = reservedServerKey+      senderId = "\223\142z\251",+      clientVRange = smpClientVRange,+      dhPublicKey = testDhKey     } -appServer :: ConnReqScheme-appServer = CRSAppServer "simplex.chat" Nothing+testDhKey :: C.PublicKeyX25519+testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o=" -connectionRequest :: AConnectionRequest+testDhKeyStr :: ByteString+testDhKeyStr = strEncode testDhKey++testDhKeyStrUri :: ByteString+testDhKeyStrUri = urlEncode True testDhKeyStr++connReqData :: ConnReqUriData+connReqData =+  ConnReqUriData+    { crScheme = simplexChat,+      crAgentVRange = smpAgentVRange,+      crSmpQueues = [queue]+    }++testDhPubKey :: C.PublicKeyX448+testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U="++testE2ERatchetParams :: E2ERatchetParamsUri 'C.X448+testE2ERatchetParams = E2ERatchetParamsUri e2eEncryptVRange testDhPubKey testDhPubKey++testE2ERatchetParams13 :: E2ERatchetParamsUri 'C.X448+testE2ERatchetParams13 = E2ERatchetParamsUri (mkVersionRange 1 3) testDhPubKey testDhPubKey++connectionRequest :: AConnectionRequestUri connectionRequest =-  ACR SCMInvitation . CRInvitation $-    ConnReqData-      { crScheme = appServer,-        crSmpQueues = [queue],-        crEncryptKey = reservedServerKey-      }+  ACR SCMInvitation $+    CRInvitationUri connReqData testE2ERatchetParams +connectionRequest12 :: AConnectionRequestUri+connectionRequest12 =+  ACR SCMInvitation $+    CRInvitationUri+      connReqData {crAgentVRange = mkVersionRange 1 2, crSmpQueues = [queue, queue]}+      testE2ERatchetParams13+ connectionRequestTests :: Spec-connectionRequestTests = do+connectionRequestTests =   describe "connection request parsing / serializing" $ do     it "should serialize SMP queue URIs" $ do-      serializeSMPQueueUri queue {smpServer = srv {port = Nothing, keyHash = Nothing}}-        `shouldBe` "smp://smp.simplex.im/1234-w==#"-      serializeSMPQueueUri queue {smpServer = srv {keyHash = Nothing}}-        `shouldBe` "smp://smp.simplex.im:5223/1234-w==#"-      serializeSMPQueueUri queue {smpServer = srv {port = Nothing}}-        `shouldBe` "smp://1234-w==@smp.simplex.im/1234-w==#"-      serializeSMPQueueUri queue-        `shouldBe` "smp://1234-w==@smp.simplex.im:5223/1234-w==#"+      strEncode (queue :: SMPQueueUri) {smpServer = srv {port = ""}}+        `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr+      strEncode queue {clientVRange = mkVersionRange 1 2}+        `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr     it "should parse SMP queue URIs" $ do-      parseAll smpQueueUriP "smp://smp.simplex.im/1234-w==#"-        `shouldBe` Right queue {smpServer = srv {port = Nothing, keyHash = Nothing}}-      parseAll smpQueueUriP "smp://smp.simplex.im:5223/1234-w==#"-        `shouldBe` Right queue {smpServer = srv {keyHash = Nothing}}-      parseAll smpQueueUriP "smp://1234-w==@smp.simplex.im/1234-w==#"-        `shouldBe` Right queue {smpServer = srv {port = Nothing}}-      parseAll smpQueueUriP "smp://1234-w==@smp.simplex.im:5223/1234-w==#"+      strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> testDhKeyStr)+        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}+      strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr)+        `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}}+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr)         `shouldBe` Right queue+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc")+        `shouldBe` Right queue+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1-2&dh=" <> testDhKeyStr)+        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}+      strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc")+        `shouldBe` Right queue {clientVRange = mkVersionRange 1 2}     it "should serialize connection requests" $ do-      serializeConnReq connectionRequest-        `shouldBe` "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F1234-w%3D%3D%23&e2e=rsa%3AMBowDQYJKoZIhvcNAQEBBQADCQAwBgIBAAIBAA%3D%3D"+      strEncode connectionRequest+        `shouldBe` "https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"+        <> testDhKeyStrUri+        <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"+      strEncode connectionRequest12+        `shouldBe` "https://simplex.chat/invitation#/?v=1-2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"+        <> testDhKeyStrUri+        <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"+        <> testDhKeyStrUri+        <> "&e2e=v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"     it "should parse connection requests" $ do-      parseAll connReqP "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F1234-w%3D%3D%23&e2e=rsa%3AMBowDQYJKoZIhvcNAQEBBQADCQAwBgIBAAIBAA%3D%3D"+      strDecode+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"+            <> testDhKeyStrUri+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"+            <> "&v=1"+        )         `shouldBe` Right connectionRequest+      strDecode+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"+            <> testDhKeyStrUri+            <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"+            <> "&v=1"+        )+        `shouldBe` Right connectionRequest+      strDecode+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"+            <> testDhKeyStrUri+            <> "&e2e=v%3D1-1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"+            <> "&v=1-1"+        )+        `shouldBe` Right connectionRequest+      strDecode+        ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26extra_param%3Dabc%26dh%3D"+            <> testDhKeyStrUri+            <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"+            <> testDhKeyStrUri+            <> "&e2e=extra_key%3Dnew%26v%3D1-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"+            <> "&some_new_param=abc"+            <> "&v=1-2"+        )+        `shouldBe` Right connectionRequest12
+ tests/AgentTests/DoubleRatchetTests.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}++module AgentTests.DoubleRatchetTests where++import Control.Concurrent.STM+import Control.Monad.Except+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as J+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.Map.Strict as M+import Simplex.Messaging.Crypto (Algorithm (..), AlgorithmI, CryptoError, DhAlgorithm)+import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Crypto.Ratchet+import Simplex.Messaging.Encoding+import Simplex.Messaging.Parsers (parseAll)+import Simplex.Messaging.Util ((<$$>))+import Test.Hspec++doubleRatchetTests :: Spec+doubleRatchetTests = do+  describe "double-ratchet encryption/decryption" $ do+    it "should serialize and parse message header" testMessageHeader+    it "should encrypt and decrypt messages" $ do+      withRatchets @X25519 testEncryptDecrypt+      withRatchets @X448 testEncryptDecrypt+    it "should encrypt and decrypt skipped messages" $ do+      withRatchets @X25519 testSkippedMessages+      withRatchets @X448 testSkippedMessages+    it "should encrypt and decrypt many messages" $ do+      withRatchets @X25519 testManyMessages+    it "should allow skipped after ratchet advance" $ do+      withRatchets @X25519 testSkippedAfterRatchetAdvance+    it "should encode/decode ratchet as JSON" $ do+      testKeyJSON C.SX25519+      testKeyJSON C.SX448+      testRatchetJSON C.SX25519+      testRatchetJSON C.SX448+    it "should agree the same ratchet parameters" $ do+      testX3dh C.SX25519+      testX3dh C.SX448++paddedMsgLen :: Int+paddedMsgLen = 100++fullMsgLen :: Int+fullMsgLen = 1 + fullHeaderLen + C.authTagSize + paddedMsgLen++testMessageHeader :: Expectation+testMessageHeader = do+  (k, _) <- C.generateKeyPair' @X25519+  let hdr = MsgHeader {msgMaxVersion = e2eEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0}+  parseAll (smpP @(MsgHeader 'X25519)) (smpEncode hdr) `shouldBe` Right hdr++pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString)+pattern Decrypted msg <- Right (Right msg)++type TestRatchets a = (AlgorithmI a, DhAlgorithm a) => TVar (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO ()++testEncryptDecrypt :: TestRatchets a+testEncryptDecrypt alice bob = do+  (bob, "hello alice") #> alice+  (alice, "hello bob") #> bob+  Right b1 <- encrypt bob "how are you, alice?"+  Right b2 <- encrypt bob "are you there?"+  Right b3 <- encrypt bob "hey?"+  Right a1 <- encrypt alice "how are you, bob?"+  Right a2 <- encrypt alice "are you there?"+  Right a3 <- encrypt alice "hey?"+  Decrypted "how are you, alice?" <- decrypt alice b1+  Decrypted "are you there?" <- decrypt alice b2+  Decrypted "hey?" <- decrypt alice b3+  Decrypted "how are you, bob?" <- decrypt bob a1+  Decrypted "are you there?" <- decrypt bob a2+  Decrypted "hey?" <- decrypt bob a3+  (bob, "I'm here, all good") #> alice+  (alice, "I'm here too, same") #> bob+  pure ()++testSkippedMessages :: TestRatchets a+testSkippedMessages alice bob = do+  Right msg1 <- encrypt bob "hello alice"+  Right msg2 <- encrypt bob "hello there again"+  Right msg3 <- encrypt bob "are you there?"+  Decrypted "are you there?" <- decrypt alice msg3+  Right (Left C.CERatchetDuplicateMessage) <- decrypt alice msg3+  Decrypted "hello there again" <- decrypt alice msg2+  Decrypted "hello alice" <- decrypt alice msg1+  pure ()++testManyMessages :: TestRatchets a+testManyMessages alice bob = do+  (bob, "b1") #> alice+  (bob, "b2") #> alice+  (bob, "b3") #> alice+  (bob, "b4") #> alice+  (alice, "a5") #> bob+  (alice, "a6") #> bob+  (alice, "a7") #> bob+  (bob, "b8") #> alice+  (alice, "a9") #> bob+  (alice, "a10") #> bob+  (bob, "b11") #> alice+  (bob, "b12") #> alice+  (alice, "a14") #> bob+  (bob, "b15") #> alice+  (bob, "b16") #> alice++testSkippedAfterRatchetAdvance :: TestRatchets a+testSkippedAfterRatchetAdvance alice bob = do+  (bob, "b1") #> alice+  Right b2 <- encrypt bob "b2"+  Right b3 <- encrypt bob "b3"+  Right b4 <- encrypt bob "b4"+  (alice, "a5") #> bob+  Right b5 <- encrypt bob "b5"+  Right b6 <- encrypt bob "b6"+  (bob, "b7") #> alice+  Right b8 <- encrypt bob "b8"+  Right b9 <- encrypt bob "b9"+  (alice, "a10") #> bob+  Right b11 <- encrypt bob "b11"+  Right b12 <- encrypt bob "b12"+  (alice, "a14") #> bob+  Decrypted "b12" <- decrypt alice b12+  Decrypted "b2" <- decrypt alice b2+  -- fails on duplicate message+  Left C.CERatchetHeader <- decrypt alice b2+  (alice, "a15") #> bob+  Right a16 <- encrypt bob "a16"+  Right a17 <- encrypt bob "a17"+  Decrypted "b8" <- decrypt alice b8+  Decrypted "b3" <- decrypt alice b3+  Decrypted "b4" <- decrypt alice b4+  Decrypted "b5" <- decrypt alice b5+  Decrypted "b6" <- decrypt alice b6+  (alice, "a18") #> bob+  Decrypted "a16" <- decrypt alice a16+  Decrypted "a17" <- decrypt alice a17+  Decrypted "b9" <- decrypt alice b9+  Decrypted "b11" <- decrypt alice b11+  pure ()++testKeyJSON :: forall a. AlgorithmI a => C.SAlgorithm a -> IO ()+testKeyJSON _ = do+  (k, pk) <- C.generateKeyPair' @a+  testEncodeDecode k+  testEncodeDecode pk++testRatchetJSON :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()+testRatchetJSON _ = do+  (alice, bob) <- initRatchets @a+  testEncodeDecode alice+  testEncodeDecode bob++testEncodeDecode :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Expectation+testEncodeDecode x = do+  let j = J.encode x+      x' = J.eitherDecode' j+  x' `shouldBe` Right x++testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()+testX3dh _ = do+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a e2eEncryptVersion+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a e2eEncryptVersion+  let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice+      paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob+  paramsAlice `shouldBe` paramsBob++(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (Ratchet a, SkippedMsgKeys), ByteString) -> TVar (Ratchet a, SkippedMsgKeys) -> Expectation+(alice, msg) #> bob = do+  Right msg' <- encrypt alice msg+  Decrypted msg'' <- decrypt bob msg'+  msg'' `shouldBe` msg++withRatchets :: forall a. (AlgorithmI a, DhAlgorithm a) => (TVar (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation+withRatchets test = do+  (a, b) <- initRatchets @a+  alice <- newTVarIO (a, M.empty)+  bob <- newTVarIO (b, M.empty)+  test alice bob `shouldReturn` ()++initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a)+initRatchets = do+  (pkBob1, pkBob2, e2eBob) <- generateE2EParams e2eEncryptVersion+  (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams e2eEncryptVersion+  let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice+      paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob+  (_, pkBob3) <- C.generateKeyPair'+  let bob = initSndRatchet (C.publicKey pkAlice2) pkBob3 paramsBob+      alice = initRcvRatchet pkAlice2 paramsAlice+  pure (alice, bob)++encrypt_ :: AlgorithmI a => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))+encrypt_ (rc, _) msg =+  runExceptT (rcEncrypt rc paddedMsgLen msg)+    >>= either (pure . Left) checkLength+  where+    checkLength (msg', rc') = do+      B.length msg' `shouldBe` fullMsgLen+      pure $ Right (msg', rc', SMDNoChange)++decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff))+decrypt_ (rc, smks) msg = runExceptT $ rcDecrypt rc smks msg++encrypt :: AlgorithmI a => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString)+encrypt = withTVar encrypt_++decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString))+decrypt = withTVar decrypt_++withTVar ::+  AlgorithmI a =>+  ((Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) ->+  TVar (Ratchet a, SkippedMsgKeys) ->+  ByteString ->+  IO (Either e r)+withTVar op rcVar msg =+  readTVarIO rcVar+    >>= (\(rc, smks) -> applyDiff smks <$$> (testEncodeDecode rc >> op (rc, smks) msg))+    >>= \case+      Right (res, rc', smks') -> atomically (writeTVar rcVar (rc', smks')) >> pure (Right res)+      Left e -> pure $ Left e+  where+    applyDiff smks (res, rc', smDiff) = (res, rc', applySMDiff smks smDiff)
tests/AgentTests/FunctionalAPITests.hs view
@@ -42,9 +42,6 @@       withSmpServer t testAsyncInitiatingOffline     it "should connect with joining client going offline before its queue activation" $       withSmpServer t testAsyncJoiningOfflineBeforeActivation-    -- TODO a valid test case but not trivial to implement, probably requires some agent rework-    xit "should connect with joining client going offline after its queue activation" $-      withSmpServer t testAsyncJoiningOfflineAfterActivation     it "should connect with both clients going offline" $       withSmpServer t testAsyncBothOffline @@ -60,25 +57,26 @@     get alice ##> ("", bobId, CON)     get bob ##> ("", aliceId, INFO "alice's connInfo")     get bob ##> ("", aliceId, CON)-    1 <- sendMessage alice bobId "hello"-    get alice ##> ("", bobId, SENT 1)-    2 <- sendMessage alice bobId "how are you?"-    get alice ##> ("", bobId, SENT 2)+    -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4+    4 <- sendMessage alice bobId "hello"+    get alice ##> ("", bobId, SENT 4)+    5 <- sendMessage alice bobId "how are you?"+    get alice ##> ("", bobId, SENT 5)     get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False-    ackMessage bob aliceId 1+    ackMessage bob aliceId 4     get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False-    ackMessage bob aliceId 2-    3 <- sendMessage bob aliceId "hello too"-    get bob ##> ("", aliceId, SENT 3)-    4 <- sendMessage bob aliceId "message 1"-    get bob ##> ("", aliceId, SENT 4)+    ackMessage bob aliceId 5+    6 <- sendMessage bob aliceId "hello too"+    get bob ##> ("", aliceId, SENT 6)+    7 <- sendMessage bob aliceId "message 1"+    get bob ##> ("", aliceId, SENT 7)     get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False-    ackMessage alice bobId 3+    ackMessage alice bobId 6     get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False-    ackMessage alice bobId 4+    ackMessage alice bobId 7     suspendConnection alice bobId-    5 <- sendMessage bob aliceId "message 2"-    get bob ##> ("", aliceId, MERR 5 (SMP AUTH))+    8 <- sendMessage bob aliceId "message 2"+    get bob ##> ("", aliceId, MERR 8 (SMP AUTH))     deleteConnection alice bobId     liftIO $ noMessages alice "nothing else should be delivered to alice"   pure ()@@ -127,9 +125,6 @@     exchangeGreetings alice bobId bob' aliceId   pure () -testAsyncJoiningOfflineAfterActivation :: IO ()-testAsyncJoiningOfflineAfterActivation = error "not implemented"- testAsyncBothOffline :: IO () testAsyncBothOffline = do   alice <- getSMPAgentClient cfg@@ -153,11 +148,11 @@  exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () exchangeGreetings alice bobId bob aliceId = do-  1 <- sendMessage alice bobId "hello"-  get alice ##> ("", bobId, SENT 1)+  4 <- sendMessage alice bobId "hello"+  get alice ##> ("", bobId, SENT 4)   get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False-  ackMessage bob aliceId 1-  2 <- sendMessage bob aliceId "hello too"-  get bob ##> ("", aliceId, SENT 2)+  ackMessage bob aliceId 4+  5 <- sendMessage bob aliceId "hello too"+  get bob ##> ("", aliceId, SENT 5)   get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False-  ackMessage alice bobId 2+  ackMessage alice bobId 5
tests/AgentTests/SQLiteTests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}@@ -12,7 +12,6 @@ import Control.Concurrent.STM import Control.Monad (replicateM_) import Control.Monad.Except (ExceptT, runExceptT)-import qualified Crypto.PubKey.RSA as R import Crypto.Random (drgNew) import Data.ByteString.Char8 (ByteString) import qualified Data.Text as T@@ -22,6 +21,7 @@ import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) import SMPClient (testKeyHash)+import Simplex.Messaging.Agent.Client () import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite@@ -70,42 +70,39 @@ -- TODO add null port tests storeTests :: Spec storeTests = do-  withStore2 do+  withStore2 $ do     describe "stress test" testConcurrentWrites-  withStore do-    describe "store setup" do+  withStore $ do+    describe "store setup" $ do       testCompiledThreadsafe       testForeignKeysEnabled-    describe "store methods" do-      describe "Queue and Connection management" do-        describe "createRcvConn" do+    describe "store methods" $ do+      describe "Queue and Connection management" $ do+        describe "createRcvConn" $ do           testCreateRcvConn           testCreateRcvConnRandomId           testCreateRcvConnDuplicate-        describe "createSndConn" do+        describe "createSndConn" $ do           testCreateSndConn           testCreateSndConnRandomID           testCreateSndConnDuplicate-        describe "getAllConnIds" testGetAllConnIds         describe "getRcvConn" testGetRcvConn-        describe "deleteConn" do+        describe "deleteConn" $ do           testDeleteRcvConn           testDeleteSndConn           testDeleteDuplexConn-        describe "upgradeRcvConnToDuplex" do+        describe "upgradeRcvConnToDuplex" $ do           testUpgradeRcvConnToDuplex-        describe "upgradeSndConnToDuplex" do+        describe "upgradeSndConnToDuplex" $ do           testUpgradeSndConnToDuplex-        describe "set Queue status" do-          describe "setRcvQueueStatus" do+        describe "set Queue status" $ do+          describe "setRcvQueueStatus" $ do             testSetRcvQueueStatus-            testSetRcvQueueStatusNoQueue-          describe "setSndQueueStatus" do+          describe "setSndQueueStatus" $ do             testSetSndQueueStatus-            testSetSndQueueStatusNoQueue           testSetQueueStatusDuplex-      describe "Msg management" do-        describe "create Msg" do+      describe "Msg management" $ do+        describe "create Msg" $ do           testCreateRcvMsg           testCreateSndMsg           testCreateRcvAndSndMsgs@@ -138,10 +135,10 @@   it "foreign keys should be enabled" . withStoreConnection $ \db -> do     let inconsistentQuery =           [sql|-            INSERT INTO connections-              (conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id)+            INSERT INTO snd_queues+              ( host, port, snd_id, conn_id, snd_private_key, e2e_dh_secret, status)             VALUES-              ("conn1", "smp.simplex.im", "5223", "1234", "smp.simplex.im", "5223", "2345");+              ('smp.simplex.im', '5223', '1234', '2345', x'', x'', 'new');           |]     DB.execute_ db inconsistentQuery       `shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)@@ -149,26 +146,35 @@ cData1 :: ConnData cData1 = ConnData {connId = "conn1"} +testPrivateSignKey :: C.APrivateSignKey+testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"++testPrivDhKey :: C.PrivateKeyX25519+testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk"++testDhSecret :: C.DhSecretX25519+testDhSecret = "01234567890123456789012345678901"+ rcvQueue1 :: RcvQueue rcvQueue1 =   RcvQueue-    { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,+    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,       rcvId = "1234",-      rcvPrivateKey = C.safePrivateKey (1, 2, 3),+      rcvPrivateKey = testPrivateSignKey,+      rcvDhSecret = testDhSecret,+      e2ePrivKey = testPrivDhKey,+      e2eDhSecret = Nothing,       sndId = Just "2345",-      decryptKey = C.safePrivateKey (1, 2, 3),-      verifyKey = Nothing,       status = New     }  sndQueue1 :: SndQueue sndQueue1 =   SndQueue-    { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,+    { server = SMPServer "smp.simplex.im" "5223" testKeyHash,       sndId = "3456",-      sndPrivateKey = C.safePrivateKey (1, 2, 3),-      encryptKey = C.PublicKey $ R.PublicKey 1 2 3,-      signKey = C.APrivateKey $ C.unPrivateKey (C.safePrivateKey (1, 2, 3) :: C.SafePrivateKey),+      sndPrivateKey = testPrivateSignKey,+      e2eDhSecret = testDhSecret,       status = New     } @@ -238,19 +244,10 @@     createSndConn store g cData1 sndQueue1       `throwsError` SEConnDuplicate -testGetAllConnIds :: SpecWith SQLiteStore-testGetAllConnIds =-  it "should get all conn aliases" $ \store -> do-    g <- newTVarIO =<< drgNew-    _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation-    _ <- runExceptT $ createSndConn store g cData1 {connId = "conn2"} sndQueue1-    getAllConnIds store-      `returnsResult` ["conn1" :: ConnId, "conn2" :: ConnId]- testGetRcvConn :: SpecWith SQLiteStore testGetRcvConn =   it "should get connection using rcv queue id and server" $ \store -> do-    let smpServer = SMPServer "smp.simplex.im" (Just "5223") testKeyHash+    let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash     let recipientId = "1234"     g <- newTVarIO =<< drgNew     _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation@@ -304,11 +301,10 @@     _ <- runExceptT $ createSndConn store g cData1 sndQueue1     let anotherSndQueue =           SndQueue-            { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,+            { server = SMPServer "smp.simplex.im" "5223" testKeyHash,               sndId = "2345",-              sndPrivateKey = C.safePrivateKey (1, 2, 3),-              encryptKey = C.PublicKey $ R.PublicKey 1 2 3,-              signKey = C.APrivateKey $ C.unPrivateKey (C.safePrivateKey (1, 2, 3) :: C.SafePrivateKey),+              sndPrivateKey = testPrivateSignKey,+              e2eDhSecret = testDhSecret,               status = New             }     upgradeRcvConnToDuplex store "conn1" anotherSndQueue@@ -324,12 +320,13 @@     _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation     let anotherRcvQueue =           RcvQueue-            { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,+            { server = SMPServer "smp.simplex.im" "5223" testKeyHash,               rcvId = "3456",-              rcvPrivateKey = C.safePrivateKey (1, 2, 3),+              rcvPrivateKey = testPrivateSignKey,+              rcvDhSecret = testDhSecret,+              e2ePrivKey = testPrivDhKey,+              e2eDhSecret = Nothing,               sndId = Just "4567",-              decryptKey = C.safePrivateKey (1, 2, 3),-              verifyKey = Nothing,               status = New             }     upgradeSndConnToDuplex store "conn1" anotherRcvQueue@@ -379,18 +376,6 @@     getConn store "conn1"       `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed}) -testSetRcvQueueStatusNoQueue :: SpecWith SQLiteStore-testSetRcvQueueStatusNoQueue =-  xit "should throw error on attempt to update status of non-existent RcvQueue" $ \store -> do-    setRcvQueueStatus store rcvQueue1 Confirmed-      `throwsError` SEConnNotFound--testSetSndQueueStatusNoQueue :: SpecWith SQLiteStore-testSetSndQueueStatusNoQueue =-  xit "should throw error on attempt to update status of non-existent SndQueue" $ \store -> do-    setSndQueueStatus store sndQueue1 Confirmed-      `throwsError` SEConnNotFound- hw :: ByteString hw = encodeUtf8 "Hello world!" @@ -405,16 +390,17 @@         MsgMeta           { integrity = MsgOk,             recipient = (unId internalId, ts),-            sender = (externalSndId, ts),+            sndMsgId = externalSndId,             broker = (brokerId, ts)           },+      msgType = A_MSG_,       msgBody = hw,       internalHash,       externalPrevSndHash = "hash_from_sender"     } -testCreateRcvMsg' :: SQLiteStore -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation-testCreateRcvMsg' st expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do+testCreateRcvMsg_ :: SQLiteStore -> PrevExternalSndId -> PrevRcvMsgHash -> ConnId -> RcvMsgData -> Expectation+testCreateRcvMsg_ st expectedPrevSndId expectedPrevHash connId rcvMsgData@RcvMsgData {..} = do   let MsgMeta {recipient = (internalId, _)} = msgMeta   updateRcvIds st connId     `returnsResult` (InternalId internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)@@ -427,9 +413,8 @@     g <- newTVarIO =<< drgNew     let ConnData {connId} = cData1     _ <- runExceptT $ createRcvConn st g cData1 rcvQueue1 SCMInvitation-    -- TODO getMsg to check message-    testCreateRcvMsg' st 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"-    testCreateRcvMsg' st 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"+    testCreateRcvMsg_ st 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"+    testCreateRcvMsg_ st 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"  mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData mkSndMsgData internalId internalSndId internalHash =@@ -437,13 +422,14 @@     { internalId,       internalSndId,       internalTs = ts,+      msgType = A_MSG_,       msgBody = hw,       internalHash,-      previousMsgHash = internalHash+      prevMsgHash = internalHash     } -testCreateSndMsg' :: SQLiteStore -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation-testCreateSndMsg' store expectedPrevHash connId sndMsgData@SndMsgData {..} = do+testCreateSndMsg_ :: SQLiteStore -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation+testCreateSndMsg_ store expectedPrevHash connId sndMsgData@SndMsgData {..} = do   updateSndIds store connId     `returnsResult` (internalId, internalSndId, expectedPrevHash)   createSndMsg store connId sndMsgData@@ -455,9 +441,8 @@     g <- newTVarIO =<< drgNew     let ConnData {connId} = cData1     _ <- runExceptT $ createSndConn store g cData1 sndQueue1-    -- TODO getMsg to check message-    testCreateSndMsg' store "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"-    testCreateSndMsg' store "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"+    testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"+    testCreateSndMsg_ store "hash_dummy" connId $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"  testCreateRcvAndSndMsgs :: SpecWith SQLiteStore testCreateRcvAndSndMsgs =@@ -466,9 +451,9 @@     let ConnData {connId} = cData1     _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation     _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1-    testCreateRcvMsg' store 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"-    testCreateRcvMsg' store 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"-    testCreateSndMsg' store "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"-    testCreateRcvMsg' store 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"-    testCreateSndMsg' store "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"-    testCreateSndMsg' store "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"+    testCreateRcvMsg_ store 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"+    testCreateRcvMsg_ store 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"+    testCreateSndMsg_ store "" connId $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"+    testCreateRcvMsg_ store 2 "rcv_hash_2" connId $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"+    testCreateSndMsg_ store "snd_hash_1" connId $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"+    testCreateSndMsg_ store "snd_hash_2" connId $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"
+ tests/CoreTests/EncodingTests.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module CoreTests.EncodingTests where++import Data.Bits (shiftR)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Internal (w2c)+import Data.Int (Int64)+import Data.Time.Clock.System (SystemTime (..), getSystemTime, utcToSystemTime)+import Data.Time.ISO8601 (parseISO8601)+import Simplex.Messaging.Encoding+import Simplex.Messaging.Parsers (parseAll)+import Test.Hspec+import Test.Hspec.QuickCheck (modifyMaxSuccess)+import Test.QuickCheck++int64 :: Int64+int64 = 1234567890123456789++s64 :: ByteString+s64 = B.pack $ map (w2c . fromIntegral . (int64 `shiftR`)) [56, 48, 40, 32, 24, 16, 8, 0]++encodingTests :: Spec+encodingTests = modifyMaxSuccess (const 1000) $ do+  describe "Encoding Int64" $ do+    it "should encode and decode Int64 example" $ do+      s64 `shouldBe` "\17\34\16\244\125\233\129\21"+      smpEncode int64 `shouldBe` s64+      parseAll smpP s64 `shouldBe` Right int64+    it "parse(encode(Int64) should equal the same Int64" . property $+      \i -> parseAll smpP (smpEncode i) == Right (i :: Int64)+  describe "Encoding SystemTime" $ do+    it "should encode and decode SystemTime" $ do+      t <- getSystemTime+      testSystemTime t+      Just t' <- pure $ utcToSystemTime <$> parseISO8601 "2022-01-01T10:24:05.000Z"+      systemSeconds t' `shouldBe` 1641032645+      testSystemTime t'+    it "parse(encode(SystemTime) should equal the same Int64" . property $+      \i -> parseAll smpP (smpEncode i) == Right (i :: Int64)+  where+    testSystemTime :: SystemTime -> Expectation+    testSystemTime t = do+      smpEncode t `shouldBe` smpEncode (systemSeconds t)+      parseAll smpP (smpEncode t) `shouldBe` Right t {systemNanoseconds = 0}
+ tests/CoreTests/ProtocolErrorTests.hs view
@@ -0,0 +1,18 @@+module CoreTests.ProtocolErrorTests where++import Simplex.Messaging.Agent.Protocol (AgentErrorType, agentErrorTypeP, serializeAgentError, serializeSmpErrorType, smpErrorTypeP)+import Simplex.Messaging.Parsers (parseAll)+import Simplex.Messaging.Protocol (ErrorType)+import Test.Hspec+import Test.Hspec.QuickCheck (modifyMaxSuccess)+import Test.QuickCheck++protocolErrorTests :: Spec+protocolErrorTests = modifyMaxSuccess (const 1000) $ do+  describe "errors parsing / serializing" $ do+    it "should parse SMP protocol errors" . property $ \err ->+      parseAll smpErrorTypeP (serializeSmpErrorType err)+        == Right (err :: ErrorType)+    it "should parse SMP agent errors" . property $ \err ->+      parseAll agentErrorTypeP (serializeAgentError err)+        == Right (err :: AgentErrorType)
+ tests/CoreTests/VersionRangeTests.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module CoreTests.VersionRangeTests where++import GHC.Generics (Generic)+import Generic.Random (genericArbitraryU)+import Simplex.Messaging.Version+import Test.Hspec+import Test.Hspec.QuickCheck (modifyMaxSuccess)+import Test.QuickCheck++data V = V1 | V2 | V3 | V4 | V5 deriving (Eq, Enum, Ord, Generic, Show)++instance Arbitrary V where arbitrary = genericArbitraryU++versionRangeTests :: Spec+versionRangeTests = modifyMaxSuccess (const 1000) $ do+  describe "VersionRange construction" $ do+    it "should fail on invalid range" $ do+      vr 1 1 `shouldBe` vr 1 1+      vr 1 2 `shouldBe` vr 1 2+      (pure $! vr 2 1) `shouldThrow` anyErrorCall+  describe "compatible version" $ do+    it "should choose mutually compatible max version" $ do+      (vr 1 1, vr 1 1) `compatible` Just 1+      (vr 1 1, vr 1 2) `compatible` Just 1+      (vr 1 2, vr 1 2) `compatible` Just 2+      (vr 1 2, vr 2 3) `compatible` Just 2+      (vr 1 3, vr 2 3) `compatible` Just 3+      (vr 1 3, vr 2 4) `compatible` Just 3+      (vr 1 2, vr 3 4) `compatible` Nothing+    it "should check if version is compatible" $ do+      isCompatible (1 :: Version) (vr 1 2) `shouldBe` True+      isCompatible (2 :: Version) (vr 1 2) `shouldBe` True+      isCompatible (2 :: Version) (vr 1 1) `shouldBe` False+      isCompatible (1 :: Version) (vr 2 2) `shouldBe` False+    it "compatibleVersion should pass isCompatible check" . property $+      \((min1, max1) :: (V, V)) ((min2, max2) :: (V, V)) ->+        min1 > max1 || min2 > max2 -- one of ranges is invalid, skip testing it+          || let w = fromIntegral . fromEnum+                 vr1 = mkVersionRange (w min1) (w max1) :: VersionRange+                 vr2 = mkVersionRange (w min2) (w max2) :: VersionRange+              in case compatibleVersion vr1 vr2 of+                   Just (Compatible v) -> v `isCompatible` vr1 && v `isCompatible` vr2+                   _ -> True+  where+    vr = mkVersionRange+    compatible :: (VersionRange, VersionRange) -> Maybe Version -> Expectation+    (vr1, vr2) `compatible` v = do+      (vr1, vr2) `checkCompatible` v+      (vr2, vr1) `checkCompatible` v+    (vr1, vr2) `checkCompatible` v =+      case compatibleVersion vr1 vr2 of+        Just (Compatible v') -> Just v' `shouldBe` v+        Nothing -> Nothing `shouldBe` v
− tests/ProtocolErrorTests.hs 
@@ -1,18 +0,0 @@-module ProtocolErrorTests where--import Simplex.Messaging.Agent.Protocol (AgentErrorType, agentErrorTypeP, serializeAgentError)-import Simplex.Messaging.Parsers (parseAll)-import Simplex.Messaging.Protocol (ErrorType, errorTypeP, serializeErrorType)-import Test.Hspec-import Test.Hspec.QuickCheck (modifyMaxSuccess)-import Test.QuickCheck--protocolErrorTests :: Spec-protocolErrorTests = modifyMaxSuccess (const 1000) $ do-  describe "errors parsing / serializing" $ do-    it "should parse SMP protocol errors" . property $ \err ->-      parseAll errorTypeP (serializeErrorType err)-        == Right (err :: ErrorType)-    it "should parse SMP agent errors" . property $ \err ->-      parseAll agentErrorTypeP (serializeAgentError err)-        == Right (err :: AgentErrorType)
tests/SMPAgentClient.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}@@ -157,21 +156,24 @@ cfg =   defaultAgentConfig     { tcpPort = agentTestPort,-      smpServers = L.fromList ["localhost:5000#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="],+      smpServers = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],       tbqSize = 1,       dbFile = testDB,       smpCfg =         smpDefaultConfig           { qSize = 1,-            defaultTransport = (testPort, transport @TCP),+            defaultTransport = (testPort, transport @TLS),             tcpTimeout = 500_000           },-      retryInterval = (retryInterval defaultAgentConfig) {initialInterval = 50_000}+      reconnectInterval = (reconnectInterval defaultAgentConfig) {initialInterval = 50_000},+      caCertificateFile = "tests/fixtures/ca.crt",+      privateKeyFile = "tests/fixtures/server.key",+      certificateFile = "tests/fixtures/server.crt"     }  withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =-  let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" (Just smpPort') testKeyHash]}+  let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}    in serverBracket         (\started -> runSMPAgentBlocking t started cfg')         afterProcess@@ -187,11 +189,12 @@  testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a testSMPAgentClientOn port' client = do-  runTransportClient agentTestHost port' $ \h -> do+  runTransportClient agentTestHost port' testKeyHash $ \h -> do     line <- liftIO $ getLn h-    if line == "Welcome to SMP agent v" <> currentSMPVersionStr+    if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion       then client h-      else error $ "wrong welcome message: " <> B.unpack line+      else do+        error $ "wrong welcome message: " <> B.unpack line  testSMPAgentClient :: (Transport c, MonadUnliftIO m) => (c -> m a) -> m a testSMPAgentClient = testSMPAgentClientOn agentTestPort
tests/SMPClient.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}@@ -8,14 +9,13 @@  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 Data.ByteString.Char8 (ByteString) import Network.Socket import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM@@ -31,27 +31,21 @@ testHost = "localhost"  testPort :: ServiceName-testPort = "5000"+testPort = "5001"  testPort2 :: ServiceName-testPort2 = "5001"--testKeyHashStr :: B.ByteString-testKeyHashStr = "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="--testBlockSize :: Maybe Int-testBlockSize = Just 8192+testPort2 = "5002" -testKeyHash :: Maybe C.KeyHash-testKeyHash = Just "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="+testKeyHash :: C.KeyHash+testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="  testStoreLogFile :: FilePath testStoreLogFile = "tests/tmp/smp-server-store.log"  testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a testSMPClient client =-  runTransportClient testHost testPort $ \h ->-    liftIO (runExceptT $ clientHandshake h testBlockSize testKeyHash) >>= \case+  runTransportClient testHost testPort testKeyHash $ \h ->+    liftIO (runExceptT $ clientHandshake h testKeyHash) >>= \case       Right th -> client th       Left e -> error $ show e @@ -62,54 +56,26 @@       tbqSize = 1,       serverTbqSize = 1,       msgQueueQuota = 4,-      queueIdBytes = 12,-      msgIdBytes = 6,+      queueIdBytes = 24,+      msgIdBytes = 24,       storeLog = Nothing,-      blockSize = 8192,-      serverPrivateKey =-        -- full RSA private key (only for tests)-        "MIIFIwIBAAKCAQEArZyrri/NAwt5buvYjwu+B/MQeJUszDBpRgVqNddlI9kNwDXu\-        \kaJ8chEhrtaUgXeSWGooWwqjXEUQE6RVbCC6QVo9VEBSP4xFwVVd9Fj7OsgfcXXh\-        \AqWxfctDcBZQ5jTUiJpdBc+Vz2ZkumVNl0W+j9kWm9nfkMLQj8c0cVSDxz4OKpZb\-        \qFuj0uzHkis7e7wsrKSKWLPg3M5ZXPZM1m9qn7SfJzDRDfJifamxWI7uz9XK2+Dp\-        \NkUQlGQgFJEv1cKN88JAwIqZ1s+TAQMQiB+4QZ2aNfSqGEzRJN7FMCKRK7pM0A9A\-        \PCnijyuImvKFxTdk8Bx1q+XNJzsY6fBrLWJZ+QKBgQCySG4tzlcEm+tOVWRcwrWh\-        \6zsczGZp9mbf9c8itRx6dlldSYuDG1qnddL70wuAZF2AgS1JZgvcRZECoZRoWP5q\-        \Kq2wvpTIYjFPpC39lxgUoA/DXKVKZZdan+gwaVPAPT54my1CS32VrOiAY4gVJ3LJ\-        \Mn1/FqZXUFQA326pau3loQKCAQEAoljmJMp88EZoy3HlHUbOjl5UEhzzVsU1TnQi\-        \QmPm+aWRe2qelhjW4aTvSVE5mAUJsN6UWTeMf4uvM69Z9I5pfw2pEm8x4+GxRibY\-        \iiwF2QNaLxxmzEHm1zQQPTgb39o8mgklhzFPill0JsnL3f6IkVwjFJofWSmpqEGs\-        \dFSMRSXUTVXh1p/o7QZrhpwO/475iWKVS7o48N/0Xp513re3aXw+DRNuVnFEaBIe\-        \TLvWM9Czn16ndAu1HYiTBuMvtRbAWnGZxU8ewzF4wlWK5tdIL5PTJDd1VhZJAKtB\-        \npDvJpwxzKmjAhcTmjx0ckMIWtdVaOVm/2gWCXDty2FEdg7koQKBgQDOUUguJ/i7\-        \q0jldWYRnVkotKnpInPdcEaodrehfOqYEHnvro9xlS6OeAS4Vz5AdH45zQ/4J3bV\-        \2cH66tNr18ebM9nL//t5G69i89R9W7szyUxCI3LmAIdi3oSEbmz5GQBaw4l6h9Wi\-        \n4FmFQaAXZrjQfO2qJcAHvWRsMp2pmqAGwKBgQDXaza0DRsKWywWznsHcmHa0cx8\-        \I4jxqGaQmLO7wBJRP1NSFrywy1QfYrVX9CTLBK4V3F0PCgZ01Qv94751CzN43TgF\-        \ebd/O9r5NjNTnOXzdWqETbCffLGd6kLgCMwPQWpM9ySVjXHWCGZsRAnF2F6M1O32\-        \43StIifvwJQFqSM3ewKBgCaW6y7sRY90Ua7283RErezd9EyT22BWlDlACrPu3FNC\-        \LtBf1j43uxBWBQrMLsHe2GtTV0xt9m0MfwZsm2gSsXcm4Xi4DJgfN+Z7rIlyy9UY\-        \PCDSdZiU1qSr+NrffDrXlfiAM1cUmCdUX7eKjp/ltkUHNaOGfSn5Pdr3MkAiD/Hf\-        \AoGBAKIdKCuOwuYlwjS9J+IRGuSSM4o+OxQdwGmcJDTCpyWb5dEk68e7xKIna3zf\-        \jc+H+QdMXv1nkRK9bZgYheXczsXaNZUSTwpxaEldzVD3hNvsXSgJRy9fqHwA4PBq\-        \vqiBHoO3RNbqg+2rmTMfDuXreME3S955ZiPZm4Z+T8Hj52mPAoGAQm5QH/gLFtY5\-        \+znqU/0G8V6BKISCQMxbbmTQVcTgGySrP2gVd+e4MWvUttaZykhWqs8rpr7mgpIY\-        \hul7Swx0SHFN3WpXu8uj+B6MLpRcCbDHO65qU4kQLs+IaXXsuuTjMvJ5LwjkZVrQ\-        \TmKzSAw7iVWwEUZR/PeiEKazqrpp9VU="+      caCertificateFile = "tests/fixtures/ca.crt",+      privateKeyFile = "tests/fixtures/server.key",+      certificateFile = "tests/fixtures/server.crt"     }  withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a-withSmpServerStoreLogOn t port client = do+withSmpServerStoreLogOn t port' client = do   s <- liftIO $ openReadStoreLog testStoreLogFile   serverBracket-    (\started -> runSMPServerBlocking started cfg {transports = [(port, t)], storeLog = Just s})+    (\started -> runSMPServerBlocking started cfg {transports = [(port', t)], storeLog = Just s})     (pure ())     client  withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a-withSmpServerThreadOn t port =+withSmpServerThreadOn t port' =   serverBracket-    (\started -> runSMPServerBlocking started cfg {transports = [(port, t)]})+    (\started -> runSMPServerBlocking started cfg {transports = [(port', t)]})     (pure ())  serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a@@ -126,7 +92,7 @@         _ -> pure ()  withSmpServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a-withSmpServerOn t port = withSmpServerThreadOn t port . const+withSmpServerOn t port' = withSmpServerThreadOn t port' . const  withSmpServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a withSmpServer t = withSmpServerOn t testPort@@ -141,8 +107,21 @@     run 0 hs = test hs     run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) -smpServerTest :: forall c. Transport c => TProxy c -> RawTransmission -> IO RawTransmission-smpServerTest _ cmd = runSmpTest $ \(h :: THandle c) -> tPutRaw h cmd >> tGetRaw h+smpServerTest ::+  forall c smp.+  (Transport c, Encoding smp) =>+  TProxy c ->+  (Maybe C.ASignature, ByteString, ByteString, smp) ->+  IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg)+smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h+  where+    tPut' h (sig, corrId, queueId, smp) = do+      let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)+      Right () <- tPut h (sig, t')+      pure ()+    tGet' h = do+      (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h+      pure (Nothing, corrId, qId, cmd)  smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation smpTest _ test' = runSmpTest test' `shouldReturn` ()@@ -162,12 +141,8 @@     _test [h1, h2, h3] = test' h1 h2 h3     _test _ = error "expected 3 handles" -tPutRaw :: Transport c => THandle c -> RawTransmission -> IO ()-tPutRaw h (sig, corrId, queueId, command) = do-  let t = B.intercalate " " [corrId, queueId, command]-  void $ tPut h (C.Signature sig, t)--tGetRaw :: Transport c => THandle c -> IO RawTransmission-tGetRaw h = do-  ("", (CorrId corrId, qId, Right cmd)) <- tGet fromServer h-  pure ("", corrId, encode qId, serializeCommand cmd)+smpTest4 :: Transport c => TProxy c -> (THandle c -> THandle c -> THandle c -> THandle c -> IO ()) -> Expectation+smpTest4 _ test' = smpTestN 4 _test+  where+    _test [h1, h2, h3, h4] = test' h1 h2 h3 h4+    _test _ = error "expected 4 handles"
tests/ServerTests.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  module ServerTests where @@ -17,6 +18,8 @@ import qualified Data.ByteString.Char8 as B import SMPClient import qualified Simplex.Messaging.Crypto as C+import Simplex.Messaging.Encoding+import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Transport import System.Directory (removeFile)@@ -25,37 +28,38 @@ import Test.HUnit import Test.Hspec -rsaKeySize :: Int-rsaKeySize = 2048 `div` 8- serverTests :: ATransport -> Spec serverTests t = do   describe "SMP syntax" $ syntaxTests t-  describe "SMP queues" do+  describe "SMP queues" $ do     describe "NEW and KEY commands, SEND messages" $ testCreateSecure t     describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t     describe "Stress test" $ stressTest t-  describe "SMP messages" do+  describe "SMP messages" $ do     describe "duplex communication over 2 SMP connections" $ testDuplex t-    describe "switch subscription to another SMP queue" $ testSwitchSub t+    describe "switch subscription to another TCP connection" $ testSwitchSub t   describe "Store log" $ testWithStoreLog t   describe "Timing of AUTH error" $ testTiming t+  describe "Message notifications" $ testMessageNotifications t -pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmissionOrError-pattern Resp corrId queueId command <- ("", (corrId, queueId, Right (Cmd SBroker command)))+pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission BrokerMsg+pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) -sendRecv :: Transport c => THandle c -> (ByteString, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError-sendRecv h (sgn, corrId, qId, cmd) = tPutRaw h (sgn, corrId, encode qId, cmd) >> tGet fromServer h+pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg+pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) -signSendRecv :: Transport c => THandle c -> C.SafePrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError-signSendRecv h pk (corrId, qId, cmd) = do-  let t = B.intercalate " " [corrId, encode qId, cmd]-  Right sig <- runExceptT $ C.sign pk t-  _ <- tPut h (sig, t)-  tGet fromServer h+sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)+sendRecv h@THandle {sessionId} (sgn, corrId, qId, cmd) = do+  let t = encodeTransmission sessionId (CorrId corrId, qId, cmd)+  Right () <- tPut h (sgn, t)+  tGet h -cmdSEND :: ByteString -> ByteString-cmdSEND msg = serializeCommand (Cmd SSender . SEND $ msg)+signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)+signSendRecv h@THandle {sessionId} pk (corrId, qId, cmd) = do+  let t = encodeTransmission sessionId (CorrId corrId, qId, cmd)+  Right sig <- runExceptT $ C.sign pk t+  Right () <- tPut h (Just sig, t)+  tGet h  (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion (actual, expected) #== message = assertEqual message expected actual@@ -64,132 +68,136 @@ testCreateSecure (ATransport t) =   it "should create (NEW) and secure (KEY) queue" $     smpTest t $ \h -> do-      (rPub, rKey) <- C.generateKeyPair rsaKeySize-      Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub)+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)+      let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)       (rId1, "") #== "creates queue" -      Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ")+      Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, SEND "hello")       (ok1, OK) #== "accepts unsigned SEND"       (sId1, sId) #== "same queue ID in response 1" -      Resp "" _ (MSG _ _ msg1) <- tGet fromServer h-      (msg1, "hello") #== "delivers message"+      Resp "" _ (MSG mId1 _ msg1) <- tGet h+      (dec mId1 msg1, Right "hello") #== "delivers message" -      Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, "ACK")+      Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK)       (ok4, OK) #== "replies OK when message acknowledged if no more messages" -      Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, "ACK")+      Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK)       (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" -      (sPub, sKey) <- C.generateKeyPair rsaKeySize-      Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ")+      (sPub, sKey) <- C.generateSignatureKeyPair C.SEd448+      Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, SEND "hello")       (err1, ERR AUTH) #== "rejects signed SEND"       (sId2, sId) #== "same queue ID in response 2" -      let keyCmd = "KEY " <> C.serializePubKey sPub-      Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, keyCmd)+      Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, KEY sPub)       (err2, ERR AUTH) #== "rejects KEY with wrong signature" -      Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, keyCmd)+      Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, KEY sPub)       (err3, ERR AUTH) #== "rejects KEY with sender's ID" -      Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, keyCmd)+      Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, KEY sPub)       (ok2, OK) #== "secures queue"       (rId2, rId) #== "same queue ID in response 3" -      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, keyCmd)+      Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)       (err4, ERR AUTH) #== "rejects KEY if already secured" -      Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11 hello again ")+      Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, SEND "hello again")       (ok3, OK) #== "accepts signed SEND" -      Resp "" _ (MSG _ _ msg) <- tGet fromServer h-      (msg, "hello again") #== "delivers message 2"+      Resp "" _ (MSG mId2 _ msg2) <- tGet h+      (dec mId2 msg2, Right "hello again") #== "delivers message 2" -      Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, "ACK")+      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 hello ")+      Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, SEND "hello")       (err5, ERR AUTH) #== "rejects unsigned SEND"  testCreateDelete :: ATransport -> Spec testCreateDelete (ATransport t) =   it "should create (NEW), suspend (OFF) and delete (DEL) queue" $     smpTest2 t $ \rh sh -> do-      (rPub, rKey) <- C.generateKeyPair rsaKeySize-      Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub)+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'+      Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)+      let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)       (rId1, "") #== "creates queue" -      (sPub, sKey) <- C.generateKeyPair rsaKeySize-      Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub)+      (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519+      Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub)       (ok1, OK) #== "secures queue" -      Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ")+      Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, SEND "hello")       (ok2, OK) #== "accepts signed SEND" -      Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND 7 hello 2 ")+      Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, SEND "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-      (msg1, "hello") #== "delivers message"+      Resp "" _ (MSG mId1 _ msg1) <- tGet rh+      (dec mId1 msg1, Right "hello") #== "delivers message" -      Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, "OFF")+      Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, OFF)       (err1, ERR AUTH) #== "rejects OFF with wrong signature" -      Resp "bcda" _ err2 <- signSendRecv rh rKey ("bcda", sId, "OFF")+      Resp "bcda" _ err2 <- signSendRecv rh rKey ("bcda", sId, OFF)       (err2, ERR AUTH) #== "rejects OFF with sender's ID" -      Resp "cdab" rId2 ok3 <- signSendRecv rh rKey ("cdab", rId, "OFF")+      Resp "cdab" rId2 ok3 <- signSendRecv rh rKey ("cdab", rId, OFF)       (ok3, OK) #== "suspends queue"       (rId2, rId) #== "same queue ID in response 2" -      Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND 5 hello ")+      Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, SEND "hello")       (err3, ERR AUTH) #== "rejects signed SEND" -      Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, "SEND 5 hello ")+      Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, SEND "hello")       (err4, ERR AUTH) #== "reject unsigned SEND too" -      Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, "OFF")+      Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF)       (ok4, OK) #== "accepts OFF when suspended" -      Resp "cdab" _ (MSG _ _ msg) <- signSendRecv rh rKey ("cdab", rId, "SUB")-      (msg, "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"+      Resp "cdab" _ (MSG mId2 _ msg2) <- signSendRecv rh rKey ("cdab", rId, SUB)+      (dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)" -      Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, "DEL")+      Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL)       (err5, ERR AUTH) #== "rejects DEL with wrong signature" -      Resp "abcd" _ err6 <- signSendRecv rh rKey ("abcd", sId, "DEL")+      Resp "abcd" _ err6 <- signSendRecv rh rKey ("abcd", sId, DEL)       (err6, ERR AUTH) #== "rejects DEL with sender's ID" -      Resp "bcda" rId3 ok6 <- signSendRecv rh rKey ("bcda", rId, "DEL")+      Resp "bcda" rId3 ok6 <- signSendRecv rh rKey ("bcda", rId, DEL)       (ok6, OK) #== "deletes queue"       (rId3, rId) #== "same queue ID in response 3" -      Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ")+      Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, SEND "hello")       (err7, ERR AUTH) #== "rejects signed SEND when deleted" -      Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, "SEND 5 hello ")+      Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, SEND "hello")       (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted" -      Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, "ACK")+      Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK)       (err11, ERR AUTH) #== "rejects ACK when conn deleted - the second message is deleted" -      Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, "OFF")+      Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, OFF)       (err9, ERR AUTH) #== "rejects OFF when deleted" -      Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, "SUB")+      Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB)       (err10, ERR AUTH) #== "rejects SUB when deleted"  stressTest :: ATransport -> Spec stressTest (ATransport t) =   it "should create many queues, disconnect and re-connect" $     smpTest3 t $ \h1 h2 h3 -> do-      (rPub, rKey) <- C.generateKeyPair rsaKeySize+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519+      (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'       rIds <- forM [1 .. 50 :: Int] . const $ do-        Resp "" "" (IDS rId _) <- signSendRecv h1 rKey ("", "", "NEW " <> C.serializePubKey rPub)+        Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub)         pure rId       let subscribeQueues h = forM_ rIds $ \rId -> do-            Resp "" rId' OK <- signSendRecv h rKey ("", rId, "SUB")+            Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)             rId' `shouldBe` rId       closeConnection $ connection h1       subscribeQueues h2@@ -200,240 +208,309 @@ testDuplex (ATransport t) =   it "should create 2 simplex connections and exchange messages" $     smpTest2 t $ \alice bob -> do-      (arPub, arKey) <- C.generateKeyPair rsaKeySize-      Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializePubKey arPub)+      (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448+      (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'+      Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub)+      let aDec nonce = C.cbDecrypt (C.dh' aSrvDh aDhPriv) (C.cbNonce nonce)       -- aSnd ID is passed to Bob out-of-band -      (bsPub, bsKey) <- C.generateKeyPair rsaKeySize-      Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializePubKey bsPub)-      -- "key ..." is ad-hoc, different from SMP protocol+      (bsPub, bsKey) <- C.generateSignatureKeyPair C.SEd448+      Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, SEND $ "key " <> strEncode bsPub)+      -- "key ..." is ad-hoc, not a part of SMP protocol -      Resp "" _ (MSG _ _ msg1) <- tGet fromServer alice-      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK")-      ["key", bobKey] <- return $ B.words msg1-      (bobKey, C.serializePubKey bsPub) #== "key received from Bob"-      Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "KEY " <> bobKey)+      Resp "" _ (MSG mId1 _ msg1) <- tGet alice+      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK)+      Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1+      (bobKey, strEncode bsPub) #== "key received from Bob"+      Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub) -      (brPub, brKey) <- C.generateKeyPair rsaKeySize-      Resp "abcd" _ (IDS bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", "NEW " <> C.serializePubKey brPub)-      Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, cmdSEND $ "reply_id " <> encode bSnd)-      -- "reply_id ..." is ad-hoc, it is not a part of SMP protocol+      (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448+      (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'+      Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub)+      let bDec nonce = C.cbDecrypt (C.dh' bSrvDh bDhPriv) (C.cbNonce nonce)+      Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, SEND $ "reply_id " <> encode bSnd)+      -- "reply_id ..." is ad-hoc, not a part of SMP protocol -      Resp "" _ (MSG _ _ msg2) <- tGet fromServer alice-      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK")-      ["reply_id", bId] <- return $ B.words msg2+      Resp "" _ (MSG mId2 _ msg2) <- tGet alice+      Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK)+      Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2       (bId, encode bSnd) #== "reply queue ID received from Bob" -      (asPub, asKey) <- C.generateKeyPair rsaKeySize-      Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializePubKey asPub)-      -- "key ..." is ad-hoc, different from SMP protocol+      (asPub, asKey) <- C.generateSignatureKeyPair C.SEd448+      Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, SEND $ "key " <> strEncode asPub)+      -- "key ..." is ad-hoc, not a part of  SMP protocol -      Resp "" _ (MSG _ _ msg3) <- tGet fromServer bob-      Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, "ACK")-      ["key", aliceKey] <- return $ B.words msg3-      (aliceKey, C.serializePubKey asPub) #== "key received from Alice"-      Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey)+      Resp "" _ (MSG mId3 _ msg3) <- tGet bob+      Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK)+      Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3+      (aliceKey, strEncode asPub) #== "key received from Alice"+      Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, KEY asPub) -      Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8 hi alice ")+      Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, SEND "hi alice") -      Resp "" _ (MSG _ _ msg4) <- tGet fromServer alice-      Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "ACK")-      (msg4, "hi alice") #== "message received from Bob"+      Resp "" _ (MSG mId4 _ msg4) <- tGet alice+      Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK)+      (aDec mId4 msg4, Right "hi alice") #== "message received from Bob" -      Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, cmdSEND "how are you bob")+      Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, SEND "how are you bob") -      Resp "" _ (MSG _ _ msg5) <- tGet fromServer bob-      Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "ACK")-      (msg5, "how are you bob") #== "message received from alice"+      Resp "" _ (MSG mId5 _ msg5) <- tGet bob+      Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK)+      (bDec mId5 msg5, Right "how are you bob") #== "message received from alice"  testSwitchSub :: ATransport -> Spec testSwitchSub (ATransport t) =   it "should create simplex connections and switch subscription to another TCP connection" $     smpTest3 t $ \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 test1 ")+      (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'+      Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub)+      let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)+      Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, SEND "test1")       (ok1, OK) #== "sent test message 1"-      Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK")+      Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, SEND "test2, no ACK")       (ok2, OK) #== "sent test message 2" -      Resp "" _ (MSG _ _ msg1) <- tGet fromServer rh1-      (msg1, "test1") #== "test message 1 delivered to the 1st TCP connection"-      Resp "abcd" _ (MSG _ _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, "ACK")-      (msg2, "test2, no ACK") #== "test message 2 delivered, no ACK"+      Resp "" _ (MSG mId1 _ msg1) <- tGet rh1+      (dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection"+      Resp "abcd" _ (MSG mId2 _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK)+      (dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK" -      Resp "bcda" _ (MSG _ _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, "SUB")-      (msg2', "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"-      Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, "ACK")+      Resp "bcda" _ (MSG mId2' _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB)+      (dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"+      Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK) -      Resp "" _ end <- tGet fromServer rh1+      Resp "" _ end <- tGet rh1       (end, END) #== "unsubscribed the 1st TCP connection" -      Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5 test3 ")+      Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, SEND "test3") -      Resp "" _ (MSG _ _ msg3) <- tGet fromServer rh2-      (msg3, "test3") #== "delivered to the 2nd TCP connection"+      Resp "" _ (MSG mId3 _ msg3) <- tGet rh2+      (dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection" -      Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, "ACK")+      Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK)       (err, ERR NO_MSG) #== "rejects ACK from the 1st TCP connection" -      Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, "ACK")+      Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK)       (ok3, OK) #== "accepts ACK from the 2nd TCP connection" -      1000 `timeout` tGet fromServer rh1 >>= \case+      1000 `timeout` tGet @BrokerMsg rh1 >>= \case         Nothing -> return ()         Just _ -> error "nothing else is delivered to the 1st TCP connection"  testWithStoreLog :: ATransport -> Spec testWithStoreLog at@(ATransport t) =   it "should store simplex queues to log and restore them after server restart" $ do-    (sPub1, sKey1) <- C.generateKeyPair rsaKeySize-    (sPub2, sKey2) <- C.generateKeyPair rsaKeySize+    (sPub1, sKey1) <- C.generateSignatureKeyPair C.SEd25519+    (sPub2, sKey2) <- C.generateSignatureKeyPair C.SEd25519+    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519+    recipientId1 <- newTVarIO ""+    recipientKey1 <- newTVarIO Nothing+    dhShared1 <- newTVarIO Nothing     senderId1 <- newTVarIO ""     senderId2 <- newTVarIO ""+    notifierId <- newTVarIO "" -    withSmpServerStoreLogOn at testPort . runTest t $ \h -> do-      (sId1, _, _) <- createAndSecureQueue h sPub1-      atomically $ writeTVar senderId1 sId1-      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")-      Resp "" _ (MSG _ _ "hello") <- tGet fromServer h+    withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do+      (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1+      Resp "abcd" _ (NID nId) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub)+      atomically $ do+        writeTVar recipientId1 rId1+        writeTVar recipientKey1 $ Just rKey1+        writeTVar dhShared1 $ Just dhShared+        writeTVar senderId1 sId1+        writeTVar notifierId nId+      Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)+      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello")+      Resp "" _ (MSG mId1 _ msg1) <- tGet h+      (C.cbDecrypt dhShared (C.cbNonce mId1) msg1, Right "hello") #== "delivered from queue 1"+      Resp "" _ NMSG <- tGet h1 -      (sId2, rId2, rKey2) <- createAndSecureQueue h sPub2+      (sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2       atomically $ writeTVar senderId2 sId2-      Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ")-      Resp "" _ (MSG _ _ "hello too") <- tGet fromServer h+      Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, SEND "hello too")+      Resp "" _ (MSG mId2 _ msg2) <- tGet h+      (C.cbDecrypt dhShared2 (C.cbNonce mId2) msg2, Right "hello too") #== "delivered from queue 2" -      Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, "DEL")+      Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)       pure () -    logSize `shouldReturn` 5+    logSize `shouldReturn` 6      withSmpServerThreadOn at testPort . runTest t $ \h -> do       sId1 <- readTVarIO senderId1       -- fails if store log is disabled-      Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")+      Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello")       pure () -    withSmpServerStoreLogOn at testPort . runTest t $ \h -> do+    withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do       -- this queue is restored+      rId1 <- readTVarIO recipientId1+      Just rKey1 <- readTVarIO recipientKey1+      Just dh1 <- readTVarIO dhShared1       sId1 <- readTVarIO senderId1-      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")+      nId <- readTVarIO notifierId+      Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)+      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello")+      Resp "cdab" _ (MSG mId3 _ msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)+      (C.cbDecrypt dh1 (C.cbNonce mId3) msg3, Right "hello") #== "delivered from restored queue"+      Resp "" _ NMSG <- tGet h1       -- this queue is removed - not restored       sId2 <- readTVarIO senderId2-      Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ")+      Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, SEND "hello too")       pure ()      logSize `shouldReturn` 1     removeFile testStoreLogFile   where-    createAndSecureQueue :: Transport c => THandle c -> SenderPublicKey -> IO (SenderId, RecipientId, C.SafePrivateKey)-    createAndSecureQueue h sPub = do-      (rPub, rKey) <- C.generateKeyPair rsaKeySize-      Resp "abcd" "" (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub)-      let keyCmd = "KEY " <> C.serializePubKey sPub-      Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd)-      (rId', rId) #== "same queue ID"-      pure (sId, rId, rKey)-     runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation     runTest _ test' server = do       testSMPClient test' `shouldReturn` ()       killThread server +    runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation+    runClient _ test' = testSMPClient test' `shouldReturn` ()+     logSize :: IO Int     logSize =       try (length . B.lines <$> B.readFile testStoreLogFile) >>= \case         Right l -> pure l         Left (_ :: SomeException) -> logSize +createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)+createAndSecureQueue h sPub = do+  (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448+  (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'+  Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)+  let dhShared = C.dh' srvDh dhPriv+  Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)+  (rId', rId) #== "same queue ID"+  pure (sId, rId, rKey, dhShared)+ testTiming :: ATransport -> Spec testTiming (ATransport t) =   it "should have similar time for auth error, whether queue exists or not, for all key sizes" $     smpTest2 t $ \rh sh ->       mapM_         (testSameTiming rh sh)-        [ (128, 128, 100),-          (128, 256, 25),-          (128, 384, 15),-          -- (128, 512, 15),-          (256, 128, 100),-          (256, 256, 25),-          (256, 384, 15),-          -- (256, 512, 15),-          (384, 128, 100),-          (384, 256, 25),-          (384, 384, 15)-          -- (384, 512, 15),-          -- (512, 128, 100),-          -- (512, 256, 25),-          -- (512, 384, 15),-          -- (512, 512, 15)+        [ (32, 32, 200),+          (32, 57, 100),+          (57, 32, 200),+          (57, 57, 100)         ]   where     timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const-    similarTime t1 t2 = abs (t1 - t2) / t1 < 0.2 `shouldBe` True+    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True     testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation-    testSameTiming rh sh (senderKeySize, badKeySize, n) = do-      (rPub, rKey) <- C.generateKeyPair rsaKeySize-      Resp "abcd" "" (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub)+    testSameTiming rh sh (goodKeySize, badKeySize, n) = do+      (rPub, rKey) <- generateKeys goodKeySize+      (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'+      Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)+      let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)+      Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) -      (sPub, sKey) <- C.generateKeyPair senderKeySize-      let keyCmd = "KEY " <> C.serializePubKey sPub-      Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd)+      (_, badKey) <- generateKeys badKeySize+      -- runTimingTest rh badKey rId "SUB" -      (_, badKey) <- C.generateKeyPair badKeySize-      Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND 5 hello ")-      timeWrongKey <- timeRepeat n $ do-        Resp "cdab" _ (ERR AUTH) <- signSendRecv sh badKey ("cdab", sId, "SEND 5 hello ")-        return ()-      timeNoQueue <- timeRepeat n $ do-        Resp "dabc" _ (ERR AUTH) <- signSendRecv sh badKey ("dabc", "1234", "SEND 5 hello ")-        return ()-      Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh-      similarTime timeNoQueue timeWrongKey+      (sPub, sKey) <- generateKeys goodKeySize+      Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub) -samplePubKey :: ByteString-samplePubKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR"+      Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, SEND "hello")+      Resp "" _ (MSG mId _ msg) <- tGet rh+      (dec mId msg, Right "hello") #== "delivered from queue" -sampleSig :: ByteString-sampleSig = "\128\207*\159eq\220i!\"\157\161\130\184\226\246\232_\\\170`\180\160\230sI\154\197\211\252\SUB\246\206ELL\t9K\ESC\196?\128\215%\222\148\NAK;9\155f\164\217e\242\156\CAN9\253\r\170\174'w\211\228?\205)\215\150\255\247z\DC115\DC1{\bn\145\rKD,K\230\202d8\233\167|7y\t_S\EM\248\EOT\216\172\167d\181\224)\137\ACKo\197j#c\217\243\228.\167\228\205\144\vr\134"+      runTimingTest sh badKey sId $ SEND "hello"+      where+        generateKeys = \case+          32 -> C.generateSignatureKeyPair C.SEd25519+          57 -> C.generateSignatureKeyPair C.SEd448+          _ -> error "unsupported key size"+        runTimingTest h badKey qId cmd = do+          timeWrongKey <- timeRepeat n $ do+            Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd)+            return ()+          timeNoQueue <- timeRepeat n $ do+            Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)+            return ()+          -- (putStrLn . unwords . map show)+          --   [ fromIntegral goodKeySize,+          --     fromIntegral badKeySize,+          --     timeWrongKey,+          --     timeNoQueue,+          --     timeWrongKey / timeNoQueue - 1+          --   ]+          similarTime timeNoQueue timeWrongKey +testMessageNotifications :: ATransport -> Spec+testMessageNotifications (ATransport t) =+  it "should create simplex connection, subscribe notifier and deliver notifications" $ do+    (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519+    (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519+    smpTest4 t $ \rh sh nh1 nh2 -> do+      (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub+      let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce)+      Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, NKEY nPub)+      Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, NSUB)+      Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, SEND "hello")+      Resp "" _ (MSG mId1 _ msg1) <- tGet rh+      (dec mId1 msg1, Right "hello") #== "delivered from queue"+      Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK)+      Resp "" _ NMSG <- tGet nh1+      Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)+      Resp "" _ END <- tGet nh1+      Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, SEND "hello again")+      Resp "" _ (MSG mId2 _ msg2) <- tGet rh+      (dec mId2 msg2, Right "hello again") #== "delivered from queue again"+      Resp "" _ NMSG <- tGet nh2+      1000 `timeout` tGet @BrokerMsg nh1 >>= \case+        Nothing -> return ()+        Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"++samplePubKey :: C.APublicVerifyKey+samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY="++sampleDhPubKey :: C.PublicKey 'C.X25519+sampleDhPubKey = "MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ="++sampleSig :: Maybe C.ASignature+sampleSig = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA=="+ syntaxTests :: ATransport -> Spec syntaxTests (ATransport t) = do-  it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX")-  describe "NEW" do-    it "no parameters" $ (sampleSig, "bcda", "", "NEW") >#> ("", "bcda", "", "ERR CMD SYNTAX")-    it "many parameters" $ (sampleSig, "cdab", "", "NEW 1 " <> samplePubKey) >#> ("", "cdab", "", "ERR CMD SYNTAX")-    it "no signature" $ ("", "dabc", "", "NEW " <> samplePubKey) >#> ("", "dabc", "", "ERR CMD NO_AUTH")-    it "queue ID" $ (sampleSig, "abcd", "12345678", "NEW " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH")-  describe "KEY" do-    it "valid syntax" $ (sampleSig, "bcda", "12345678", "KEY " <> samplePubKey) >#> ("", "bcda", "12345678", "ERR AUTH")-    it "no parameters" $ (sampleSig, "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX")-    it "many parameters" $ (sampleSig, "dabc", "12345678", "KEY 1 " <> samplePubKey) >#> ("", "dabc", "12345678", "ERR CMD SYNTAX")-    it "no signature" $ ("", "abcd", "12345678", "KEY " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD NO_AUTH")-    it "no queue ID" $ (sampleSig, "bcda", "", "KEY " <> samplePubKey) >#> ("", "bcda", "", "ERR CMD NO_AUTH")-  noParamsSyntaxTest "SUB"-  noParamsSyntaxTest "ACK"-  noParamsSyntaxTest "OFF"-  noParamsSyntaxTest "DEL"-  describe "SEND" do-    it "valid syntax 1" $ (sampleSig, "cdab", "12345678", "SEND 5 hello ") >#> ("", "cdab", "12345678", "ERR AUTH")-    it "valid syntax 2" $ (sampleSig, "dabc", "12345678", "SEND 11 hello there ") >#> ("", "dabc", "12345678", "ERR AUTH")-    it "no parameters" $ (sampleSig, "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX")-    it "no queue ID" $ (sampleSig, "bcda", "", "SEND 5 hello ") >#> ("", "bcda", "", "ERR CMD NO_QUEUE")-    it "bad message body 1" $ (sampleSig, "cdab", "12345678", "SEND 11 hello ") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX")-    it "bad message body 2" $ (sampleSig, "dabc", "12345678", "SEND hello ") >#> ("", "dabc", "12345678", "ERR CMD SYNTAX")-    it "bigger body" $ (sampleSig, "abcd", "12345678", "SEND 4 hello ") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX")-  describe "PING" do-    it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG")-  describe "broker response not allowed" do-    it "OK" $ (sampleSig, "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR CMD PROHIBITED")+  it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)+  describe "NEW" $ do+    it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)+    it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)+    it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)+    it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)+  describe "KEY" $ do+    it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH)+    it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX)+    it "many parameters" $ (sampleSig, "dabc", "12345678", (KEY_, ' ', ('\x01', 'A'), samplePubKey)) >#> ("", "dabc", "12345678", ERR $ CMD SYNTAX)+    it "no signature" $ ("", "abcd", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "abcd", "12345678", ERR $ CMD NO_AUTH)+    it "no queue ID" $ (sampleSig, "bcda", "", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH)+  noParamsSyntaxTest "SUB" SUB_+  noParamsSyntaxTest "ACK" ACK_+  noParamsSyntaxTest "OFF" OFF_+  noParamsSyntaxTest "DEL" DEL_+  describe "SEND" $ do+    it "valid syntax" $ (sampleSig, "cdab", "12345678", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)+    it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)+    it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_QUEUE)+  describe "PING" $ do+    it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG)+  describe "broker response not allowed" $ do+    it "OK" $ (sampleSig, "bcda", "12345678", OK_) >#> ("", "bcda", "12345678", ERR $ CMD UNKNOWN)   where-    noParamsSyntaxTest :: ByteString -> Spec-    noParamsSyntaxTest cmd = describe (B.unpack cmd) do-      it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH")-      it "wrong terminator" $ (sampleSig, "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR CMD SYNTAX")-      it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR CMD NO_AUTH")-      it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", "ERR CMD NO_AUTH")-    (>#>) :: RawTransmission -> RawTransmission -> Expectation+    noParamsSyntaxTest :: PartyI p => String -> CommandTag p -> Spec+    noParamsSyntaxTest description cmd = describe description $ do+      it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", ERR AUTH)+      it "wrong terminator" $ (sampleSig, "bcda", "12345678", (cmd, '=')) >#> ("", "bcda", "12345678", ERR $ CMD UNKNOWN)+      it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH)+      it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)+    (>#>) ::+      Encoding smp =>+      (Maybe C.ASignature, ByteString, ByteString, smp) ->+      (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->+      Expectation     command >#> response = smpServerTest t command `shouldReturn` response
tests/Test.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE TypeApplications #-}  import AgentTests (agentTests)-import ProtocolErrorTests+import CoreTests.EncodingTests+import CoreTests.ProtocolErrorTests+import CoreTests.VersionRangeTests import ServerTests-import Simplex.Messaging.Transport (TCP, Transport (..))+import Simplex.Messaging.Transport (TLS, Transport (..)) import Simplex.Messaging.Transport.WebSockets (WS) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import Test.Hspec@@ -12,8 +14,11 @@ main = do   createDirectoryIfMissing False "tests/tmp"   hspec $ do-    describe "Protocol errors" protocolErrorTests-    describe "SMP server via TCP" $ serverTests (transport @TCP)+    describe "Core tests" $ do+      describe "Encoding tests" encodingTests+      describe "Protocol error tests" protocolErrorTests+      describe "Version range" versionRangeTests+    describe "SMP server via TLS 1.3" $ serverTests (transport @TLS)     describe "SMP server via WebSockets" $ serverTests (transport @WS)-    describe "SMP client agent" $ agentTests (transport @TCP)+    describe "SMP client agent" $ agentTests (transport @TLS)   removeDirectoryRecursive "tests/tmp"