0.3.2 (#146)

SMP server CLI commands

.github/workflows/build.yml

@@ -47,26 +47,9 @@ jobs:
       matrix:
         include:
           - os: ubuntu-20.04
-            cache_path: ~/.stack
-            stack_args: "--test"
-            artifact_rel_path: /bin/dog-food
-            asset_name: dog-food-ubuntu-20_04-x86-64
+            asset_name: smp-server-ubuntu-20_04-x86-64
           - os: ubuntu-18.04
-            cache_path: ~/.stack
-            stack_args: "--test"
-            artifact_rel_path: /bin/dog-food
-            asset_name: dog-food-ubuntu-18_04-x86-64
-          # TODO re-enable tests for mac and windows when they consistently pass (remove stack_args altogether)
-          - os: macos-latest
-            cache_path: ~/.stack
-            stack_args: ""
-            artifact_rel_path: /bin/dog-food
-            asset_name: dog-food-macos-x86-64
-          - os: windows-latest
-            cache_path: C:/sr
-            stack_args: ""
-            artifact_rel_path: /bin/dog-food.exe
-            asset_name: dog-food-windows-x86-64
+            asset_name: smp-server-ubuntu-18_04-x86-64
     steps:
       - name: Clone project
         uses: actions/checkout@v2
@@ -81,13 +64,13 @@ jobs:
       - name: Cache dependencies
         uses: actions/cache@v2
         with:
-          path: ${{ matrix.cache_path }}
+          path: ~/.stack
           key: ${{ matrix.os }}-${{ hashFiles('stack.yaml') }}
 
       - name: Build & test
         id: build_test
         run: |
-          stack build ${{ matrix.stack_args }}
+          stack build --test
           echo "::set-output name=LOCAL_INSTALL_ROOT::$(stack path --local-install-root)"
 
       - name: Upload binaries to release
@@ -95,6 +78,6 @@ jobs:
         uses: svenstaro/upload-release-action@v2
         with:
           repo_token: ${{ secrets.GITHUB_TOKEN }}
-          file: ${{ steps.build_test.outputs.LOCAL_INSTALL_ROOT }}${{ matrix.artifact_rel_path }}
+          file: ${{ steps.build_test.outputs.LOCAL_INSTALL_ROOT }}/bin/smp-server
           asset_name: ${{ matrix.asset_name }}
           tag: ${{ github.ref }}

CHANGELOG.md

@@ -0,0 +1,31 @@
+# 0.3.2
+
+- Support websockets
+- SMP server CLI commands
+
+# 0.3.1
+
+- Released to hackage.org
+- SMP agent protocol changes:
+  - move SMP server from agent commands NEW/JOIN to agent config
+  - send CON to user only when the 1st party responds HELLO
+- Fix REPLY vulnerability
+- Fix transaction busy error
+
+# 0.3.0
+
+- SMP encrypted transport over TCP
+- Standard X509/PKCS8 encoding for RSA keys
+- Sign and verify agent messages
+- Verify message integrity based on previous message hash and ID
+- Prevent timing attack allowing to determine if queue exists
+- Only allow correct RSA keys and signature sizes
+
+# 0.2.0
+
+- SMP client library
+- SMP agent with E2E encryption
+
+# 0.1.0
+
+- SMP protocol server implementation without encryption

Dockerfile

@@ -1,10 +0,0 @@
-FROM haskell:8.8.4 AS build-stage
-# if you encounter "version `GLIBC_2.28' not found" error when running
-# chat client executable, build with the following base image instead:
-# FROM haskell:8.8.4-stretch AS build-stage
-COPY . /project
-WORKDIR /project
-RUN stack install
-
-FROM scratch AS export-stage
-COPY --from=build-stage /root/.local/bin/dog-food /

README.md

@@ -1,223 +1,69 @@
-# simplex-messaging
+# SimpleXMQ
 
-[![GitHub build](https://github.com/simplex-chat/simplex-messaging/workflows/build/badge.svg)](https://github.com/simplex-chat/simplex-messaging/actions?query=workflow%3Abuild)
-[![GitHub release](https://img.shields.io/github/v/release/simplex-chat/simplex-messaging)](https://github.com/simplex-chat/simplex-messaging/releases)
+[![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)
 
-## Federated chat - private, secure, decentralised
+## Message broker for unidirectional (simplex) queues
 
-See [simplex.chat](https://simplex.chat) website for chat demo and the explanations of the system and how SMP protocol works.
+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 semi-formally defined [here](https://github.com/simplex-chat/protocol).
+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.
 
-Currently only these features are available:
-- simple 1-to-1 chat with multiple people in the same terminal window.
-- auto-populated recipient name - just type your messages.
-- default server is available to play with - `smp.simplex.im:5223` - and you can deploy your own (`smp-server` executable in this repo).
-- no global identity or names visible to the server(s) - for the privacy of contacts and conversations.
-- E2E encryption, with public key that has to be passed out-of-band (see below)
-- authentication of each command/message with automatically generated RSA key pairs, separate for each conversation, the keys are not used as identity (2048 bit keys are used, it can be changed in [code via rsaKeySize setting](https://github.com/simplex-chat/simplex-messaging/blob/master/apps/dog-food/Main.hs))
+SimpleXMQ is implemented in Haskell - it benefits from robust software transactional memory (STM) and concurrency primitives that Haskell provides.
 
-Limitations/disclaimers:
-- no support for chat groups. It is coming in the next major version (i.e., not very soon:)
-- no delivery notifications - coming soon
-- no TCP transport encryption - coming soon (messages are encrypted e2e though, only random connection IDs and server commands are visible, but not the contents of the message)
-- system and protocol security was not audited yet, so you probably should NOT use it yet for high security communications - unless you know what you are doing.
+## SimpleXMQ roadmap
 
-## How to run chat client locally
+- Streams - high performance message queues. See [Streams RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-02-28-streams.md) for details.
+- "Small" connection groups, when each message will be sent by the SMP agent to multiple connections with a single client command. See [Groups RFC](https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-03-18-groups.md) for details.
+- SMP agents cluster to share connections and message management by multiple agents (for example, it would enable multi-device use for [simplex-chat](https://github.com/simplex-chat/simplex-chat)).
+- SMP queue redundancy and rotation in SMP agent duplex connections.
+- "Large" groups design and implementation. 
 
-Install [Haskell stack](https://docs.haskellstack.org/en/stable/README/):
+## Components
 
-```shell
-curl -sSL https://get.haskellstack.org/ | sh
-```
+### SMP server
 
-and build the project:
+[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.
 
-```shell
-$ git clone [email protected]:simplex-chat/simplex-messaging.git
-$ cd simplex-messaging
-$ stack install
-$ dog-food
-```
+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.
 
-If you'd prefer to not set up Haskell locally, on Linux you may instead build the chat client executable using [docker build with custom output](https://docs.docker.com/engine/reference/commandline/build/#custom-build-outputs):
+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>`.
 
-```shell
-$ git clone [email protected]:simplex-chat/simplex-messaging.git
-$ cd simplex-messaging
-$ DOCKER_BUILDKIT=1 docker build --output ~/.local/bin .
-$ dog-food
-```
+SMP server implements [SMP protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md).
 
-> **NOTE:** When running chat client executable built with the latter approach, if you encounter ``version `GLIBC_2.28' not found`` error, rebuild it with `haskell:8.8.4-stretch` base image instead (you'd have to change it in your local [Dockerfile](Dockerfile)).
+### SMP client library
 
-`dog-food` (as in "eating your own dog food" - it is an early prototype) starts chat client with default parameters. By default, app data directory is created in the home directory (`~/.simplex`, or `%APPDATA%/simplex` on Windows), and SQLite database file `smp-chat.db` is initialized in it. The default SMP server is `smp.simplex.im:5223`.
+[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:
+- execute commands with a functional API.
+- receive messages and other notifications via STM queue.
+- automatically send keep-alive commands.
 
-To specify a different file path for the chat database use `-d` command line option:
+### SMP agent
 
-```shell
-$ dog-food -d my-chat.db
-```
+[SMP agent library](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent.hs) can be used to run SMP agent as part of another application and to communicate with the agent via STM queues, without serializing and parsing commands and responses.
 
-If you deployed your own SMP server you can set client to use it via `-s` option:
+Haskell type [ACommand](https://github.com/simplex-chat/simplexmq/blob/master/src/Simplex/Messaging/Agent/Protocol.hs) represents SMP agent protocol to communicate via STM queues.
 
-```shell
-$ dog-food -s smp.example.com:5223
-```
+See [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI for the example of integrating SMP agent into another application.
 
-You can still talk to people using default or any other server, it only affects the location of the message queue when you initiate the connection (and the reply queue can be on another server, as set by the other party's client).
+[SMP agent executable](https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs) can be used to run a standalone SMP agent process that implements plaintext [SMP agent protocol](https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md) via TCP port 5224, so it can be used via telnet. It can be deployed in private networks to share access to the connections between multiple applications and services.
 
-Run `dog-food --help` to see all available options.
+## Using SMP server and SMP agent
 
-### Using chat client
+You can either run SMP server locally or try local SMP agent with the deployed demo server:
 
-Once chat client is started, use `/add <name1>` to create a new connection and generate an invitation to send to your contact via any other communication channel (`<name1>` - is any name you want to use for that contact).
+`smp1.simplex.im:5223#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=`
 
-Invitation has format `smp::<server>::<queue_id>::<public_key_for_this_queue_only>` - this needs to be shared with another party, via any other chat. It can only be used once - even if this is intercepted, the attacker would not be able to use it to send you the messages via this queue once your contact confirms that the connection is established.
+It's the easiest to try SMP agent via a prototype [simplex-chat](https://github.com/simplex-chat/simplex-chat) terminal UI.
 
-The party that received the invitation should use `/accept <name2> <invitation>` to accept the connection (`<name2>` is any name that the accepting party wants to use for you).
+## SMP server design
 
-For example, if Alice and Bob want to chat, with Alice initiating, Alice would use [in her chat client]:
+![SMP server design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/server.svg)
 
-```
-/add bob
-```
+## SMP agent design
 
-And then send the generated invitation to Bob out-of-band. Bob then would use [in his chat client]:
+![SMP agent design](https://raw.githubusercontent.com/simplex-chat/simplexmq/master/design/agent2.svg)
 
-```
-/accept alice <alice's invitation>
-```
+## License
 
-They would then use `@<name> <message>` commands to send messages. One may also press Space or just start typing a message to send a message to the contact that was the last.
-
-If you exit from chat client (or if internet connection is interrupted) you need to use `/chat <name>` to activate conversation with respective contact - it is not resumed automatically (it will improve soon).
-
-Since SMP doesn't use global identity (all account information is managed by clients), you should configure your name to use in invitations for your contacts:
-
-```
-/name alice
-```
-
-Now Alice's invitations would be generated with her name in it for others' convenience.
-
-Use `/help` in chat to see the list of available commands and their explanation.
-
-### Accessing chat history
-
-You can access your chat history by opening a connection to your SQLite database file and querying `messages` table, for example:
-
-```sql
-select * from messages
-where conn_alias = cast('alice' as blob)
-order by internal_id desc;
-
-select * from messages
-where conn_alias = cast('alice' as blob)
-and body like '%cats%';
-```
-
-> **NOTE:** Beware that SQLite foreign key constraints are disabled by default, and must be **[enabled separately for each database connection](https://sqlite.org/foreignkeys.html#fk_enable)**. The latter can be achieved by running `PRAGMA foreign_keys = ON;` command on an open database connection. By running data altering queries without enabling foreign keys prior to that, you may risk putting your database in an inconsistent state.
-
-## 🚧 [further README not up to date] SMP server demo 🏗
-
-This is a demo implementation of SMP ([simplex messaging protocol](https://github.com/simplex-chat/protocol/blob/master/simplex-messaging.md)) server.
-
-It has a very limited utility (if any) for real applications, as it lacks the following protocol features:
-
-- cryptographic signature verification, instead it simply compares provided "signature" with stored "public key", effectively treating them as plain text passwords.
-- there is no transport encryption
-
-Because of these limitations, it is easy to experiment with the protocol logic via telnet.
-
-You can either run it locally or try with the deployed demo server:
-
-```bash
-telnet smp.simplex.im 5223
-```
-
-## Run locally
-
-[Install stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/) and `stack run`.
-
-## Usage example
-
-Lines you should send are prefixed with `>` character, you should not type them.
-
-Comments are prefixed with `--`, they are not part of transmissions.
-
-`>` on its own means you need to press `return` - telnet should be configured to send it as CRLF.
-
-1. Create simplex message queue:
-
-```telnet
->
-> abcd -- correlation ID, any string
->
-> NEW 1234 -- 1234 is recipient's key
-
-abcd
-
-IDS QuCLU4YxgS7wcPFA YB4CCATREHkaQcEh -- recipient and sender IDs for the queue
-```
-
-2. Sender can send their "key" to the queue:
-
-```telnet
-> -- no signature (just press enter)
-> bcda -- correlation ID, any string
-> YB4CCATREHkaQcEh -- sender ID for the queue
-> SEND :key abcd
-
-bcda
-YB4CCATREHkaQcEh
-OK
-```
-
-3. Secure queue with sender's "key"
-
-```telnet
-> 1234 -- recipient's "signature" - same as "key" in the demo
-> cdab
-> QuCLU4YxgS7wcPFA -- recipient ID
-> KEY abcd -- "key" provided by sender
-
-cdab
-QuCLU4YxgS7wcPFA
-OK
-```
-
-4. Sender can now send messages to the queue
-
-```telnet
-> abcd -- sender's "signature" - same as "key" in the demo
-> dabc -- correlation ID
-> YB4CCATREHkaQcEh -- sender ID
-> SEND :hello
-
-dabc
-YB4CCATREHkaQcEh
-OK
-```
-
-5. Recipient recieves the message and acknowledges it to receive further messages
-
-```telnet
-
--- no correlation ID for messages delivered without client command
-QuCLU4YxgS7wcPFA
-MSG ECA3w3ID 2020-10-18T20:19:36.874Z 5
-hello
-> 1234
-> abcd
-> QuCLU4YxgS7wcPFA
-> ACK
-
-abcd
-QuCLU4YxgS7wcPFA
-OK
-```
-
-## Design
-
-![server design](design/server.svg)
+[AGPL v3](https://github.com/simplex-chat/simplexmq/blob/master/LICENSE)

apps/dog-food/ChatOptions.hs

@@ -1,79 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module ChatOptions (getChatOpts, ChatOpts (..)) where
-
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Options.Applicative
-import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP)
-import System.FilePath (combine)
-import System.Info (os)
-import Types
-
-data ChatOpts = ChatOpts
-  { name :: Maybe ByteString,
-    dbFileName :: String,
-    smpServer :: SMPServer,
-    termMode :: TermMode
-  }
-
-chatOpts :: FilePath -> Parser ChatOpts
-chatOpts appDir =
-  ChatOpts
-    <$> option
-      (Just <$> str)
-      ( long "name"
-          <> short 'n'
-          <> metavar "NAME"
-          <> help "optional name to use for invitations"
-          <> value Nothing
-      )
-    <*> strOption
-      ( long "database"
-          <> short 'd'
-          <> metavar "DB_FILE"
-          <> help ("sqlite database file path (" <> defaultDbFilePath <> ")")
-          <> value defaultDbFilePath
-      )
-    <*> option
-      parseSMPServer
-      ( long "server"
-          <> short 's'
-          <> metavar "SERVER"
-          <> help "SMP server to use (smp.simplex.im:5223)"
-          <> value (SMPServer "smp.simplex.im" (Just "5223") Nothing)
-      )
-    <*> option
-      parseTermMode
-      ( long "term"
-          <> short 't'
-          <> metavar "TERM"
-          <> help ("terminal mode: editor or basic (" <> termModeName deafultTermMode <> ")")
-          <> value deafultTermMode
-      )
-  where
-    defaultDbFilePath = combine appDir "smp-chat.db"
-    deafultTermMode
-      | os == "mingw32" = TermModeBasic
-      | otherwise = TermModeEditor
-
-parseSMPServer :: ReadM SMPServer
-parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack
-
-parseTermMode :: ReadM TermMode
-parseTermMode = maybeReader $ \case
-  "basic" -> Just TermModeBasic
-  "editor" -> Just TermModeEditor
-  _ -> Nothing
-
-getChatOpts :: FilePath -> IO ChatOpts
-getChatOpts appDir = execParser opts
-  where
-    opts =
-      info
-        (chatOpts appDir <**> helper)
-        ( fullDesc
-            <> header "Chat prototype using Simplex Messaging Protocol (SMP)"
-            <> progDesc "Start chat with DB_FILE file and use SERVER as SMP server"
-        )

apps/dog-food/ChatTerminal.hs

@@ -1,105 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module ChatTerminal
-  ( ChatTerminal (..),
-    newChatTerminal,
-    chatTerminal,
-    updateUsername,
-    ttyContact,
-    ttyFromContact,
-  )
-where
-
-import ChatTerminal.Basic (getLn, putLn)
-import ChatTerminal.Core
-import ChatTerminal.POSIX
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async (race_)
-import Control.Concurrent.STM
-import Control.Monad
-import Data.Maybe (fromMaybe)
-import Numeric.Natural
-import Styled
-import qualified System.Console.ANSI as C
-import Types
-
-newChatTerminal :: Natural -> Maybe Contact -> TermMode -> IO ChatTerminal
-newChatTerminal qSize user termMode = do
-  inputQ <- newTBQueueIO qSize
-  outputQ <- newTBQueueIO qSize
-  activeContact <- newTVarIO Nothing
-  username <- newTVarIO user
-  termSize <- fromMaybe (0, 0) <$> C.getTerminalSize
-  let lastRow = fst termSize - 1
-  termState <- newTVarIO $ newTermState user
-  termLock <- newTMVarIO ()
-  nextMessageRow <- newTVarIO lastRow
-  threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
-  return ChatTerminal {inputQ, outputQ, activeContact, username, termMode, termState, termSize, nextMessageRow, termLock}
-
-newTermState :: Maybe Contact -> TerminalState
-newTermState user =
-  TerminalState
-    { inputString = "",
-      inputPosition = 0,
-      inputPrompt = promptString user
-    }
-
-chatTerminal :: ChatTerminal -> IO ()
-chatTerminal ct
-  | termSize ct == (0, 0) || termMode ct == TermModeBasic =
-    run basicReceiveFromTTY basicSendToTTY
-  | otherwise = do
-    initTTY
-    updateInput ct
-    run receiveFromTTY sendToTTY
-  where
-    run receive send = race_ (receive ct) (send ct)
-
-basicReceiveFromTTY :: ChatTerminal -> IO ()
-basicReceiveFromTTY ct =
-  forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
-
-basicSendToTTY :: ChatTerminal -> IO ()
-basicSendToTTY ct = forever $ readOutputQ ct >>= putLn
-
-withTermLock :: ChatTerminal -> IO () -> IO ()
-withTermLock ChatTerminal {termLock} action = do
-  _ <- atomically $ takeTMVar termLock
-  action
-  atomically $ putTMVar termLock ()
-
-receiveFromTTY :: ChatTerminal -> IO ()
-receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
-  forever $
-    getKey >>= processKey >> withTermLock ct (updateInput ct)
-  where
-    processKey :: Key -> IO ()
-    processKey = \case
-      KeyEnter -> submitInput
-      key -> atomically $ do
-        ac <- readTVar activeContact
-        modifyTVar termState $ updateTermState ac (snd termSize) key
-
-    submitInput :: IO ()
-    submitInput = do
-      msg <- atomically $ do
-        ts <- readTVar termState
-        writeTVar termState $ ts {inputString = "", inputPosition = 0}
-        let s = inputString ts
-        writeTBQueue inputQ s
-        return s
-      withTermLock ct . printMessage ct $ styleMessage msg
-
-sendToTTY :: ChatTerminal -> IO ()
-sendToTTY ct = forever $ do
-  msg <- readOutputQ ct
-  withTermLock ct $ do
-    printMessage ct msg
-    updateInput ct
-
-readOutputQ :: ChatTerminal -> IO StyledString
-readOutputQ = atomically . readTBQueue . outputQ

apps/dog-food/ChatTerminal/Basic.hs

@@ -1,81 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module ChatTerminal.Basic where
-
-import Control.Monad.IO.Class (liftIO)
-import Styled
-import System.Console.ANSI.Types
-import System.Exit (exitSuccess)
-import System.Terminal as C
-
-getLn :: IO String
-getLn = withTerminal $ runTerminalT getTermLine
-
-putLn :: StyledString -> IO ()
-putLn s =
-  withTerminal . runTerminalT $
-    putStyled s >> C.putLn >> flush
-
-putStyled :: MonadTerminal m => StyledString -> m ()
-putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
-putStyled (Styled [] s) = putString s
-putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes
-
-setSGR :: MonadTerminal m => [SGR] -> m ()
-setSGR = mapM_ $ \case
-  Reset -> resetAttributes
-  SetConsoleIntensity BoldIntensity -> setAttribute bold
-  SetConsoleIntensity _ -> resetAttribute bold
-  SetItalicized True -> setAttribute italic
-  SetItalicized _ -> resetAttribute italic
-  SetUnderlining NoUnderline -> resetAttribute underlined
-  SetUnderlining _ -> setAttribute underlined
-  SetSwapForegroundBackground True -> setAttribute inverted
-  SetSwapForegroundBackground _ -> resetAttribute inverted
-  SetColor l i c -> setAttribute . layer l . intensity i $ color c
-  SetBlinkSpeed _ -> pure ()
-  SetVisible _ -> pure ()
-  SetRGBColor _ _ -> pure ()
-  SetPaletteColor _ _ -> pure ()
-  SetDefaultColor _ -> pure ()
-  where
-    layer = \case
-      Foreground -> foreground
-      Background -> background
-    intensity = \case
-      Dull -> id
-      Vivid -> bright
-    color = \case
-      Black -> black
-      Red -> red
-      Green -> green
-      Yellow -> yellow
-      Blue -> blue
-      Magenta -> magenta
-      Cyan -> cyan
-      White -> white
-
-getTermLine :: MonadTerminal m => m String
-getTermLine = getChars ""
-  where
-    getChars s = awaitEvent >>= processKey s
-    processKey s = \case
-      Right (KeyEvent key ms) -> case key of
-        CharKey c
-          | ms == mempty || ms == shiftKey -> do
-            C.putChar c
-            flush
-            getChars (c : s)
-          | otherwise -> getChars s
-        EnterKey -> do
-          C.putLn
-          flush
-          pure $ reverse s
-        BackspaceKey -> do
-          moveCursorBackward 1
-          eraseChars 1
-          flush
-          getChars $ if null s then s else tail s
-        _ -> getChars s
-      Left Interrupt -> liftIO exitSuccess
-      _ -> getChars s

apps/dog-food/ChatTerminal/Core.hs

@@ -1,130 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module ChatTerminal.Core where
-
-import Control.Concurrent.STM
-import qualified Data.ByteString.Char8 as B
-import Data.List (dropWhileEnd)
-import qualified Data.Text as T
-import SimplexMarkdown
-import Styled
-import System.Console.ANSI.Types
-import Types
-
-data ChatTerminal = ChatTerminal
-  { inputQ :: TBQueue String,
-    outputQ :: TBQueue StyledString,
-    activeContact :: TVar (Maybe Contact),
-    username :: TVar (Maybe Contact),
-    termMode :: TermMode,
-    termState :: TVar TerminalState,
-    termSize :: (Int, Int),
-    nextMessageRow :: TVar Int,
-    termLock :: TMVar ()
-  }
-
-data TerminalState = TerminalState
-  { inputPrompt :: String,
-    inputString :: String,
-    inputPosition :: Int
-  }
-
-data Key
-  = KeyLeft
-  | KeyRight
-  | KeyUp
-  | KeyDown
-  | KeyAltLeft
-  | KeyAltRight
-  | KeyCtrlLeft
-  | KeyCtrlRight
-  | KeyShiftLeft
-  | KeyShiftRight
-  | KeyEnter
-  | KeyBack
-  | KeyTab
-  | KeyEsc
-  | KeyChars String
-  | KeyUnsupported
-  deriving (Eq)
-
-inputHeight :: TerminalState -> ChatTerminal -> Int
-inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1
-
-updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState
-updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of
-  KeyChars cs -> insertCharsWithContact cs
-  KeyTab -> insertChars "    "
-  KeyBack -> backDeleteChar
-  KeyLeft -> setPosition $ max 0 (p - 1)
-  KeyRight -> setPosition $ min (length s) (p + 1)
-  KeyUp -> setPosition $ let p' = p - tw in if p' > 0 then p' else p
-  KeyDown -> setPosition $ let p' = p + tw in if p' <= length s then p' else p
-  KeyAltLeft -> setPosition prevWordPos
-  KeyAltRight -> setPosition nextWordPos
-  KeyCtrlLeft -> setPosition prevWordPos
-  KeyCtrlRight -> setPosition nextWordPos
-  KeyShiftLeft -> setPosition 0
-  KeyShiftRight -> setPosition $ length s
-  _ -> ts
-  where
-    insertCharsWithContact cs
-      | null s && cs /= "@" && cs /= "/" =
-        insertChars $ contactPrefix <> cs
-      | otherwise = insertChars cs
-    insertChars = ts' . if p >= length s then append else insert
-    append cs = let s' = s <> cs in (s', length s')
-    insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
-    contactPrefix = case ac of
-      Just (Contact c) -> "@" <> B.unpack c <> " "
-      Nothing -> ""
-    backDeleteChar
-      | p == 0 || null s = ts
-      | p >= length s = ts' backDeleteLast
-      | otherwise = ts' backDelete
-    backDeleteLast = if null s then (s, 0) else let s' = init s in (s', length s')
-    backDelete = let (b, a) = splitAt p s in (init b <> a, p - 1)
-    setPosition p' = ts' (s, p')
-    prevWordPos
-      | p == 0 || null s = p
-      | otherwise =
-        let before = take p s
-            beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
-         in max 0 $ p - length before + length beforeWord
-    nextWordPos
-      | p >= length s || null s = p
-      | otherwise =
-        let after = drop p s
-            afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
-         in min (length s) $ p + length after - length afterWord
-    ts' (s', p') = ts {inputString = s', inputPosition = p'}
-
-styleMessage :: String -> StyledString
-styleMessage = \case
-  "" -> ""
-  s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> markdown rest
-  s -> markdown s
-  where
-    markdown :: String -> StyledString
-    markdown = styleMarkdown . parseMarkdown . T.pack
-
-updateUsername :: ChatTerminal -> Maybe Contact -> STM ()
-updateUsername ct a = do
-  writeTVar (username ct) a
-  modifyTVar (termState ct) $ \ts -> ts {inputPrompt = promptString a}
-
-promptString :: Maybe Contact -> String
-promptString a = maybe "" (B.unpack . toBs) a <> "> "
-
-ttyContact :: Contact -> StyledString
-ttyContact (Contact a) = Styled contactSGR $ B.unpack a
-
-ttyFromContact :: Contact -> StyledString
-ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> ">"
-
-contactSGR :: [SGR]
-contactSGR = [SetColor Foreground Vivid Yellow]
-
-selfSGR :: [SGR]
-selfSGR = [SetColor Foreground Vivid Cyan]

apps/dog-food/ChatTerminal/POSIX.hs

@@ -1,102 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module ChatTerminal.POSIX where
-
-import ChatTerminal.Core
-import Control.Concurrent.STM
-import Styled
-import qualified System.Console.ANSI as C
-import System.IO
-
-initTTY :: IO ()
-initTTY = do
-  hSetEcho stdin False
-  hSetBuffering stdin NoBuffering
-  hSetBuffering stdout NoBuffering
-
-updateInput :: ChatTerminal -> IO ()
-updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do
-  C.hideCursor
-  ts <- readTVarIO termState
-  nmr <- readTVarIO nextMessageRow
-  let (th, tw) = termSize
-      ih = inputHeight ts ct
-      iStart = th - ih
-      prompt = inputPrompt ts
-      (cRow, cCol) = relativeCursorPosition tw $ length prompt + inputPosition ts
-  if nmr >= iStart
-    then atomically $ writeTVar nextMessageRow iStart
-    else clearLines nmr iStart
-  C.setCursorPosition (max nmr iStart) 0
-  putStr $ prompt <> inputString ts <> " "
-  C.clearFromCursorToLineEnd
-  C.setCursorPosition (iStart + cRow) cCol
-  C.showCursor
-  where
-    clearLines :: Int -> Int -> IO ()
-    clearLines from till
-      | from >= till = return ()
-      | otherwise = do
-        C.setCursorPosition from 0
-        C.clearFromCursorToLineEnd
-        clearLines (from + 1) till
-
-    relativeCursorPosition :: Int -> Int -> (Int, Int)
-    relativeCursorPosition width pos =
-      let row = pos `div` width
-          col = pos - row * width
-       in (row, col)
-
-printMessage :: ChatTerminal -> StyledString -> IO ()
-printMessage ChatTerminal {termSize, nextMessageRow} msg = do
-  nmr <- readTVarIO nextMessageRow
-  C.setCursorPosition nmr 0
-  let (th, tw) = termSize
-  lc <- printLines tw msg
-  atomically . writeTVar nextMessageRow $ min (th - 1) (nmr + lc)
-  where
-    printLines :: Int -> StyledString -> IO Int
-    printLines tw ss = do
-      let s = styledToANSITerm ss
-          ls
-            | null s = [""]
-            | otherwise = lines s <> ["" | last s == '\n']
-      print_ ls
-      return $ foldl (\lc l -> lc + (length l `div` tw) + 1) 0 ls
-
-    print_ :: [String] -> IO ()
-    print_ [] = return ()
-    print_ (l : ls) = do
-      putStr l
-      C.clearFromCursorToLineEnd
-      putStr "\n"
-      print_ ls
-
-getKey :: IO Key
-getKey = charsToKey . reverse <$> keyChars ""
-  where
-    charsToKey = \case
-      "\ESC" -> KeyEsc
-      "\ESC[A" -> KeyUp
-      "\ESC[B" -> KeyDown
-      "\ESC[D" -> KeyLeft
-      "\ESC[C" -> KeyRight
-      "\ESCb" -> KeyAltLeft
-      "\ESCf" -> KeyAltRight
-      "\ESC[1;5D" -> KeyCtrlLeft
-      "\ESC[1;5C" -> KeyCtrlRight
-      "\ESC[1;2D" -> KeyShiftLeft
-      "\ESC[1;2C" -> KeyShiftRight
-      "\n" -> KeyEnter
-      "\DEL" -> KeyBack
-      "\t" -> KeyTab
-      '\ESC' : _ -> KeyUnsupported
-      cs -> KeyChars cs
-
-    keyChars cs = do
-      c <- getChar
-      more <- hReady stdin
-      -- for debugging - uncomment this, comment line after:
-      -- (if more then keyChars else \c' -> print (reverse c') >> return c') (c : cs)
-      (if more then keyChars else return) (c : cs)

apps/dog-food/Main.hs

@@ -1,250 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Main where
-
-import ChatOptions
-import ChatTerminal
-import Control.Applicative ((<|>))
-import Control.Concurrent.STM
-import Control.Logger.Simple
-import Control.Monad.Reader
-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.Functor (($>))
-import qualified Data.Text as T
-import Data.Text.Encoding
-import Numeric.Natural
-import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient)
-import Simplex.Messaging.Agent.Client (AgentClient (..))
-import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Transmission
-import Simplex.Messaging.Client (smpDefaultConfig)
-import Simplex.Messaging.Util (raceAny_)
-import SimplexMarkdown
-import Styled
-import System.Directory (getAppUserDataDirectory)
-import System.Exit (exitFailure)
-import System.Info (os)
-import Types
-
-cfg :: AgentConfig
-cfg =
-  AgentConfig
-    { tcpPort = undefined, -- TODO maybe take it out of config
-      rsaKeySize = 2048 `div` 8,
-      connIdBytes = 12,
-      tbqSize = 16,
-      dbFile = "smp-chat.db",
-      smpCfg = smpDefaultConfig
-    }
-
-logCfg :: LogConfig
-logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
-
-data ChatClient = ChatClient
-  { inQ :: TBQueue ChatCommand,
-    outQ :: TBQueue ChatResponse,
-    smpServer :: SMPServer,
-    username :: TVar (Maybe Contact)
-  }
-
--- | GroupMessage ChatGroup ByteString
--- | AddToGroup Contact
-data ChatCommand
-  = ChatHelp
-  | AddContact Contact
-  | AcceptContact Contact SMPQueueInfo
-  | ChatWith Contact
-  | SetName Contact
-  | SendMessage Contact ByteString
-
-chatCommandP :: Parser ChatCommand
-chatCommandP =
-  "/help" $> ChatHelp
-    <|> "/add " *> (AddContact <$> contact)
-    <|> "/accept " *> acceptContact
-    <|> "/chat " *> chatWith
-    <|> "/name " *> setName
-    <|> "@" *> sendMessage
-  where
-    acceptContact = AcceptContact <$> contact <* A.space <*> smpQueueInfoP
-    chatWith = ChatWith <$> contact
-    setName = SetName <$> contact
-    sendMessage = SendMessage <$> contact <* A.space <*> A.takeByteString
-    contact = Contact <$> A.takeTill (== ' ')
-
-data ChatResponse
-  = ChatHelpInfo
-  | Invitation SMPQueueInfo
-  | Connected Contact
-  | ReceivedMessage Contact ByteString
-  | Disconnected Contact
-  | YesYes
-  | ErrorInput ByteString
-  | ChatError AgentErrorType
-  | NoChatResponse
-
-serializeChatResponse :: Maybe Contact -> ChatResponse -> StyledString
-serializeChatResponse name = \case
-  ChatHelpInfo -> chatHelpInfo
-  Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo
-  Connected c -> ttyContact c <> " connected"
-  ReceivedMessage c t -> ttyFromContact c <> " " <> msgPlain t
-  Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""
-  YesYes -> "you got it!"
-  ErrorInput t -> "invalid input: " <> bPlain t
-  ChatError e -> "chat error: " <> plain (show e)
-  NoChatResponse -> ""
-  where
-    showName Nothing = "<your name>"
-    showName (Just (Contact a)) = bPlain a
-    msgPlain = styleMarkdown . parseMarkdown . decodeUtf8With onError
-    onError _ _ = Just '?'
-
-chatHelpInfo :: StyledString
-chatHelpInfo =
-  "Using chat:\n\
-  \/add <name>       - create invitation to send out-of-band\n\
-  \                    to your contact <name>\n\
-  \                    (any unique string without spaces)\n\
-  \/accept <name> <invitation> - accept <invitation>\n\
-  \                    (a string that starts from \"smp::\")\n\
-  \                    from your contact <name>\n\
-  \/name <name>      - set <name> to use in invitations\n\
-  \@<name> <message> - send <message> (any string) to contact <name>\n\
-  \                    @<name> can be omitted to send to previous"
-
-main :: IO ()
-main = do
-  ChatOpts {dbFileName, smpServer, name, termMode} <- welcomeGetOpts
-  let user = Contact <$> name
-  t <- getChatClient smpServer user
-  ct <- newChatTerminal (tbqSize cfg) user termMode
-  -- setLogLevel LogInfo -- LogError
-  -- withGlobalLogging logCfg $
-  env <- newSMPAgentEnv cfg {dbFile = dbFileName}
-  dogFoodChat t ct env
-
-welcomeGetOpts :: IO ChatOpts
-welcomeGetOpts = do
-  appDir <- getAppUserDataDirectory "simplex"
-  opts@ChatOpts {dbFileName, termMode} <- getChatOpts appDir
-  putStrLn "simpleX chat prototype"
-  putStrLn $ "db: " <> dbFileName
-  when (os == "mingw32") $ windowsWarning termMode
-  putStrLn "type \"/help\" for usage information"
-  pure opts
-
-windowsWarning :: TermMode -> IO ()
-windowsWarning = \case
-  m@TermModeBasic -> do
-    putStrLn $ "running in Windows (terminal mode is " <> termModeName m <> ", no utf8 support)"
-    putStrLn "it is recommended to use Windows Subsystem for Linux (WSL)"
-  m -> do
-    putStrLn $ "running in Windows, terminal mode " <> termModeName m <> " is not supported"
-    exitFailure
-
-dogFoodChat :: ChatClient -> ChatTerminal -> Env -> IO ()
-dogFoodChat t ct env = do
-  c <- runReaderT getSMPAgentClient env
-  raceAny_
-    [ runReaderT (runSMPAgentClient c) env,
-      sendToAgent t ct c,
-      sendToChatTerm t ct,
-      receiveFromAgent t ct c,
-      receiveFromChatTerm t ct,
-      chatTerminal ct
-    ]
-
-getChatClient :: SMPServer -> Maybe Contact -> IO ChatClient
-getChatClient srv name = atomically $ newChatClient (tbqSize cfg) srv name
-
-newChatClient :: Natural -> SMPServer -> Maybe Contact -> STM ChatClient
-newChatClient qSize smpServer name = do
-  inQ <- newTBQueue qSize
-  outQ <- newTBQueue qSize
-  username <- newTVar name
-  return ChatClient {inQ, outQ, smpServer, username}
-
-receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO ()
-receiveFromChatTerm t ct = forever $ do
-  atomically (readTBQueue $ inputQ ct)
-    >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) . encodeUtf8 . T.pack
-  where
-    processOrError = \case
-      Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err
-      Right ChatHelp -> atomically . writeTBQueue (outQ t) $ ChatHelpInfo
-      Right (SetName a) -> atomically $ do
-        let user = Just a
-        writeTVar (username (t :: ChatClient)) user
-        updateUsername ct user
-        writeTBQueue (outQ t) YesYes
-      Right cmd -> atomically $ writeTBQueue (inQ t) cmd
-
-sendToChatTerm :: ChatClient -> ChatTerminal -> IO ()
-sendToChatTerm ChatClient {outQ, username} ChatTerminal {outputQ} = forever $ do
-  atomically (readTBQueue outQ) >>= \case
-    NoChatResponse -> return ()
-    resp -> do
-      name <- readTVarIO username
-      atomically . writeTBQueue outputQ $ serializeChatResponse name resp
-
-sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
-sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do
-  atomically $ writeTBQueue rcvQ ("1", "", SUBALL) -- hack for subscribing to all
-  forever . atomically $ do
-    cmd <- readTBQueue inQ
-    writeTBQueue rcvQ `mapM_` agentTransmission cmd
-    setActiveContact cmd
-  where
-    setActiveContact :: ChatCommand -> STM ()
-    setActiveContact cmd =
-      writeTVar (activeContact ct) $ case cmd of
-        ChatWith a -> Just a
-        SendMessage a _ -> Just a
-        _ -> Nothing
-    agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client)
-    agentTransmission = \case
-      AddContact a -> transmission a $ NEW smpServer
-      AcceptContact a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer
-      ChatWith a -> transmission a SUB
-      SendMessage a msg -> transmission a $ SEND msg
-      ChatHelp -> Nothing
-      SetName _ -> Nothing
-    transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client)
-    transmission (Contact a) cmd = Just ("1", a, cmd)
-
-receiveFromAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
-receiveFromAgent t ct c = forever . atomically $ do
-  resp <- chatResponse <$> readTBQueue (sndQ c)
-  writeTBQueue (outQ t) resp
-  setActiveContact resp
-  where
-    chatResponse :: ATransmission 'Agent -> ChatResponse
-    chatResponse (_, a, resp) = case resp of
-      INV qInfo -> Invitation qInfo
-      CON -> Connected contact
-      END -> Disconnected contact
-      MSG {m_body} -> ReceivedMessage contact m_body
-      SENT _ -> NoChatResponse
-      OK -> Connected contact -- hack for subscribing to all
-      ERR e -> ChatError e
-      where
-        contact = Contact a
-    setActiveContact :: ChatResponse -> STM ()
-    setActiveContact = \case
-      Connected a -> set $ Just a
-      ReceivedMessage a _ -> set $ Just a
-      Disconnected _ -> set Nothing
-      _ -> return ()
-      where
-        set a = writeTVar (activeContact ct) a

apps/dog-food/SimplexMarkdown.hs

@@ -1,122 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module SimplexMarkdown where
-
-import Control.Applicative ((<|>))
-import Data.Attoparsec.Text (Parser)
-import qualified Data.Attoparsec.Text as A
-import Data.Either (fromRight)
-import Data.Functor (($>))
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.String
-import Data.Text (Text)
-import qualified Data.Text as T
-import Styled
-import System.Console.ANSI.Types
-
-data Markdown = Markdown Format Text | Markdown :|: Markdown
-  deriving (Show)
-
-data Format
-  = Bold
-  | Italic
-  | Underline
-  | StrikeThrough
-  | Colored Color
-  | NoFormat
-  deriving (Show)
-
-instance Semigroup Markdown where (<>) = (:|:)
-
-instance Monoid Markdown where mempty = unmarked ""
-
-instance IsString Markdown where fromString = unmarked . T.pack
-
-unmarked :: Text -> Markdown
-unmarked = Markdown NoFormat
-
-styleMarkdown :: Markdown -> StyledString
-styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
-styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s
-  where
-    sgr = case f of
-      Bold -> [SetConsoleIntensity BoldIntensity]
-      Italic -> [SetUnderlining SingleUnderline, SetItalicized True]
-      Underline -> [SetUnderlining SingleUnderline]
-      StrikeThrough -> [SetSwapForegroundBackground True]
-      Colored c -> [SetColor Foreground Vivid c]
-      NoFormat -> []
-
-formats :: Map Char Format
-formats =
-  M.fromList
-    [ ('*', Bold),
-      ('_', Italic),
-      ('+', Underline),
-      ('~', StrikeThrough),
-      ('^', Colored White)
-    ]
-
-colors :: Map Text Color
-colors =
-  M.fromList
-    [ ("red", Red),
-      ("green", Green),
-      ("blue", Blue),
-      ("yellow", Yellow),
-      ("cyan", Cyan),
-      ("magenta", Magenta),
-      ("r", Red),
-      ("g", Green),
-      ("b", Blue),
-      ("y", Yellow),
-      ("c", Cyan),
-      ("m", Magenta)
-    ]
-
-parseMarkdown :: Text -> Markdown
-parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
-
-markdownP :: Parser Markdown
-markdownP = merge <$> A.many' fragmentP
-  where
-    merge :: [Markdown] -> Markdown
-    merge [] = ""
-    merge [f] = f
-    merge (f : fs) = foldl (:|:) f fs
-    fragmentP :: Parser Markdown
-    fragmentP =
-      A.anyChar >>= \case
-        ' ' -> unmarked . (" " <>) <$> A.takeWhile (== ' ')
-        c -> case M.lookup c formats of
-          Just (Colored White) -> coloredP
-          Just f -> formattedP c "" f
-          Nothing -> unformattedP c
-    formattedP :: Char -> Text -> Format -> Parser Markdown
-    formattedP c p f = do
-      s <- A.takeTill (== c)
-      (A.char c $> Markdown f s) <|> noFormat (T.singleton c <> p <> s)
-    coloredP :: Parser Markdown
-    coloredP = do
-      color <- A.takeWhile (\c -> c /= ' ' && c /= '^')
-      case M.lookup color colors of
-        Just c ->
-          let f = Colored c
-           in (A.char ' ' *> formattedP '^' (color <> " ") f)
-                <|> (A.char '^' $> Markdown f color)
-                <|> noFormat ("^" <> color)
-        _ -> noFormat ("^" <> color)
-    unformattedP :: Char -> Parser Markdown
-    unformattedP c = unmarked . (T.singleton c <>) <$> wordsP
-    wordsP :: Parser Text
-    wordsP = do
-      s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ')
-      A.peekChar >>= \case
-        Nothing -> pure s
-        Just c -> case M.lookup c formats of
-          Just _ -> pure s
-          Nothing -> (s <>) <$> wordsP
-    noFormat :: Text -> Parser Markdown
-    noFormat = pure . unmarked

apps/dog-food/Styled.hs

@@ -1,29 +0,0 @@
-module Styled (StyledString (..), plain, bPlain, styledToANSITerm, styledToPlain) where
-
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.String
-import System.Console.ANSI (SGR (..), setSGRCode)
-
-data StyledString = Styled [SGR] String | StyledString :<>: StyledString
-
-instance Semigroup StyledString where (<>) = (:<>:)
-
-instance Monoid StyledString where mempty = plain ""
-
-instance IsString StyledString where fromString = plain
-
-plain :: String -> StyledString
-plain = Styled []
-
-bPlain :: ByteString -> StyledString
-bPlain = Styled [] . B.unpack
-
-styledToANSITerm :: StyledString -> String
-styledToANSITerm (Styled [] s) = s
-styledToANSITerm (Styled sgr s) = setSGRCode sgr <> s <> setSGRCode [Reset]
-styledToANSITerm (s1 :<>: s2) = styledToANSITerm s1 <> styledToANSITerm s2
-
-styledToPlain :: StyledString -> String
-styledToPlain (Styled _ s) = s
-styledToPlain (s1 :<>: s2) = styledToPlain s1 <> styledToPlain s2

apps/dog-food/Types.hs

@@ -1,14 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module Types where
-
-import Data.ByteString.Char8 (ByteString)
-
-newtype Contact = Contact {toBs :: ByteString}
-
-data TermMode = TermModeBasic | TermModeEditor deriving (Eq)
-
-termModeName :: TermMode -> String
-termModeName = \case
-  TermModeBasic -> "basic"
-  TermModeEditor -> "editor"

apps/smp-agent/Main.hs

@@ -1,16 +1,21 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Main where
 
 import Control.Logger.Simple
+import qualified Data.List.NonEmpty as L
 import Simplex.Messaging.Agent (runSMPAgent)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Client (smpDefaultConfig)
+import Simplex.Messaging.Transport (TCP, Transport (..))
 
 cfg :: AgentConfig
 cfg =
   AgentConfig
     { tcpPort = "5224",
+      smpServers = L.fromList ["localhost:5223#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="],
       rsaKeySize = 2048 `div` 8,
       connIdBytes = 12,
       tbqSize = 16,
@@ -25,5 +30,4 @@ main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
   setLogLevel LogInfo -- LogError
-  withGlobalLogging logCfg $
-    runSMPAgent cfg
+  withGlobalLogging logCfg $ runSMPAgent (transport @TCP) cfg

apps/smp-server/Main.hs

@@ -1,18 +1,264 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
 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 qualified Data.ByteString.Char8 as B
+import Data.Char (toLower)
+import Data.Ini (Ini, lookupValue, readIniFile)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.X509 (PrivKey (PrivKeyRSA))
+import Network.Socket (ServiceName)
+import Options.Applicative
+import qualified Simplex.Messaging.Crypto as C
 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.WebSockets (WS)
+import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
+import System.Exit (exitFailure)
+import System.FilePath (combine)
+import System.IO (IOMode (..), hFlush, stdout)
 
-cfg :: ServerConfig
-cfg =
+defaultServerPort :: ServiceName
+defaultServerPort = "5223"
+
+serverConfig :: ServerConfig
+serverConfig =
   ServerConfig
-    { tcpPort = "5223",
-      tbqSize = 16,
+    { tbqSize = 16,
       queueIdBytes = 12,
-      msgIdBytes = 6
+      msgIdBytes = 6,
+      -- below parameters are set based on ini file /etc/opt/simplex/smp-server.ini
+      transports = undefined,
+      storeLog = undefined,
+      serverPrivateKey = undefined
     }
 
+newKeySize :: Int
+newKeySize = 2048 `div` 8
+
+cfgDir :: FilePath
+cfgDir = "/etc/opt/simplex"
+
+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"
+
 main :: IO ()
 main = do
-  putStrLn $ "Listening on port " ++ tcpPort cfg
+  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"
+
+getConfig :: ServerOpts -> ExceptT String IO ServerConfig
+getConfig opts = do
+  ini <- readIni
+  pk <- readKey ini
+  storeLog <- liftIO $ openStoreLog opts ini
+  pure $ makeConfig ini pk storeLog
+
+makeConfig :: IniOpts -> C.FullPrivateKey -> Maybe (StoreLog 'ReadMode) -> ServerConfig
+makeConfig IniOpts {serverPort, enableWebsockets} pk storeLog =
+  let transports = (serverPort, transport @TCP) : [("80", transport @WS) | enableWebsockets]
+   in serverConfig {serverPrivateKey = pk, storeLog, transports}
+
+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"
+
+initializeServer :: ServerOpts -> IO ServerConfig
+initializeServer opts = do
+  ini <- createIni opts
+  pk <- createKey ini
+  storeLog <- openStoreLog opts ini
+  pure $ makeConfig ini pk storeLog
+
+runServer :: ServerConfig -> IO ()
+runServer cfg = do
+  printConfig cfg
+  forM_ (transports cfg) $ \(port, ATransport t) ->
+    putStrLn $ "listening on port " <> port <> " (" <> transportName t <> ")"
   runSMPServer cfg
+
+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
+
+data IniOpts = IniOpts
+  { enableStoreLog :: Bool,
+    storeLogFile :: FilePath,
+    serverKeyFile :: FilePath,
+    serverPort :: ServiceName,
+    enableWebsockets :: Bool
+  }
+
+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
+  pure IniOpts {enableStoreLog, storeLogFile, serverKeyFile, serverPort, enableWebsockets}
+  where
+    opt :: String -> Text -> Text -> Ini -> String
+    opt def section key ini = either (const def) T.unpack $ lookupValue section key ini
+
+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\
+         \websockets: on\n"
+  pure
+    IniOpts
+      { enableStoreLog,
+        storeLogFile = defaultStoreLogFile,
+        serverKeyFile = defaultKeyFile,
+        serverPort = defaultServerPort,
+        enableWebsockets = True
+      }
+
+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"
+  where
+    err :: String -> ExceptT String IO b
+    err e = throwE $ e <> ": " <> serverKeyFile
+
+createKey :: IniOpts -> IO C.FullPrivateKey
+createKey IniOpts {serverKeyFile} = do
+  createDirectoryIfMissing True cfgDir
+  (_, pk) <- C.generateKeyPair newKeySize
+  S.writeKeyFile S.TraditionalFormat serverKeyFile [PrivKeyRSA $ C.rsaPrivateKey pk]
+  pure pk
+
+fileExists :: FilePath -> ExceptT String IO ()
+fileExists path = do
+  exists <- liftIO $ doesFileExist path
+  unless exists . throwE $ "file " <> path <> " not found"
+
+deleteIfExists :: FilePath -> IO ()
+deleteIfExists path = doesFileExist path >>= (`when` removeFile path)
+
+confirm :: String -> IO ()
+confirm msg = do
+  putStr $ msg <> " (y/N): "
+  hFlush stdout
+  ok <- getLine
+  when (map toLower ok /= "y") exitFailure
+
+serverKeyHash :: C.FullPrivateKey -> B.ByteString
+serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey
+
+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
+
+data ServerOpts = ServerOpts
+  { serverCommand :: ServerCommand,
+    enableStoreLog :: Bool
+  }
+
+data ServerCommand = ServerInit | ServerStart | ServerDelete
+
+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"
+      )
+
+getServerOpts :: IO ServerOpts
+getServerOpts = customExecParser p opts
+  where
+    p = prefs showHelpOnEmpty
+    opts =
+      info
+        (serverOpts <**> helper)
+        ( fullDesc
+            <> header "Simplex Messaging Protocol (SMP) Server"
+        )

design/agent2.gv

@@ -8,7 +8,7 @@ digraph SMPAgent {
 
   subgraph clusterPersistence {
     graph [fontsize=11 color=gray]
-    label="persistence (sqlite)\nQ: can multiple threads use it"
+    label="persistence (sqlite)"
     connectionsStore [shape=cylinder label="duplex connections,\nSMP queues,\nrecent messages"]
   }
 

design/agent2.svg

@@ -0,0 +1,394 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
+<!-- Generated by graphviz version 2.40.1 (20161225.0304)
+ -->
+<!-- Title: SMPAgent Pages: 1 -->
+<svg width="1073pt" height="1142pt"
+ viewBox="0.00 0.00 1073.00 1142.34" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 1138.3374)">
+<title>SMPAgent</title>
+<polygon fill="#ffffff" stroke="transparent" points="-4,4 -4,-1138.3374 1069,-1138.3374 1069,4 -4,4"/>
+<g id="clust1" class="cluster">
+<title>clusterPersistence</title>
+<polygon fill="none" stroke="#c0c0c0" points="927,-512.7374 927,-615.3874 1057,-615.3874 1057,-512.7374 927,-512.7374"/>
+<text text-anchor="middle" x="992" y="-601.4874" font-family="arial" font-size="11.00" fill="#000000">persistence (sqlite)</text>
+</g>
+<g id="clust2" class="cluster">
+<title>clusterAgent</title>
+<polygon fill="none" stroke="#c0c0c0" points="175,-963.3624 175,-1040.1624 389,-1040.1624 389,-963.3624 175,-963.3624"/>
+<text text-anchor="middle" x="282" y="-1023.5624" font-family="arial" font-size="14.00" fill="#000000">agent threads</text>
+</g>
+<g id="clust4" class="cluster">
+<title>clusterUserTCP</title>
+<polygon fill="none" stroke="#c0c0c0" points="8,-509.375 8,-933.3624 230,-933.3624 230,-509.375 8,-509.375"/>
+<text text-anchor="middle" x="119" y="-916.7624" font-family="arial" font-size="14.00" fill="#000000">1 group per user TCP connection</text>
+</g>
+<g id="clust5" class="cluster">
+<title>clusterUserTCPThreads</title>
+<polygon fill="none" stroke="#c0c0c0" points="38,-517.375 38,-610.7499 222,-610.7499 222,-517.375 38,-517.375"/>
+<text text-anchor="middle" x="130" y="-596.8499" font-family="arial" font-size="11.00" fill="#000000">user TCP threads</text>
+</g>
+<g id="clust6" class="cluster">
+<title>clusterUser</title>
+<polygon fill="none" stroke="#c0c0c0" points="250,-8 250,-826.5624 919,-826.5624 919,-8 250,-8"/>
+<text text-anchor="middle" x="584.5" y="-809.9624" font-family="arial" font-size="14.00" fill="#000000">1 group per user TCP connection</text>
+</g>
+<g id="clust7" class="cluster">
+<title>clusterUserInterface</title>
+<polygon fill="none" stroke="#c0c0c0" points="258,-400.375 258,-485.175 419,-485.175 419,-400.375 258,-400.375"/>
+<text text-anchor="middle" x="338.5" y="-471.275" font-family="arial" font-size="11.00" fill="#000000">user queues</text>
+</g>
+<g id="clust8" class="cluster">
+<title>clusterUserThreads</title>
+<polygon fill="none" stroke="#c0c0c0" points="622,-634.3874 622,-793.7624 865,-793.7624 865,-634.3874 622,-634.3874"/>
+<text text-anchor="middle" x="743.5" y="-779.8624" font-family="arial" font-size="11.00" fill="#000000">user threads</text>
+<text text-anchor="middle" x="743.5" y="-766.6624" font-family="arial" font-size="11.00" fill="#000000">Note: `user agent` sends</text>
+<text text-anchor="middle" x="743.5" y="-753.4624" font-family="arial" font-size="11.00" fill="#000000">all commands to `commands TBQueue`s</text>
+<text text-anchor="middle" x="743.5" y="-740.2624" font-family="arial" font-size="11.00" fill="#000000">(invalid commands with attached responses),</text>
+<text text-anchor="middle" x="743.5" y="-727.0624" font-family="arial" font-size="11.00" fill="#000000">and only valid commands to `server TBQueue`.</text>
+<text text-anchor="middle" x="743.5" y="-713.8624" font-family="arial" font-size="11.00" fill="#000000">It is used to respond in correct order.</text>
+</g>
+<g id="clust10" class="cluster">
+<title>clusterClient</title>
+<polygon fill="none" stroke="#c0c0c0" points="427,-128.6 427,-482.975 812,-482.975 812,-128.6 427,-128.6"/>
+<text text-anchor="middle" x="619.5" y="-466.375" font-family="arial" font-size="14.00" fill="#000000">1 group per SMP client/server connection</text>
+</g>
+<g id="clust11" class="cluster">
+<title>clusterServerThreads</title>
+<polygon fill="none" stroke="#c0c0c0" points="564,-136.6 564,-229.975 758,-229.975 758,-136.6 564,-136.6"/>
+<text text-anchor="middle" x="661" y="-216.075" font-family="arial" font-size="11.00" fill="#000000">SMP client threads</text>
+</g>
+<!-- main -->
+<g id="node1" class="node">
+<title>main</title>
+<polygon fill="none" stroke="#ffa500" points="382.542,-1106.2499 363.271,-1134.4251 324.729,-1134.4251 305.458,-1106.2499 324.729,-1078.0747 363.271,-1078.0747 382.542,-1106.2499"/>
+<text text-anchor="middle" x="344" y="-1109.5499" font-family="arial" font-size="11.00" fill="#000000">main</text>
+<text text-anchor="middle" x="344" y="-1096.3499" font-family="arial" font-size="11.00" fill="#000000">thread</text>
+</g>
+<!-- connectClnt -->
+<g id="node4" class="node">
+<title>connectClnt</title>
+<polygon fill="none" stroke="#ffa500" points="288.8246,-989.3624 262.4123,-1007.3624 209.5877,-1007.3624 183.1754,-989.3624 209.5877,-971.3624 262.4123,-971.3624 288.8246,-989.3624"/>
+<text text-anchor="middle" x="236" y="-986.0624" font-family="arial" font-size="11.00" fill="#000000">connectClnt</text>
+</g>
+<!-- main&#45;&gt;connectClnt -->
+<g id="edge1" class="edge">
+<title>main&#45;&gt;connectClnt</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M321.6223,-1082.0307C303.5136,-1062.4318 278.0793,-1034.9044 259.6406,-1014.9484"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="252.7011,-1007.4378 262.7926,-1011.7288 256.0942,-1011.1102 259.4874,-1014.7826 259.4874,-1014.7826 259.4874,-1014.7826 256.0942,-1011.1102 256.1823,-1017.8365 252.7011,-1007.4378 252.7011,-1007.4378"/>
+<text text-anchor="middle" x="308.7235" y="-1051.1624" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- runClnt -->
+<g id="node5" class="node">
+<title>runClnt</title>
+<polygon fill="none" stroke="#ffa500" points="380.5019,-989.3624 362.251,-1007.3624 325.749,-1007.3624 307.4981,-989.3624 325.749,-971.3624 362.251,-971.3624 380.5019,-989.3624"/>
+<text text-anchor="middle" x="344" y="-986.0624" font-family="arial" font-size="11.00" fill="#000000">runClnt</text>
+</g>
+<!-- main&#45;&gt;runClnt -->
+<g id="edge2" class="edge">
+<title>main&#45;&gt;runClnt</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M344,-1077.9547C344,-1059.6552 344,-1035.9253 344,-1017.631"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="344,-1007.5699 348.5001,-1017.5699 344,-1012.5699 344.0001,-1017.5699 344.0001,-1017.5699 344.0001,-1017.5699 344,-1012.5699 339.5001,-1017.57 344,-1007.5699 344,-1007.5699"/>
+<text text-anchor="middle" x="353.7235" y="-1051.1624" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- aSock -->
+<g id="node2" class="node">
+<title>aSock</title>
+<polygon fill="none" stroke="#006400" points="287.8624,-1124.2499 160.1376,-1124.2499 160.1376,-1088.2499 287.8624,-1088.2499 287.8624,-1124.2499"/>
+<text text-anchor="middle" x="224" y="-1102.9499" font-family="arial" font-size="11.00" fill="#000000">user agent TCP socket</text>
+</g>
+<!-- aSock&#45;&gt;connectClnt -->
+<g id="edge3" class="edge">
+<title>aSock&#45;&gt;connectClnt</title>
+<path fill="none" stroke="#006400" d="M225.8487,-1088.2424C227.781,-1069.421 230.8399,-1039.6253 233.0952,-1017.6565"/>
+<polygon fill="#006400" stroke="#006400" points="234.1294,-1007.583 237.5845,-1017.9903 233.6188,-1012.5568 233.1081,-1017.5307 233.1081,-1017.5307 233.1081,-1017.5307 233.6188,-1012.5568 228.6316,-1017.0711 234.1294,-1007.583 234.1294,-1007.583"/>
+</g>
+<!-- connectionsStore -->
+<g id="node3" class="node">
+<title>connectionsStore</title>
+<path fill="none" stroke="#000000" d="M1048.7017,-580.4228C1048.7017,-583.7287 1023.2871,-586.414 992,-586.414 960.7129,-586.414 935.2983,-583.7287 935.2983,-580.4228 935.2983,-580.4228 935.2983,-526.5021 935.2983,-526.5021 935.2983,-523.1962 960.7129,-520.5109 992,-520.5109 1023.2871,-520.5109 1048.7017,-523.1962 1048.7017,-526.5021 1048.7017,-526.5021 1048.7017,-580.4228 1048.7017,-580.4228"/>
+<path fill="none" stroke="#000000" d="M1048.7017,-580.4228C1048.7017,-577.117 1023.2871,-574.4316 992,-574.4316 960.7129,-574.4316 935.2983,-577.117 935.2983,-580.4228"/>
+<text text-anchor="middle" x="992" y="-563.3624" font-family="arial" font-size="11.00" fill="#000000">duplex connections,</text>
+<text text-anchor="middle" x="992" y="-550.1624" font-family="arial" font-size="11.00" fill="#000000">SMP queues,</text>
+<text text-anchor="middle" x="992" y="-536.9624" font-family="arial" font-size="11.00" fill="#000000">recent messages</text>
+</g>
+<!-- uSock -->
+<g id="node6" class="node">
+<title>uSock</title>
+<polygon fill="none" stroke="#006400" points="169.5337,-900.5624 16.4663,-900.5624 16.4663,-864.5624 169.5337,-864.5624 169.5337,-900.5624"/>
+<text text-anchor="middle" x="93" y="-879.2624" font-family="arial" font-size="11.00" fill="#000000">user connection TCP socket</text>
+</g>
+<!-- connectClnt&#45;&gt;uSock -->
+<g id="edge23" class="edge">
+<title>connectClnt&#45;&gt;uSock</title>
+<path fill="none" stroke="#006400" stroke-dasharray="5,2" d="M198.6778,-978.637C182.4066,-972.8176 163.7253,-964.4984 148.985,-953.3624 133.1431,-941.3941 119.2685,-923.9297 109.2945,-909.3413"/>
+<polygon fill="#006400" stroke="#006400" points="103.6056,-900.7046 112.8644,-906.5804 106.356,-904.8801 109.1064,-909.0557 109.1064,-909.0557 109.1064,-909.0557 106.356,-904.8801 105.3483,-911.5311 103.6056,-900.7046 103.6056,-900.7046"/>
+<text text-anchor="middle" x="165.5075" y="-944.3624" font-family="arial" font-size="10.00" fill="#006400">connect</text>
+</g>
+<!-- uRcv -->
+<g id="node7" class="node">
+<title>uRcv</title>
+<polygon fill="none" stroke="#ffa500" points="214.0134,-553.4624 193.0067,-581.6377 150.9933,-581.6377 129.9866,-553.4624 150.9933,-525.2872 193.0067,-525.2872 214.0134,-553.4624"/>
+<text text-anchor="middle" x="172" y="-556.7624" font-family="arial" font-size="11.00" fill="#000000">user</text>
+<text text-anchor="middle" x="172" y="-543.5624" font-family="arial" font-size="11.00" fill="#000000">receive</text>
+</g>
+<!-- connectClnt&#45;&gt;uRcv -->
+<g id="edge24" class="edge">
+<title>connectClnt&#45;&gt;uRcv</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M237.1238,-971.0203C239.9206,-916.7089 244.541,-752.4513 208,-623.3874 204.8674,-612.323 199.8997,-600.9707 194.6434,-590.7174"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="189.7794,-581.6499 198.472,-588.3349 192.143,-586.056 194.5065,-590.4621 194.5065,-590.4621 194.5065,-590.4621 192.143,-586.056 190.541,-592.5893 189.7794,-581.6499 189.7794,-581.6499"/>
+<text text-anchor="middle" x="247.7235" y="-837.5624" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- uSnd -->
+<g id="node8" class="node">
+<title>uSnd</title>
+<polygon fill="none" stroke="#ffa500" points="111.5662,-553.4624 95.2831,-581.6377 62.7169,-581.6377 46.4338,-553.4624 62.7169,-525.2872 95.2831,-525.2872 111.5662,-553.4624"/>
+<text text-anchor="middle" x="79" y="-556.7624" font-family="arial" font-size="11.00" fill="#000000">user</text>
+<text text-anchor="middle" x="79" y="-543.5624" font-family="arial" font-size="11.00" fill="#000000">send</text>
+</g>
+<!-- connectClnt&#45;&gt;uSnd -->
+<g id="edge25" class="edge">
+<title>connectClnt&#45;&gt;uSnd</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M232.6954,-971.3264C227.2453,-941.3316 216.1632,-879.2768 208,-826.5624 201.0253,-781.5225 212.2627,-655.5799 180,-623.3874 161.268,-604.6963 143.493,-629.327 121,-615.3874 111.1934,-609.31 103.1361,-599.9964 96.7947,-590.4234"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="91.4524,-581.6443 100.4951,-587.8476 94.0516,-585.9157 96.6509,-590.187 96.6509,-590.187 96.6509,-590.187 94.0516,-585.9157 92.8067,-592.5263 91.4524,-581.6443 91.4524,-581.6443"/>
+<text text-anchor="middle" x="219.7235" y="-837.5624" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- uAgent -->
+<g id="node11" class="node">
+<title>uAgent</title>
+<polygon fill="none" stroke="#ffa500" points="715.5622,-670.4749 697.7811,-698.6502 662.2189,-698.6502 644.4378,-670.4749 662.2189,-642.2997 697.7811,-642.2997 715.5622,-670.4749"/>
+<text text-anchor="middle" x="680" y="-673.7749" font-family="arial" font-size="11.00" fill="#000000">user</text>
+<text text-anchor="middle" x="680" y="-660.5749" font-family="arial" font-size="11.00" fill="#000000">agent</text>
+</g>
+<!-- runClnt&#45;&gt;uAgent -->
+<g id="edge26" class="edge">
+<title>runClnt&#45;&gt;uAgent</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M363.0275,-971.304C418.9032,-918.2741 582.8091,-762.7159 650.3686,-698.5972"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="657.7387,-691.6025 653.5831,-701.7505 654.112,-695.0444 650.4853,-698.4864 650.4853,-698.4864 650.4853,-698.4864 654.112,-695.0444 647.3875,-695.2224 657.7387,-691.6025 657.7387,-691.6025"/>
+<text text-anchor="middle" x="482.7235" y="-879.5624" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- uProcess -->
+<g id="node12" class="node">
+<title>uProcess</title>
+<polygon fill="none" stroke="#ffa500" points="849.4801,-670.4749 822.24,-698.6502 767.76,-698.6502 740.5199,-670.4749 767.76,-642.2997 822.24,-642.2997 849.4801,-670.4749"/>
+<text text-anchor="middle" x="795" y="-673.7749" font-family="arial" font-size="11.00" fill="#000000">process</text>
+<text text-anchor="middle" x="795" y="-660.5749" font-family="arial" font-size="11.00" fill="#000000">responses</text>
+</g>
+<!-- runClnt&#45;&gt;uProcess -->
+<g id="edge27" class="edge">
+<title>runClnt&#45;&gt;uProcess</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M375.4171,-984.2599C446.9624,-971.0733 623.6511,-929.4235 725,-826.5624 757.4412,-793.6372 776.3095,-743.0546 786.1177,-708.4539"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="788.7618,-698.7069 790.4867,-709.5363 787.4527,-703.5325 786.1436,-708.3581 786.1436,-708.3581 786.1436,-708.3581 787.4527,-703.5325 781.8006,-707.1799 788.7618,-698.7069 788.7618,-698.7069"/>
+<text text-anchor="middle" x="686.7235" y="-879.5624" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- uSock&#45;&gt;uRcv -->
+<g id="edge4" class="edge">
+<title>uSock&#45;&gt;uRcv</title>
+<path fill="none" stroke="#006400" d="M97.3599,-864.3998C109.8154,-812.5125 145.7537,-662.8 162.808,-591.7545"/>
+<polygon fill="#006400" stroke="#006400" points="165.1822,-581.8642 167.2236,-592.6383 164.0151,-586.7261 162.848,-591.5879 162.848,-591.5879 162.848,-591.5879 164.0151,-586.7261 158.4723,-590.5375 165.1822,-581.8642 165.1822,-581.8642"/>
+</g>
+<!-- uInq -->
+<g id="node9" class="node">
+<title>uInq</title>
+<polygon fill="none" stroke="#000000" points="392.5723,-449.7766 347.4277,-449.7766 347.4277,-414.5733 392.5723,-414.5733 392.5723,-408.5733 410.5723,-432.175 392.5723,-455.7766 392.5723,-449.7766"/>
+<text text-anchor="middle" x="379" y="-442.075" font-family="arial" font-size="11.00" fill="#000000">user</text>
+<text text-anchor="middle" x="379" y="-428.875" font-family="arial" font-size="11.00" fill="#000000">receive</text>
+<text text-anchor="middle" x="379" y="-415.675" font-family="arial" font-size="11.00" fill="#000000">TBQueue</text>
+</g>
+<!-- uRcv&#45;&gt;uInq -->
+<g id="edge6" class="edge">
+<title>uRcv&#45;&gt;uInq</title>
+<path fill="none" stroke="#006400" d="M207.752,-544.8492C243.6388,-534.9021 299.1678,-515.8485 339,-485.175 346.5794,-479.3383 353.4481,-471.7165 359.2704,-464.0802"/>
+<polygon fill="#006400" stroke="#006400" points="365.1617,-455.8721 362.9865,-466.6201 362.2462,-459.9341 359.3307,-463.9961 359.3307,-463.9961 359.3307,-463.9961 362.2462,-459.9341 355.6749,-461.3722 365.1617,-455.8721 365.1617,-455.8721"/>
+</g>
+<!-- uOutq -->
+<g id="node10" class="node">
+<title>uOutq</title>
+<polygon fill="none" stroke="#000000" points="329.5723,-449.7766 284.4277,-449.7766 284.4277,-455.7766 266.4277,-432.175 284.4277,-408.5733 284.4277,-414.5733 329.5723,-414.5733 329.5723,-449.7766"/>
+<text text-anchor="middle" x="298" y="-442.075" font-family="arial" font-size="11.00" fill="#000000">user</text>
+<text text-anchor="middle" x="298" y="-428.875" font-family="arial" font-size="11.00" fill="#000000">send</text>
+<text text-anchor="middle" x="298" y="-415.675" font-family="arial" font-size="11.00" fill="#000000">TBQueue</text>
+</g>
+<!-- uRcv&#45;&gt;uOutq -->
+<g id="edge10" class="edge">
+<title>uRcv&#45;&gt;uOutq</title>
+<path fill="none" stroke="#00ff00" d="M196.5932,-529.7891C216.4531,-510.6719 244.5472,-483.6285 266.1304,-462.8527"/>
+<polygon fill="#00ff00" stroke="#00ff00" points="273.4688,-455.7886 269.3851,-465.9658 269.8666,-459.2562 266.2643,-462.7237 266.2643,-462.7237 266.2643,-462.7237 269.8666,-459.2562 263.1435,-459.4817 273.4688,-455.7886 273.4688,-455.7886"/>
+</g>
+<!-- uSnd&#45;&gt;uSock -->
+<g id="edge5" class="edge">
+<title>uSnd&#45;&gt;uSock</title>
+<path fill="none" stroke="#006400" d="M80.2082,-581.8642C82.8558,-644.1008 89.1434,-791.9036 91.7913,-854.15"/>
+<polygon fill="#006400" stroke="#006400" points="92.2274,-864.3998 87.3063,-854.6001 92.0148,-859.4043 91.8022,-854.4088 91.8022,-854.4088 91.8022,-854.4088 92.0148,-859.4043 96.2982,-854.2175 92.2274,-864.3998 92.2274,-864.3998"/>
+</g>
+<!-- uInq&#45;&gt;uAgent -->
+<g id="edge7" class="edge">
+<title>uInq&#45;&gt;uAgent</title>
+<path fill="none" stroke="#006400" d="M396.6501,-455.9955C404.2553,-465.5484 413.5612,-476.3588 423,-485.175 495.6201,-553.0045 593.7284,-617.3782 645.1887,-649.3958"/>
+<polygon fill="#006400" stroke="#006400" points="653.9378,-654.8067 643.0659,-653.374 649.6853,-652.1767 645.4329,-649.5468 645.4329,-649.5468 645.4329,-649.5468 649.6853,-652.1767 647.7999,-645.7196 653.9378,-654.8067 653.9378,-654.8067"/>
+</g>
+<!-- uOutq&#45;&gt;uSnd -->
+<g id="edge9" class="edge">
+<title>uOutq&#45;&gt;uSnd</title>
+<path fill="none" stroke="#006400" d="M266.3235,-441.7172C229.3231,-453.7931 167.2864,-476.9926 121,-509.375 115.6566,-513.1132 110.4497,-517.6098 105.6237,-522.2822"/>
+<polygon fill="#006400" stroke="#006400" points="98.3887,-529.6856 102.1596,-519.3885 101.8833,-526.1096 105.378,-522.5337 105.378,-522.5337 105.378,-522.5337 101.8833,-526.1096 108.5964,-525.6789 98.3887,-529.6856 98.3887,-529.6856"/>
+</g>
+<!-- uAgent&#45;&gt;connectionsStore -->
+<g id="edge21" class="edge">
+<title>uAgent&#45;&gt;connectionsStore</title>
+<path fill="none" stroke="#880000" d="M711.4852,-644.5965C717.9336,-640.4916 724.9231,-636.8075 732,-634.3874 772.2162,-620.6351 884.2913,-641.9405 923,-624.3874 937.8878,-617.6364 951.2411,-606.1048 962.1439,-594.2794"/>
+<polygon fill="#880000" stroke="#880000" points="703.07,-650.3759 708.7656,-641.0051 707.1916,-647.5452 711.3132,-644.7146 711.3132,-644.7146 711.3132,-644.7146 707.1916,-647.5452 713.8608,-648.424 703.07,-650.3759 703.07,-650.3759"/>
+<polygon fill="#880000" stroke="#880000" points="968.9461,-586.5133 965.7424,-597.0007 965.6517,-590.2745 962.3573,-594.0358 962.3573,-594.0358 962.3573,-594.0358 965.6517,-590.2745 958.9722,-591.0708 968.9461,-586.5133 968.9461,-586.5133"/>
+</g>
+<!-- uAgent&#45;&gt;uOutq -->
+<g id="edge11" class="edge">
+<title>uAgent&#45;&gt;uOutq</title>
+<path fill="none" stroke="#00ff00" d="M647.3434,-665.3697C591.4951,-656.2129 480.4257,-636.0193 447,-615.3874 386.1848,-577.8496 339.1057,-506.4848 315.2537,-464.7649"/>
+<polygon fill="#00ff00" stroke="#00ff00" points="310.2445,-455.8352 319.0616,-462.3552 312.6907,-460.196 315.1369,-464.5567 315.1369,-464.5567 315.1369,-464.5567 312.6907,-460.196 311.2123,-466.7583 310.2445,-455.8352 310.2445,-455.8352"/>
+</g>
+<!-- runClient -->
+<g id="node14" class="node">
+<title>runClient</title>
+<polygon fill="none" stroke="#ffa500" points="722.7244,-432.175 701.3622,-450.175 658.6378,-450.175 637.2756,-432.175 658.6378,-414.175 701.3622,-414.175 722.7244,-432.175"/>
+<text text-anchor="middle" x="680" y="-428.875" font-family="arial" font-size="11.00" fill="#000000">runClient</text>
+</g>
+<!-- uAgent&#45;&gt;runClient -->
+<g id="edge30" class="edge">
+<title>uAgent&#45;&gt;runClient</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M680,-642.203C680,-596.3198 680,-506.1699 680,-460.3495"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="680,-450.2297 684.5001,-460.2297 680,-455.2297 680.0001,-460.2297 680.0001,-460.2297 680.0001,-460.2297 680,-455.2297 675.5001,-460.2298 680,-450.2297 680,-450.2297"/>
+<text text-anchor="middle" x="688.3335" y="-550.4624" font-family="arial" font-size="10.00" fill="#ffa500">fork</text>
+</g>
+<!-- sOutq -->
+<g id="node15" class="node">
+<title>sOutq</title>
+<polygon fill="none" stroke="#000000" points="785.5723,-444.175 740.4277,-444.175 740.4277,-420.175 785.5723,-420.175 785.5723,-414.175 803.5723,-432.175 785.5723,-450.175 785.5723,-444.175"/>
+<text text-anchor="middle" x="772" y="-435.475" font-family="arial" font-size="11.00" fill="#000000">srv send</text>
+<text text-anchor="middle" x="772" y="-422.275" font-family="arial" font-size="11.00" fill="#000000">TBQueue</text>
+</g>
+<!-- uAgent&#45;&gt;sOutq -->
+<g id="edge14" class="edge">
+<title>uAgent&#45;&gt;sOutq</title>
+<path fill="none" stroke="#0000ff" d="M691.5879,-642.1215C694.8569,-633.6035 698.2645,-624.1836 701,-615.3874 716.6229,-565.151 708.4801,-548.8178 729,-500.375 735.1504,-485.8551 744.2149,-470.9073 752.4376,-458.7199"/>
+<polygon fill="#0000ff" stroke="#0000ff" points="758.2226,-450.3792 756.2211,-461.1608 755.373,-454.4877 752.5234,-458.5962 752.5234,-458.5962 752.5234,-458.5962 755.373,-454.4877 748.8257,-456.0316 758.2226,-450.3792 758.2226,-450.3792"/>
+</g>
+<!-- userState -->
+<g id="node19" class="node">
+<title>userState</title>
+<polygon fill="none" stroke="#000000" points="890.7837,-482.5758 887.7837,-486.5758 866.7837,-486.5758 863.7837,-482.5758 821.2163,-482.5758 821.2163,-381.7742 890.7837,-381.7742 890.7837,-482.5758"/>
+<text text-anchor="middle" x="856" y="-468.475" font-family="arial" font-size="11.00" fill="#000000">connected</text>
+<text text-anchor="middle" x="856" y="-455.275" font-family="arial" font-size="11.00" fill="#000000">servers,</text>
+<text text-anchor="middle" x="856" y="-442.075" font-family="arial" font-size="11.00" fill="#000000">subscribed</text>
+<text text-anchor="middle" x="856" y="-428.875" font-family="arial" font-size="11.00" fill="#000000">queues,</text>
+<text text-anchor="middle" x="856" y="-415.675" font-family="arial" font-size="11.00" fill="#000000">sent</text>
+<text text-anchor="middle" x="856" y="-402.475" font-family="arial" font-size="11.00" fill="#000000">commands</text>
+<text text-anchor="middle" x="856" y="-389.275" font-family="arial" font-size="11.00" fill="#000000">(STM)</text>
+</g>
+<!-- uAgent&#45;&gt;userState -->
+<g id="edge19" class="edge">
+<title>uAgent&#45;&gt;userState</title>
+<path fill="none" stroke="#ff8888" d="M705.4839,-635.9704C734.1546,-597.1508 781.1323,-533.5442 814.9848,-487.7086"/>
+<polygon fill="#ff8888" stroke="#ff8888" points="699.5075,-644.0622 701.8288,-633.3448 702.478,-640.0402 705.4485,-636.0182 705.4485,-636.0182 705.4485,-636.0182 702.478,-640.0402 709.0683,-638.6917 699.5075,-644.0622 699.5075,-644.0622"/>
+<polygon fill="#ff8888" stroke="#ff8888" points="820.9337,-479.654 818.6124,-490.3714 817.9632,-483.6759 814.9927,-487.6979 814.9927,-487.6979 814.9927,-487.6979 817.9632,-483.6759 811.3729,-485.0245 820.9337,-479.654 820.9337,-479.654"/>
+</g>
+<!-- uProcess&#45;&gt;connectionsStore -->
+<g id="edge22" class="edge">
+<title>uProcess&#45;&gt;connectionsStore</title>
+<path fill="none" stroke="#880000" d="M851.5097,-660.0083C892.5279,-651.4468 943.5859,-638.4864 960,-624.3874 968.7086,-616.9071 975.1618,-606.5771 979.8973,-596.1137"/>
+<polygon fill="#880000" stroke="#880000" points="841.5933,-662.0345 850.49,-655.6236 846.4921,-661.0335 851.3909,-660.0325 851.3909,-660.0325 851.3909,-660.0325 846.4921,-661.0335 852.2918,-664.4414 841.5933,-662.0345 841.5933,-662.0345"/>
+<polygon fill="#880000" stroke="#880000" points="983.7787,-586.5449 984.1898,-597.5031 981.8992,-591.1782 980.0198,-595.8116 980.0198,-595.8116 980.0198,-595.8116 981.8992,-591.1782 975.8498,-594.12 983.7787,-586.5449 983.7787,-586.5449"/>
+</g>
+<!-- uProcess&#45;&gt;uOutq -->
+<g id="edge8" class="edge">
+<title>uProcess&#45;&gt;uOutq</title>
+<path fill="none" stroke="#006400" d="M782.4156,-642.109C763.1961,-600.1829 726.1195,-524.9349 701,-509.375 632.2716,-466.8022 409.1254,-523.6095 338,-485.175 329.0427,-480.3347 321.505,-472.5258 315.4734,-464.3728"/>
+<polygon fill="#006400" stroke="#006400" points="309.7367,-455.862 319.0575,-461.639 312.5314,-460.0081 315.326,-464.1542 315.326,-464.1542 315.326,-464.1542 312.5314,-460.0081 311.5946,-466.6694 309.7367,-455.862 309.7367,-455.862"/>
+</g>
+<!-- uProcess&#45;&gt;sOutq -->
+<g id="edge15" class="edge">
+<title>uProcess&#45;&gt;sOutq</title>
+<path fill="none" stroke="#0000ff" d="M792.2713,-642.203C787.8428,-596.3198 779.1418,-506.1699 774.7193,-460.3495"/>
+<polygon fill="#0000ff" stroke="#0000ff" points="773.7426,-450.2297 779.1826,-459.7511 774.223,-455.2066 774.7034,-460.1835 774.7034,-460.1835 774.7034,-460.1835 774.223,-455.2066 770.2242,-460.6158 773.7426,-450.2297 773.7426,-450.2297"/>
+</g>
+<!-- uProcess&#45;&gt;userState -->
+<g id="edge20" class="edge">
+<title>uProcess&#45;&gt;userState</title>
+<path fill="none" stroke="#ff8888" d="M804.7422,-632.4164C814.4107,-594.6461 829.3748,-536.188 840.6433,-492.1666"/>
+<polygon fill="#ff8888" stroke="#ff8888" points="802.237,-642.203 800.3575,-631.3994 803.477,-637.3592 804.717,-632.5154 804.717,-632.5154 804.717,-632.5154 803.477,-637.3592 809.0764,-633.6313 802.237,-642.203 802.237,-642.203"/>
+<polygon fill="#ff8888" stroke="#ff8888" points="843.1328,-482.4415 845.0123,-493.2451 841.8928,-487.2854 840.6529,-492.1292 840.6529,-492.1292 840.6529,-492.1292 841.8928,-487.2854 836.2934,-491.0132 843.1328,-482.4415 843.1328,-482.4415"/>
+</g>
+<!-- uRespq -->
+<g id="node13" class="node">
+<title>uRespq</title>
+<polygon fill="none" stroke="#000000" points="744.5723,-57.4017 699.4277,-57.4017 699.4277,-22.1983 744.5723,-22.1983 744.5723,-16.1983 762.5723,-39.8 744.5723,-63.4017 744.5723,-57.4017"/>
+<text text-anchor="middle" x="731" y="-49.7" font-family="arial" font-size="11.00" fill="#000000">user</text>
+<text text-anchor="middle" x="731" y="-36.5" font-family="arial" font-size="11.00" fill="#000000">SMP</text>
+<text text-anchor="middle" x="731" y="-23.3" font-family="arial" font-size="11.00" fill="#000000">TBQueue</text>
+</g>
+<!-- uRespq&#45;&gt;uProcess -->
+<g id="edge29" class="edge">
+<title>uRespq&#45;&gt;uProcess</title>
+<path fill="none" stroke="#000000" d="M762.5896,-44.0035C813.9769,-51.7359 910,-70.3048 910,-101.1 910,-553.4624 910,-553.4624 910,-553.4624 910,-594.8589 872.935,-626.9659 840.89,-646.9888"/>
+<polygon fill="#000000" stroke="#000000" points="832.0197,-652.3135 838.2775,-643.3085 836.3067,-649.7401 840.5936,-647.1667 840.5936,-647.1667 840.5936,-647.1667 836.3067,-649.7401 842.9097,-651.0249 832.0197,-652.3135 832.0197,-652.3135"/>
+</g>
+<!-- sAgent -->
+<g id="node17" class="node">
+<title>sAgent</title>
+<polygon fill="none" stroke="#ffa500" points="656.0134,-172.6875 635.0067,-200.8627 592.9933,-200.8627 571.9866,-172.6875 592.9933,-144.5122 635.0067,-144.5122 656.0134,-172.6875"/>
+<text text-anchor="middle" x="614" y="-175.9875" font-family="arial" font-size="11.00" fill="#000000">server</text>
+<text text-anchor="middle" x="614" y="-162.7875" font-family="arial" font-size="11.00" fill="#000000">receive</text>
+</g>
+<!-- runClient&#45;&gt;sAgent -->
+<g id="edge12" class="edge">
+<title>runClient&#45;&gt;sAgent</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M663.5617,-414.1714C650.0082,-397.4105 633,-371.0774 633,-344.475 633,-344.475 633,-344.475 633,-257.475 633,-242.0587 629.9721,-225.439 626.3339,-211.0334"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="623.6113,-200.9841 630.5697,-209.4594 624.9188,-205.8101 626.2263,-210.6361 626.2263,-210.6361 626.2263,-210.6361 624.9188,-205.8101 621.8829,-211.8129 623.6113,-200.9841 623.6113,-200.9841"/>
+<text text-anchor="middle" x="642.7235" y="-297.975" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- sSnd -->
+<g id="node18" class="node">
+<title>sSnd</title>
+<polygon fill="none" stroke="#ffa500" points="750.0217,-172.6875 731.0109,-200.8627 692.9891,-200.8627 673.9783,-172.6875 692.9891,-144.5122 731.0109,-144.5122 750.0217,-172.6875"/>
+<text text-anchor="middle" x="712" y="-175.9875" font-family="arial" font-size="11.00" fill="#000000">server</text>
+<text text-anchor="middle" x="712" y="-162.7875" font-family="arial" font-size="11.00" fill="#000000">send</text>
+</g>
+<!-- runClient&#45;&gt;sSnd -->
+<g id="edge13" class="edge">
+<title>runClient&#45;&gt;sSnd</title>
+<path fill="none" stroke="#ffa500" stroke-dasharray="5,2" d="M684.2567,-414.1504C688.048,-396.5013 693,-368.7944 693,-344.475 693,-344.475 693,-344.475 693,-257.475 693,-242.0587 696.0279,-225.439 699.6661,-211.0334"/>
+<polygon fill="#ffa500" stroke="#ffa500" points="702.3887,-200.9841 704.1171,-211.8129 701.0812,-205.8101 699.7737,-210.6361 699.7737,-210.6361 699.7737,-210.6361 701.0812,-205.8101 695.4303,-209.4594 702.3887,-200.9841 702.3887,-200.9841"/>
+<text text-anchor="middle" x="702.7235" y="-297.975" font-family="arial" font-size="10.00" fill="#ffa500">race</text>
+</g>
+<!-- sOutq&#45;&gt;sSnd -->
+<g id="edge16" class="edge">
+<title>sOutq&#45;&gt;sSnd</title>
+<path fill="none" stroke="#0000ff" d="M767.4159,-414.1688C763.3329,-396.5332 758,-368.8362 758,-344.475 758,-344.475 758,-344.475 758,-257.475 758,-238.8558 749.3238,-220.4171 739.5075,-205.5139"/>
+<polygon fill="#0000ff" stroke="#0000ff" points="733.653,-197.1731 743.0814,-202.7728 736.5256,-201.2656 739.3981,-205.3581 739.3981,-205.3581 739.3981,-205.3581 736.5256,-201.2656 735.7149,-207.9434 733.653,-197.1731 733.653,-197.1731"/>
+</g>
+<!-- sSock -->
+<g id="node16" class="node">
+<title>sSock</title>
+<polygon fill="none" stroke="#0000ff" points="619.2006,-450.175 434.7994,-450.175 434.7994,-414.175 619.2006,-414.175 619.2006,-450.175"/>
+<text text-anchor="middle" x="527" y="-428.875" font-family="arial" font-size="11.00" fill="#000000">SMP client connection TCP socket</text>
+</g>
+<!-- sSock&#45;&gt;sAgent -->
+<g id="edge18" class="edge">
+<title>sSock&#45;&gt;sAgent</title>
+<path fill="none" stroke="#0000ff" d="M533.3267,-413.9457C538.8538,-396.3776 546,-368.9339 546,-344.475 546,-344.475 546,-344.475 546,-257.475 546,-234.2863 561.6699,-213.8223 577.9653,-198.8106"/>
+<polygon fill="#0000ff" stroke="#0000ff" points="585.9492,-191.8912 581.3395,-201.8412 582.1708,-195.1659 578.3923,-198.4406 578.3923,-198.4406 578.3923,-198.4406 582.1708,-195.1659 575.4451,-195.04 585.9492,-191.8912 585.9492,-191.8912"/>
+</g>
+<!-- sAgent&#45;&gt;uRespq -->
+<g id="edge28" class="edge">
+<title>sAgent&#45;&gt;uRespq</title>
+<path fill="none" stroke="#000000" d="M636.8365,-146.75C655.8728,-125.1288 683.0563,-94.254 703.3269,-71.2308"/>
+<polygon fill="#000000" stroke="#000000" points="710.1839,-63.4427 706.9532,-73.9219 706.8798,-67.1955 703.5757,-70.9482 703.5757,-70.9482 703.5757,-70.9482 706.8798,-67.1955 700.1982,-67.9746 710.1839,-63.4427 710.1839,-63.4427"/>
+</g>
+<!-- sSnd&#45;&gt;sSock -->
+<g id="edge17" class="edge">
+<title>sSnd&#45;&gt;sSock</title>
+<path fill="none" stroke="#0000ff" d="M693.7955,-200.8992C685.9738,-211.2174 676.0767,-222.2439 665,-229.975 634.5137,-251.2531 586,-220.2974 586,-257.475 586,-344.475 586,-344.475 586,-344.475 586,-368.2876 570.8403,-390.4932 555.8897,-406.6024"/>
+<polygon fill="#0000ff" stroke="#0000ff" points="548.6344,-414.0012 552.4229,-403.7105 552.1352,-410.4312 555.6359,-406.8612 555.6359,-406.8612 555.6359,-406.8612 552.1352,-410.4312 558.8489,-410.0118 548.6344,-414.0012 548.6344,-414.0012"/>
+</g>
+</g>
+</svg>

package.yaml

@@ -1,40 +1,58 @@
-name: simplex-messaging
-version: 0.1.0.0
-#synopsis:
-#description:
-homepage: https://github.com/simplex-chat/simplex-messaging#readme
+name: simplexmq
+version: 0.3.2
+synopsis: SimpleXMQ message broker
+description:  |
+  This package includes <./docs/Simplex-Messaging-Server.html server>,
+  <./docs/Simplex-Messaging-Client.html client> and
+  <./docs/Simplex-Messaging-Agent.html agent> for SMP protocols:
+  .
+  * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md SMP protocol>
+  * <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md SMP agent protocol>
+  .
+  See <https://github.com/simplex-chat/simplex-chat terminal chat prototype> built with SimpleXMQ broker.
+
+homepage: https://github.com/simplex-chat/simplexmq#readme
 license: AGPL-3
-author: Evgeny Poberezkin
-maintainer: [email protected]
-copyright: 2020 Evgeny Poberezkin
-category: Web, System, Services, Cryptography
+author: simplex.chat
+maintainer: [email protected]
+copyright: 2020 simplex.chat
+category: Chat, Network, Web, System, Cryptography
 extra-source-files:
   - README.md
+  - CHANGELOG.md
 
 dependencies:
+  - ansi-terminal == 0.10.*
+  - asn1-encoding == 0.9.*
+  - asn1-types == 0.3.*
   - async == 2.2.*
   - attoparsec == 0.13.*
   - base >= 4.7 && < 5
   - base64-bytestring >= 1.0 && < 1.3
   - bytestring == 0.10.*
-  - containers
-  - cryptonite == 0.26.*
+  - containers == 0.6.*
+  - cryptonite == 0.27.*
   - directory == 1.3.*
   - filepath == 1.4.*
+  - generic-random == 1.3.*
   - iso8601-time == 0.1.*
   - memory == 0.15.*
-  - mtl
+  - mtl == 2.2.*
   - network == 3.1.*
   - network-transport == 0.5.*
+  - QuickCheck == 2.14.*
+  - random == 1.1.*
   - simple-logger == 0.1.*
   - sqlite-simple == 0.4.*
-  - stm
-  - template-haskell == 2.15.*
+  - stm == 2.5.*
+  - template-haskell == 2.16.*
   - text == 1.2.*
   - time == 1.9.*
   - transformers == 0.5.*
   - unliftio == 0.2.*
-  - unliftio-core == 0.1.*
+  - unliftio-core == 0.2.*
+  - websockets == 0.12.*
+  - x509 == 1.7.*
 
 library:
   source-dirs: src
@@ -44,7 +62,10 @@ executables:
     source-dirs: apps/smp-server
     main: Main.hs
     dependencies:
-      - simplex-messaging
+      - cryptostore == 0.2.*
+      - ini == 0.4.*
+      - optparse-applicative == 0.15.*
+      - simplexmq
     ghc-options:
       - -threaded
 
@@ -52,18 +73,7 @@ executables:
     source-dirs: apps/smp-agent
     main: Main.hs
     dependencies:
-      - simplex-messaging
-    ghc-options:
-      - -threaded
-
-  dog-food:
-    source-dirs: apps/dog-food
-    main: Main.hs
-    dependencies:
-      - ansi-terminal == 0.10.*
-      - optparse-applicative == 0.15.*
-      - simplex-messaging
-      - terminal == 0.2.*
+      - simplexmq
     ghc-options:
       - -threaded
 
@@ -72,11 +82,13 @@ tests:
     source-dirs: tests
     main: Test.hs
     dependencies:
-      - simplex-messaging
+      - simplexmq
       - hspec == 2.7.*
       - hspec-core == 2.7.*
       - HUnit == 1.6.*
       - random == 1.1.*
+      - QuickCheck == 2.14.*
+      - timeit == 2.0.*
 
 ghc-options:
   # - -haddock

protocol/agent-protocol.md

@@ -0,0 +1,314 @@
+# SMP agent protocol - duplex communication over SMP protocol
+
+## Table of contents
+
+- [Abstract](#abstract)
+- [SMP agent](#smp-agent)
+- [SMP servers management](#smp-servers-management)
+- [SMP agent protocol components](#smp-agent-protocol-components)
+- [Duplex connection procedure](#duplex-connection-procedure)
+- [Communication between SMP agents](#communication-between-smp-agents)
+  - [Message syntax](#messages-between-smp-agents)
+    - [HELLO message](#hello-message)
+    - [REPLY message](#reply-message)
+    - [MSG message](#msg-message)
+- [SMP agent commands](#smp-agent-commands)
+  - [Client commands and server responses](#client-commands-and-server-responses)
+    - [NEW command and INV response](#new-command-and-inv-response)
+    - [JOIN command](#join-command)
+    - [CON notification](#con-notification)
+    - [SUB command](#sub-command)
+    - [SEND command and SENT response](#send-command-and-sent-response)
+    - [MSG notification](#msg-notification)
+    - [END notification](#end-notification)
+    - [OFF command](#off-command)
+    - [DEL command](#del-command)
+- [Connection invitation](#connection-invitation)
+
+## Abstract
+
+The purpose of SMP agent protocol is to define the syntax and the semantics of communications between the client and the agent that connects to [SMP](./simplex-messaging.md) servers.
+
+It provides:
+- convenient protocol to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the protocol.
+- management of E2E encryption between SMP agents, generating ephemeral RSA keys for each connection.
+- SMP command authentication on SMP servers, generating ephemeral RSA keys for each SMP queue.
+- TCP transport handshake and encryption with SMP servers.
+- validation of message integrity.
+
+SMP agent protocols provides no encryption or any security on the client side - it is assumed that the agent is executed in the trusted and secure environment.
+
+The future versions of this protocol could provide:
+- managing redundant SMP queues with more than 1 queue in each direction.
+- managing simple symmetric groups as a foundation for chat groups and device synchronization.
+- agent cluster - synchronizing states of multiple agents.
+- secure "synchronous" streams with symmetric message encryption and connection-level authentication (requires extending [SMP protocol](./simplex-messaging.md)) - it can be used, e.g., for file transfers.
+
+## SMP agent
+
+SMP agent is a client-side process or library that communicates via SMP servers using [simplex messaging protocol (SMP)](./simplex-messaging.md) with other SMP agents according to the commands received from its users. This protocol is a middle layer in SMP protocols stack (above SMP protocol but below any application level protocol) - it is intended to be used by client-side applications that need secure asynchronous bi-directional communication channels ("connections").
+
+The agent must have a persistent storage to manage the states of known connections and of the client-side information of two SMP queues that each connection consists of, and also the buffer of the most recent messages. The number of the messages that should be stored is implementation specific, depending on the error management approach that the agent implements; at the very least the agent must store the hash and id of the last received message.
+
+## SMP servers management
+
+SMP agent protocol commands do not contain SMP servers that the agent will use to establish the connections between their users. The servers are part of the agent configuration and can be dynamically added and removed by the agent implementation:
+- by the client applications via any API that is outside of scope of this protocol.
+- by the agents themselves based on servers availability and latency.
+
+## SMP agent protocol components
+
+SMP agent protocol has 3 main parts:
+
+- the syntax and semantics of messages that SMP agents exchange between each other in order to:
+  - negotiate establishing unidirectional (simplex) encrypted queues on SMP server(s)
+  - exchange client messages and delivery notifications, providing sequential message IDs and message integrity (by including the hash of the previous message).
+- the syntax and semantics of the commands (a higher level interface than SMP protocol) that are sent over TCP or other sequential protocol by agent clients to the agents. This protocol allows to create and manage multiple connections, each consisting of two simplex SMP queues.
+- the syntax and semantics of the message that the clients of SMP agents should send out-of-band (as pre-shared "invitation" including SMP server, queue ID and encryption key) to ensure [E2E encryption][1] the integrity of SMP queues and protection against active attacks ([MITM attacks][2]).
+
+## Duplex connection procedure
+
+![Duplex connection procedure](./diagrams/duplex-messaging/duplex-creating.svg)
+
+The procedure of establishing a duplex connection is explained on the example of Alice and Bob creating a bi-directional connection comprised of two unidirectional (simplex) queues, using SMP agents (A and B) to facilitate it, and two different SMP servers (which could be the same server). It is shown on the diagram above and has these steps:
+
+1. Alice requests the new connection from the SMP agent A using `NEW` command.
+2. Agent A creates an SMP queue on the server (using [SMP protocol](./simplex-messaging.md)) and responds to Alice with the invitation that contains queue information and the encryption key Bob's agent B should use. The invitation format is described in [Connection invitation](#connection-invitation).
+3. Alice sends the invitation to Bob via any secure channel they have (out-of-band message).
+4. Bob sends `JOIN` command with the invitation as a parameter to agent B to accept the connection.
+5. Establishing Alice's SMP queue (with SMP protocol commands):
+  - Agent B sends unauthenticated message to SMP queue with ephemeral key that will be used to authenticate commands to the queue, as described in SMP protocol.
+  - Agent A receives the KEY and secures the queue.
+  - Agent B tries sending authenticated SMP SEND command with agent `HELLO` message until it succeeds. Once it succeeds, Bob's agent "knows" the queue is secured.
+6. Agent B creates a new SMP queue on the server.
+7. Establish Bob's SMP queue:
+  - Agent B sends `REPLY` message with the invitation to this 2nd queue to Alice's agent (via the 1st queue).
+  - Agent A having received this `REPLY` message sends unauthenticated message to SMP queue with Alice agent's ephemeral key that will be used to authenticate commands to the queue, as described in SMP protocol.
+  - Bob's agent receives the key and secures the queue.
+  - Alice's agent keeps sending `HELLO` message until it succeeds.
+8. Agents A and B notify Alice and Bob that connection is established.
+  - Once sending `HELLO` succeeds, Alice's agent sends to Alice `CON` notification that confirms that now both parties can communicate.
+  - Once Bob's agent receives `HELLO` from Alice's agent, it sends to Bob `CON` notification as well.
+
+At this point the duplex connection between Alice and Bob is established, they can use `SEND` command to send messages. The diagram also shows how the connection status changes for both parties, where the first part is the status of the SMP queue to receive messages, and the second part - the status of the queue to send messages.
+
+The most communication happens between the agents and servers, from the point of view of Alice and Bob they have only 3 steps to do:
+
+1. Alice requests a new connection with `NEW` command and receives the invitation.
+2. Alice passes invitation out-of-band to Bob.
+3. Bob accepts the connection by sending `JOIN` command with the invitation to his agent.
+
+## Communication between SMP agents
+
+SMP agents communicate via SMP servers managing creation, deletion and operations of SMP queues.
+
+Agents can use SMP message client body (the part of the SMP message after header - see [SMP protocol](./simplex-messaging.md)) to transmit agent client messages and exchange messages between each other.
+
+Each SMP message client body, once decrypted, contains 3 parts (one of them may include binary message body), as defined by `decryptedSmpMessageBody` syntax:
+
+- `agentMsgHeader` - agent message header that contains sequential agent message ID for a particular SMP queue, agent timestamp (ISO8601) and the hash of the previous message.
+- `agentMessage` - a command/message to the other SMP agent:
+  - to establish the connection with two SMP queues (`helloMsg`, `replyQueueMsg`)
+  - to send and to acknowledge user messages (`clientMsg`, `acknowledgeMsg`)
+  - to notify another agent about queue deletion (`deleteQueueMsg`)
+- `msgPadding` - an optional message padding to make all SMP messages have consistent size as an additional privacy protection measure.
+
+### Messages between SMP agents
+
+Message syntax below uses [ABNF][3] with [case-sensitive strings extension][4].
+
+```abnf
+decryptedSmpMessageBody = agentMsgHeader CRLF agentMessage CRLF msgPadding
+agentMsgHeader = agentMsgId SP agentTimestamp SP previousMsgHash ; here `agentMsgId` is sequential ID set by the sending agent
+agentMsgId = 1*DIGIT
+agentTimestamp = <date-time> ; RFC3339
+previousMsgHash = encoded
+encoded = <base64 encoded>
+
+agentMessage = helloMsg / replyQueueMsg / deleteQueueMsg / clientMsg / acknowledgeMsg
+
+msgPadding = *OCTET ; optional random bytes to get messages to the same size (as defined in SMP message size)
+
+helloMsg = %s"HELLO" SP signatureVerificationKey [SP %s"NO_ACK"]
+; NO_ACK means that acknowledgements to client messages will NOT be sent in this connection by the agent that sent `HELLO` message.
+signatureVerificationKey = encoded
+
+replyQueueMsg = %s"REPLY" SP <queueInfo> ; `queueInfo` is the same as in out-of-band message, see SMP protocol
+; this message can only be sent by the second connection party
+
+deleteQueueMsg = %s"DEL" ; notification that recipient queue will be deleted
+; no need to notify the other party about suspending queue separately, as suspended and deleted queues are the same to the sender 
+; NOT SUPPORTED with the current implementation
+
+clientMsg = %s"MSG" SP size CRLF clientMsgBody CRLF ; CRLF is in addition to CRLF in decryptedSmpMessageBody
+size = 1*DIGIT
+clientMsgBody = *OCTET
+
+acknowledgeMsg = %s"ACK" SP agentMsgId SP ackStatus
+; NOT SUPPORTED with the current implementation
+
+ackStatus = %s"OK" / ackError
+
+ackError = %s"ERR" SP ackErrorType
+
+ackErrorType = ackUnknownMsg / ackProhibitedMsg / ackSyntaxErr
+
+ackUnknownMsg = %s"UNKNOWN"
+
+ackProhibitedMsg = %s"PROHIBITED" ; e.g. "HELLO" or "REPLY"
+
+ackSyntaxErr = %s"SYNTAX" SP syntaxErrCode
+syntaxErrCode = 1*DIGIT ; TODO
+```
+
+#### HELLO message
+
+This is the first message that both agents send after the respective SMP queue is secured by the receiving agent (see diagram). It contains the verification key that the sender will use to cryptographically sign the messages.
+
+Sending agent might need to retry sending HELLO message, as it would not have any other confirmation that the queue is secured other than the success of sending this message with the signed SEND command of SMP protocol.
+
+#### REPLY message
+
+This is the message that is sent by the agent that received an out-of-band invitation to pass the invitation to the reply SMP queue to the agent that originated the connection (see diagram).
+
+#### MSG message
+
+This is the agent envelope used to send client messages once the connection is established. Do not confuse it with the MSG response from SMP server to the agent and MSG response from SMP agent to the client that are sent in different contexts.
+
+## SMP agent commands
+
+This part describes the transmissions between users and client-side SMP agents: commands that the users send to create and operate duplex connections and SMP agent responses and messages they deliver.
+
+Commands syntax below is provided using [ABNF][3] with [case-sensitive strings extension][4].
+
+Each transmission between the user and SMP agent must have this format/syntax:
+
+```abnf
+agentTransmission = [corrId] CRLF [cAlias] CRLF agentCommand
+
+corrId = 1*(%x21-7F) ; any characters other than control/whitespace
+
+cAlias = cId / cName
+cId = encoded
+cName = 1*(ALPHA / DIGIT / "_" / "-")
+
+agentCommand = (userCmd / agentMsg) CRLF
+userCmd = newCmd / joinCmd / subscribeCmd / sendCmd / acknowledgeCmd / suspendCmd / deleteCmd
+agentMsg = invitation / connected / unsubscribed / message / sent / received / ok / error
+
+newCmd = %s"NEW" [SP %s"NO_ACK"] ; response is `invitation` or `error`
+
+invitation = %s"INV" SP <queueInfo> ; `queueInfo` is the same as in out-of-band message, see SMP protocol
+
+connected = %s"CON"
+
+subscribeCmd = %s"SUB" ; response is `ok` or `error`
+
+unsubscribed = %s"END"
+; when another agent (or another client of the same agent)
+; subscribes to the same SMP queue on the server
+
+joinCmd = %s"JOIN" SP <queueInfo> [SP %s"NO_REPLY"] [SP %s"NO_ACK"]
+; `queueInfo` is the same as in out-of-band message, see SMP protocol
+; response is `connected` or `error`
+
+suspendCmd = %s"OFF" ; can be sent by either party, response `ok` or `error`
+
+deleteCmd = %s"DEL" ; can be sent by either party, response `ok` or `error`
+
+sendCmd = %s"SEND" SP msgBody
+; send syntax is similar to that of SMP protocol, but it is wrapped in SMP message
+msgBody = stringMsg | binaryMsg
+stringMsg = ":" string ; until CRLF in the transmission
+string = *(%x01-09 / %x0B-0C / %x0E-FF %) ; any characters other than NUL, CR and LF
+binaryMsg = size CRLF msgBody CRLF ; the last CRLF is in addition to CRLF in the transmission
+size = 1*DIGIT ; size in bytes
+msgBody = *OCTET ; any content of specified size - safe for binary
+
+sent = %s"SENT" SP agentMsgId
+
+message = %s"MSG" SP msgIntegrity SP recipientMeta SP brokerMeta SP senderMeta SP binaryMsg
+recipientMeta = %s"R=" agentMsgId "," agentTimestamp ; receiving agent message metadata 
+brokerMeta = %s"B=" brokerMsgId "," brokerTimestamp ; broker (server) message metadata
+senderMeta = %s"S=" agentMsgId "," agentTimestamp ; sending agent message metadata 
+brokerMsgId = encoded
+brokerTimestamp = <date-time>
+msgIntegrity = ok / messageError
+
+messageError = %s"ERR" SP messageErrorType
+messageErrorType = skippedMsgErr / badMsgIdErr / badHashErr
+
+skippedMsgErr = %s"NO_ID" SP missingFromMsgId SP missingToMsgId
+badMsgIdErr = %s"ID" SP previousMsgId ; ID is lower than the previous
+badHashErr = %s"HASH"
+
+missingFromMsgId = agentMsgId
+missingToMsgId = agentMsgId
+previousMsgId = agentMsgId
+
+acknowledgeCmd = %s"ACK" SP agentMsgId ; ID assigned by receiving agent (in MSG "R")
+; currently not implemented
+
+received = %s"RCVD" SP agentMsgId ; ID assigned by sending agent (in SENT response)
+; currently not implemented
+
+ok = %s"OK"
+
+error = %s"ERR" SP <errorType>
+```
+
+### Client commands and server responses
+
+#### NEW command and INV response
+
+`NEW` command is used to create a connection and an invitation to be sent out-of-band to another protocol user. It should be used by the client of the agent that initiates creating a duplex connection.
+
+`INV` response is sent by the agent to the client.
+
+#### JOIN command
+
+It is used to create a connection and accept the invitation received out-of-band. It should be used by the client of the agent that accepts the connection.
+
+#### CON notification
+
+It is sent by both agents managing duplex connection to their clients once the connection is established and ready to accept client messages.
+
+#### SUB command
+
+This command can be used by the client to resume receiving messages from the connection that was created in another TCP/client session. Agent response to this command can be `OK` or `ERR` in case connection does not exist (or can only be used to send connections - e.g. when the reply queue was not created).
+
+#### SEND command and SENT response
+
+`SEND` command is used to the client to send messages
+
+`SENT` response is sent by the agent to confirm that the message was delivered to the SMP server. Message ID in this response is the sequential message number that includes both sent and received messages in the connection.
+
+#### MSG notification
+
+It is sent by the agent to the client when agent receives the message from the SMP server. It has message ID and timestamp from both the receiving and sending agents and from SMP server:
+- recipient agent ID is intended to be used to refer to the message in the future.
+- sender agent ID is intended to be used to identify any missed / skipped message(s)
+- broker ID should be used to detect duplicate deliveries (it would happen if TCP connection is lost before the message is acknowledged by the agent - see [SMP protocol](./simplex-messaging.md))
+
+#### END notification
+
+It is sent by the agent to the client when agent receives SMP protocol `END` notification from SMP server. It indicates that another agent has subscribed to the same SMP queue on the server and the server terminated the subscription of the current agent.
+
+#### OFF command
+
+It is used to suspend the receiving SMP queue - sender will no longer be able to send the messages to the connection, but the recipient can retrieve the remaining messages. Agent response to this command can be `OK` or `ERR`. This command is irreversible.
+
+#### DEL command
+
+It is used to delete the connection and all messages in it, as well as the receiving SMP queue and all messages in it that were remaining on the server. Agent response to this command can be `OK` or `ERR`. This command is irreversible.
+
+## Connection invitation
+
+Connection invitation `queueInfo` is generated by SMP agent in response to `newCmd` command (`"NEW"`), used by another party user with `joinCmd` command (`"JOIN"`), and then another invitation is sent by the agent in `replyQueueMsg` and used by the first party agent to connect to the reply queue (the second part of the process is invisible to the users).
+
+See SMP protocol [out-of-band messages](./simplex-messaging.md#out-of-band-messages) for connection invitation syntax.
+
+[1]: https://en.wikipedia.org/wiki/End-to-end_encryption
+[2]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack
+[3]: https://tools.ietf.org/html/rfc5234
+[4]: https://tools.ietf.org/html/rfc7405

protocol/diagrams/duplex-messaging/duplex-creating.mmd

@@ -0,0 +1,71 @@
+sequenceDiagram
+  participant A as Alice
+  participant AA as Alice's<br>agent
+  participant AS as Alice's<br>server
+  participant BS as Bob's<br>server
+  participant BA as Bob's<br>agent
+  participant B as Bob
+
+  note over AA, BA: status (receive/send): NONE/NONE
+
+  note over A, AA: 1. request connection from agent
+  A ->> AA: NEW: create<br>duplex connection
+ 
+  note over AA, AS: 2. create Alice's SMP queue
+  AA ->> AS: NEW: create SMP queue
+  AS ->> AA: IDS: SMP queue IDs
+  note over AA: status: NEW/NONE
+
+  AA ->> A: INV: invitation<br>to connect
+  note over AA: status: PENDING/NONE
+
+  note over A, B: 3. out-of-band invitation
+  A ->> B: OOB: invitation to connect
+
+  note over BA, B: 4. accept connection
+  B ->> BA: JOIN:<br>via invitation info
+  note over BA: status: NONE/NEW
+
+  note over BA, AA: 5. establish Alice's SMP queue
+  BA ->> AS: SEND: KEY: sender's server key
+  note over BA: status: NONE/CONFIRMED
+  activate BA
+  AS ->> AA: MSG: KEY: sender's server key
+  note over AA: status: CONFIRMED/NONE
+  AA ->> AS: KEY: secure queue
+  note over AA: status: SECURED/NONE
+
+  BA ->> AS: SEND: HELLO: try sending until successful
+  deactivate BA
+  note over BA: status: NONE/ACTIVE
+  AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
+  note over AA: status: ACTIVE/NONE
+
+  note over BA, BS: 6. create Bob's SMP queue
+  BA ->> BS: NEW: create SMP queue
+  BS ->> BA: IDS: SMP queue IDs
+  note over BA: status: NEW/ACTIVE
+
+  note over AA, BA: 7. establish Bob's SMP queue
+  BA ->> AS: SEND: REPLY: invitation to the connect
+  note over BA: status: PENDING/ACTIVE
+  AS ->> AA: MSG: REPLY: invitation<br>to connect
+  note over AA: status: ACTIVE/NEW
+
+  AA ->> BS: SEND: KEY: sender's server key
+  note over AA: status: ACTIVE/CONFIRMED
+  activate AA
+  BS ->> BA: MSG: KEY: sender's server key
+  note over BA: status: CONFIRMED/ACTIVE
+  BA ->> BS: KEY: secure queue
+  note over BA: status: SECURED/ACTIVE
+
+  AA ->> BS: SEND: HELLO: try sending until successful
+  deactivate AA
+  note over AA: status: ACTIVE/ACTIVE
+  BS ->> BA: MSG: HELLO: Bob's agent<br>knows Alice can send
+  note over BA: status: ACTIVE/ACTIVE
+
+  note over A, B: 8. notify users about connection success
+  AA ->> A: CON: connected
+  BA ->> B: CON: connected

protocol/diagrams/simplex-messaging/simplex-creating.mmd

@@ -0,0 +1,20 @@
+sequenceDiagram
+  participant B as Bob (sender)
+  participant S as server (queue RID)
+  participant A as Alice (recipient)
+
+  note over A: creating queue<br>("public" key RK<br>for msg retrieval)
+  A ->> S: 1. create queue ("NEW")
+  S ->> A: respond with queue RID and SID ("IDS")
+
+  note over A: out-of-band msg<br>(sender's queue SID<br>and "public" key EK<br>to encrypt msgs)
+  A -->> B: 2. send out-of-band message
+
+  note over B: confirm queue<br>("public" key SK for<br>sending messages<br>and any optional<br>info encrypted with<br>"public" key EK)
+  B ->> S: 3. confirm queue ("SEND" command not signed)
+
+  S ->> A: 4. deliver Bob's message
+  note over A: decrypt message<br>("private" key EK)
+  A ->> S: 5. secure queue ("KEY", RK-signed)
+
+  note over S: 6. simplex<br>queue RID<br>is ready to use!

protocol/diagrams/simplex-messaging/simplex-op.mmd

@@ -0,0 +1,26 @@
+sequenceDiagram
+  participant S as sender (client)
+  participant A as transport
+  participant Q as pubsub
+  participant P as transport
+  participant R as receiver (client)
+  note over R: sign subscription (1)
+  R ->> P: subscribe to messages
+  note over P: verify subscriber (1)
+  alt subscriber verified?
+    P -->> Q: subscribe
+  else
+    P ->> R: reject subscription
+  end
+  note over S: sign message (2)
+  S ->> A: send message
+  note over A: verify sender (2)
+  alt sender verified?
+    A -->> Q: queue message
+    activate Q
+  else
+    A ->> S: reject message
+  end
+  Q -->> P: take message
+  deactivate Q
+  P ->> R: deliver message

protocol/diagrams/simplex-messaging/simplex-using.mmd

@@ -0,0 +1,10 @@
+sequenceDiagram
+  participant B as Bob (sender)
+  participant S as server (queue RID)
+  participant A as Alice (recipient)
+
+  note over B: encrypt message<br>("public" key EK)
+  B ->> S: 1. send message to SID (SK-signed command)
+
+  S ->> A: 2. receive messages from RID (RK-signed subscription)
+  note over A: decrypt message<br>("private" key EK)

protocol/diagrams/simplex-messaging/simplex.mmd

@@ -0,0 +1,11 @@
+graph LR
+  VS{{"verify sender (SK)"}}
+  VR{{"verify recipient (RK)"}}
+
+  S(sender) -->|msg| VS
+  subgraph "server (queue RID, SID)"
+    VS --> DB[("storage")]
+    DB --> VR
+  end
+  R(recipient) -->|"1) sub"| VR
+  VR -->|"2) msg"| R

protocol/simplex-messaging.md

@@ -0,0 +1,625 @@
+# Simplex Messaging Protocol (SMP)
+
+## Table of contents
+
+- [Abstract](#abstract)
+- [Introduction](#introduction)
+- [SMP Model](#smp-model)
+- [Out-of-band messages](#out-of-band-messages)
+- [Simplex queue](#simplex-queue)
+- [SMP procedure](#smp-procedure)
+- [SMP qualities and features](#smp-qualities-and-features)
+- [Cryptographic algorithms](#cryptographic-algorithms)
+- [Simplex queue IDs](#simplex-queue-ids)
+- [Server privacy requirements](#server-privacy-requirements)
+- [SMP commands](#smp-commands)
+  - [Correlating responses with commands](#correlating-responses-with-commands)
+  - [Command authentication](#command-authentication)
+  - [Keep-alive command](#keep-alive-command)
+  - [Recipient commands](#recipient-commands)
+    - [Create queue command](#create-queue-command)
+    - [Subscribe to queue](#subscribe-to-queue)
+    - [Secure queue command](#secure-queue-command)
+    - [Acknowledge message delivery](#acknowledge-message-delivery)
+    - [Suspend queue](#suspend-queue)
+    - [Delete queue](#delete-queue)
+  - [Sender commands](#sender-commands)
+    - [Send message](#send-message)
+  - [Server messages](#server-messages)
+    - [Queue IDs response](#queue-ids-response)
+    - [Deliver queue message](#deliver-queue-message)
+    - [Subscription END notification](#subscription-end-notification)
+    - [Error responses](#error-responses)
+    - [OK response](#ok-response)
+- [Appendices](#appendices)
+  - [Appendix A. Transport connection with the SMP server](#appendix-a)
+
+## Abstract
+
+Simplex Messaging Protocol is a transport agnostic client-server protocol for asynchronous distributed secure unidirectional message transmission via persistent simplex message queues.
+
+It's designed with the focus on communication security and integrity, under the assumption that any part of the message transmission network can be compromised.
+
+It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
+
+## Introduction
+
+The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
+
+SMP is independent of any particular transmission system and requires only a reliable ordered data stream channel. While this document describes transport over TCP, other transports are also possible.
+
+The protocol describes the set of commands that recipients and senders can exchange with SMP servers to create and to operate unidirectional "queues" (a data abstraction identifying one of many communication channels managed by the server) and to send messages from the sender to the recipient via the SMP server.
+
+More complex communication scenarios can be designed using multiple queues - for example, a duplex communication channel can be made of 2 simplex queues.
+
+The protocol is designed with the focus on privacy and security, to some extent deprioritizing reliability by requiring that SMP servers only store messages until they are acknowledged by the recipients and, in any case, for a limited period of time. For communication scenarios requiring more reliable transmission the users should use several SMP servers to pass each message and implement some additional protocol to ensure that messages are not removed, inserted or changed - this is out of scope of this document.
+
+SMP does not use any form of participants' identities and provides [E2EE][2] without the possibility of [MITM attack][1] relying on two pre-requisites:
+
+- the users can establish a secure encrypted transport connection with the SMP server. [Appendix A](#appendix-a) describes SMP transport protocol of such connection over TCP, but any other transport connection protocol can be used.
+
+- the recipient can pass a single message to the sender via a pre-existing secure and private communication channel (out-of-band message) - the information in this message is used to encrypt messages and to establish connection with SMP server.
+
+## SMP Model
+
+The SMP model has three communication participants: the recipient, the message broker (SMP server) that is chosen and, possibly, controlled by the recipient, and the sender.
+
+SMP server manages multiple "simplex queues" - data records on the server that identify communication channels from the senders to the recipients. The same communicating party that is the sender in one queue, can be the recipient in another - without exposing this fact to the server.
+
+The queue record consists of 2 unique random IDs generated by the server, one for the recipient and another for the sender, and 2 keys to authenticate the recipient and the sender respectively, provided by the client. The users of SMP protocol must use a unique key for each queue, to avoid the possibility of aggregating and analysing their queues in case SMP server is compromised.
+
+Creating and using the queue requires sending commands to the SMP server from the recipient and the sender - they are described in detail in [SMP commands](#smp-commands) section.
+
+## Out-of-band messages
+
+The out-of-band message with the queue information is sent via some trusted alternative channel from the recipient to the sender. This message is used to share the encryption (a.k.a. "public") key that the sender will use to encrypt the messages (to be decrypted by the recipient), sender queue ID, server hostname and any other information necessary to establish secure encrypted connection with SMP server (see [Appendix A](#appendix-a) for SMP transport protocol).
+
+The [ABNF][8] syntax of the message is:
+
+```abnf
+queueInfo = %s"smp::" smpServer "::" queueId "::" encryptionKey
+smpServer = srvHost [":" port] ["#" serverKeyHash]
+srvHost = <hostname> ; RFC1123, RFC5891
+port = 1*DIGIT
+serverKeyHash = encoded
+queueId = encoded
+encryptionKey = %s"rsa:" x509encoded ; the recipient's RSA public key for sender to encrypt messages
+x509encoded = <base64 X509 key encoding>
+encoded = <base64 encoded>
+```
+
+`hostname` can be IP address or domain name, as defined in RFC 1123, section 2.1.
+
+`port` is optional, the default TCP port for SMP protocol is 5223.
+
+`serverKeyHash` is an optional hash of the server transport key used during transport handshake (see [Appendix A](#appendix-a)).
+
+Encryption keys are encoded using [X509][11] specification.
+
+Defining the approach to out-of-band message passing is out of scope of this protocol.
+
+## Simplex queue
+
+The simplex queue is the main unit of SMP protocol. It is used by:
+
+- Sender of the queue (who received out-of-band message) to send messages to the server using sender's queue ID, signed by sender's key.
+
+- Recipient of the queue (who created the queue and sent out-of-band message) will use it to retrieve messages from the server, signing the commands by the recipient key.
+
+- Participant identities are not shared with the server - new unique keys and queue IDs are used for each queue.
+
+This simplex queue can serve as a building block for more complex communication network. For example, two (or more, for redundancy) simplex queues can be used to create a duplex communication channel. Higher level primitives that are only known to system participants in their client applications can be created as well - e.g., contacts, conversations, groups and broadcasts. Simplex messaging servers only have the information about the low-level simplex queues. In this way a high level of privacy and security of the communication is provided. Application level primitives are not in scope of this protocol.
+
+This approach is based on the concept of [unidirectional networks][4] that are used for applications with high level of information security.
+
+Access to each queue is controlled with unique (not shared with other queues) asymmetric key pairs, separate for the sender and the recipient. The sender and the receiver have private keys, and the server has associated public keys to authenticate participants' commands by verifying cryptographic signatures.
+
+The messages sent over the queue are encrypted and decrypted using another key pair that was shared via out-of-band message - the recipient has the private key and the sender has the associated public key.
+
+**Simplex queue diagram:**
+
+![Simplex queue](./diagrams/simplex-messaging/simplex.svg)
+
+Queue is defined by recipient ID `RID` and sender ID `SID`, unique for the server. Sender key (`SK`) is used by the server to verify sender's commands (identified by `SID`) to send messages. Recipient key (`RK`) is used by the server to verify recipient's commands (identified by `RID`) to retrieve messages.
+
+The protocol uses different IDs for sender and recipient in order to provide an additional privacy by preventing the correlation of senders and recipients commands sent over the network - in case the encrypted transport is compromised, it would still be difficult to correlate senders and recipients without access to the queue records on the server.
+
+## SMP procedure
+
+The SMP procedure of creating a simplex queue on SMP server is explained using participants Alice (the recipient) who wants to receive messages from Bob (the sender).
+
+To create and start using a simplex queue Alice and Bob follow these steps:
+
+1. Alice creates a simplex queue on the server:
+
+    1. Decides which SMP server to use (can be the same or different server that Alice uses for other queues) and opens secure encrypted transport connection to the chosen SMP server (see [Appendix A](#appendix-a)).
+
+    2. Generates a new random public/private key pair (encryption key - `EK`) that she did not use before for Bob to encrypt the messages.
+
+    3. Generates another new random public/private key pair (recipient key - `RK`) that she did not use before for her to sign commands and to decrypt the transmissions received from the server.
+
+    4. Sends `"NEW"` command to the server to create a simplex queue (see `create` in [Create queue command](#create-queue-command)). This command contains previously generated unique "public" key `RK` that will be used to verify the following commands related to the same queue signed by its private counterpart, for example to subscribe to the messages received to this queue or to update the queue, e.g. by setting the key required to send the messages (initially Alice creates the queue that accepts unsigned messages, so anybody could send the message via this queue if they knew the queue sender's ID and server address).
+
+    5. The server sends `"IDS"` response with queue IDs (`queueIds`):
+
+        - Recipient ID `RID` for Alice to manage the queue and to receive the messages.
+
+        - Sender ID `SID` for Bob to send messages to the queue.
+
+2. Alice sends an out-of-band message to Bob via the alternative channel that both Alice and Bob trust (see [protocol abstract](#simplex-messaging-protocol-abstract)). The message must include:
+
+    - Unique "public" key (`EK`) that Bob must use to encrypt messages.
+
+    - SMP server hostname and information to open secure encrypted transport connection (see [Appendix A](#appendix-a)).
+
+    - Sender queue ID `SID` for Bob to use.
+
+3. Bob, having received the out-of-band message from Alice, connects to the queue:
+
+    1. Generates a new random public/private key pair (sender key - `SK`) that he did not use before for him to sign messages sent to Alice's server.
+
+    2. Prepares the confirmation message for Alice to secure the queue. This message includes:
+
+        - Previously generated "public" key `SK` that will be used by Alice's server to authenticate Bob's messages, once the queue is secured.
+
+        - Optionally, any additional information (application specific, e.g. Bob's profile name and details).
+
+    3. Encrypts the confirmation body with the "public" key `EK` (that Alice provided via the out-of-band message).
+
+    4. Sends the encrypted message to the server with queue ID `SID` (see `send` in [Send message](#send-message)). This initial message to the queue must not be signed - signed messages will be rejected until Alice secures the queue (below).
+
+4. Alice receives Bob's message from the server using recipient queue ID `RID` (possibly, via the same transport connection she already has opened - see `message` in [Deliver queue message](#deliver-queue-message)):
+
+    1. She decrypts received message with "private" key `EK`.
+
+    2. Even though anybody could have sent the message to the queue with ID `SID` before it is secured (e.g. if communication is compromised), Alice would ignore all messages until the decryption succeeds (i.e. the result contains the expected message format). Optionally, in the client application, she also may identify Bob using the information provided, but it is out of scope of SMP protocol.
+
+5. Alice secures the queue `RID` with `"KEY"` command so only Bob can send messages to it (see [Secure queue command](#secure-queue-command)):
+
+    1. She sends the `KEY` command with `RID` signed with "private" key `RK` to update the queue to only accept requests signed by "private" key `SK` provided by Bob. This command contains unique "public" key `SK` previously generated by Bob.
+
+    2. From this moment the server will accept only signed commands to `SID`, so only Bob will be able to send messages to the queue `SID` (corresponding to `RID` that Alice has).
+
+    3. Once queue is secured, Alice deletes `SID` and `SK` - even if Alice's client is compromised in the future, the attacker would not be able to send messages pretending to be Bob.
+
+6. The simplex queue `RID` is now ready to be used.
+
+This flow is shown on the sequence diagram below.
+
+**Creating simplex queue from Bob to Alice:**
+
+![Creating queue](./diagrams/simplex-messaging/simplex-creating.svg)
+
+Bob now can securely send messages to Alice:
+
+1. Bob sends the message:
+
+    1. He encrypts the message to Alice with "public" key `EK` (provided by Alice, only known to Bob, used only for one simplex queue).
+
+    2. He signs `"SEND"` command to the server queue `SID` using the "private" key `SK` (that only he knows, used only for this queue).
+
+    3. He sends the command to the server (see `send` in [Send message](#send-message)), that the server will authenticate using the "public" key `SK` (that Alice earlier provided to the server).
+
+2. Alice receives the message(s):
+
+    1. She signs `"SUB"` command to the server to subscribe to the queue `RID` with the "private" key `RK` (see `subscribe` in [Subscribe to queue](#subscribe-to-queue)).
+
+    2. The server, having authenticated Alice's command with the "public" key `RK` that she provided, delivers Bob's message(s) (see `message` in [Deliver queue message](#deliver-queue-message)).
+
+    3. She decrypts Bob's message(s) with the "private" key `EK` (that only she has).
+
+    4. She acknowledges the message reception to the server with `"ACK"` so that the server can delete the message and deliver the next messages.
+
+This flow is show on sequence diagram below.
+
+**Sending messages from Bob to Alice via simplex queue:**
+
+![Using queue](./diagrams/simplex-messaging/simplex-using.svg)
+
+**Simplex queue operation:**
+
+![Simplex queue operations](./diagrams/simplex-messaging/simplex-op.svg)
+
+Sequence diagram does not show E2E encryption - server knows nothing about encryption between the sender and the receiver.
+
+A higher level protocol application protocol should define the semantics that allow to use two simplex queues (or two sets of queues for redundancy) for the bi-directional or any other communication scenarios.
+
+The SMP is intentionally unidirectional - it provides no answer to how Bob will know that the transmission succeeded, and whether Alice received any messages. There may be a scenario when Alice wants to securely receive the messages from Bob, but she does not want Bob to have any proof that she received any messages - this low-level protocol can be used in this scenario, as all Bob knows as a fact is that he was able to send one unsigned message to the server that Alice provided, and now he can only send messages signed with the key `SK` that he sent to the server - it does not prove that any message was received by Alice.
+
+For practical purposes of bi-directional conversation, now that Bob can securely send encrypted messages to Alice, Bob can create the second simplex queue that will allow Alice to send messages to Bob in the same way, sending the second queue details via the first queue. If both Alice and Bob have their respective unique "public" keys (Alice's and Bob's `EK`s of two separate queues), or pass additional keys to sign the messages, the conversation can be both encrypted and signed.
+
+The established queues can also be used to change the encryption keys providing [forward secrecy][5], or to negotiate using other SMP queue(s).
+
+This protocol also can be used for off-the-record messaging, as Alice and Bob can use multiple queues between them and only information they pass to each other allows proving their identity, so if they want to share anything off-the-record they can initiate a new queue without linking it to any other information they exchanged. As a result, this protocol provides better anonymity and better protection from [MITM][1] than [OTR][6] protocol.
+
+## SMP qualities and features
+
+Simplex Messaging Protocol:
+
+- Defines only message-passing protocol:
+
+  - Transport agnostic - the protocol does not define how clients connect to the servers. It can be implemented over any ordered data stream channel: TCP connection, HTTP with long polling, websockets, etc.
+
+  - Not semantic - the protocol does not assign any meaning to queues and messages. While on the application level the queues and messages can have different meaning (e.g., for messages: text or image chat message, message acknowledgement, participant profile information, status updates, changing "public" key to encrypt messages, changing servers, etc.), on SMP protocol level all the messages are binary and their meaning can only be interpreted by client applications and not by the servers - this interpretation is out of scope of this protocol.
+
+- Client-server architecture:
+
+  - Multiple servers, that can be deployed by the system users, can be used to send and retrieve messages.
+
+  - Servers do not communicate with each other and do not "know" about other servers.
+
+  - Clients only communicate with servers (excluding the initial out-of-band message), so the message passing is asynchronous.
+
+  - For each queue, the message recipient defines the server through which the sender should send messages.
+
+  - While multiple servers and multiple queues can be used to pass each message, it is in scope of application level protocol(s), and out of scope of this protocol.
+
+  - Servers store messages only until they are retrieved by the recipients, and in any case, for a limited time.
+
+  - Servers are required to NOT store any message history or delivery log, but even if the server is compromised, it does not allow to decrypt the messages or to determine the list of queues established by any participant - this information is only stored on client devices.
+
+- The only element provided by SMP servers is simplex queues:
+
+  - Each queue is created and managed by the queue recipient.
+
+  - Asymmetric encryption is used to sign and verify the requests to send and receive the messages.
+
+  - One unique "public" key is used by the servers to authenticate requests to send the messages into the queue, and another unique "public" key - to retrieve the messages from the queue. "Unique" here means that each "public" key is used only for one queue and is not used for any other context - effectively, this key is not public and does not represent any participant identity.
+
+  - Both recipient and sender "public" keys are provided to the server by the queue recipient. "Public" key `RK` is provided when the queue is created, public key `SK` is proviced when the queue is secured.
+
+  - The "public" keys known to the server and used to authenticate commands from the participants are unrelated to the keys used to encrypt and decrypt the messages - the latter keys are also unique per each queue but they are only known to participants, not to the servers.
+
+  - Messaging graph can be asymmetric: Bob's ability to send messages to Alice does not automatically lead to the Alice's ability to send messages to Bob.
+
+## Cryptographic algorithms
+
+Simplex messaging clients need to cryptographically sign commands for the following operations:
+
+- With the recipient's key `RK` (server to verify):
+  - create the queue (`NEW`)
+  - subscribe to queue (`SUB`)
+  - secure the queue (`KEY`)
+  - acknowledge received messages (`ACK`)
+  - suspend the queue (`OFF`)
+  - delete the queue (`DEL`)
+- With the sender's key `SK` (server to verify):
+  - send messages (`SEND`)
+
+To sign and verify commands, clients and servers MUST use RSA-PSS algorithm defined in [RFC3447][2].
+
+To optionally sign and verify messages, clients SHOULD use RSA-PSS algorithm.
+
+To encrypt and decrypt messages, clients and servers SHOULD use RSA-OAEP algorithm defined in [RFC3447][2].
+
+The reasons to use these algorithms:
+
+- They are supported by WebCrypto API.
+- They are more widely supported than ECC algorithms.
+- They are newer versions than RSA-PKCS1-v1_5 encryption and signature schemes.
+
+Future versions of the protocol may allow different cryptographic algorithms.
+
+## Simplex queue IDs
+
+Simplex messaging servers MUST generate 2 different IDs for each new queue - for the recipient (that created the queue) and for the sender. It is REQUIRED that:
+
+- These IDs are different and unique within the server.
+- Based on random bytes generated with cryptographically strong pseudo-random number generator.
+
+## Server security requirements
+
+Simplex messaging server implementations MUST NOT create, store or send to any other servers:
+
+- Logs of the client commands and transport connections in the production environment.
+
+- History of deleted queues, retrieved or acknowledged messages (deleted queues MAY be stored temporarily as part of the queue persistence implementation).
+
+- Snapshots of the database they use to store queues and messages (instead simplex messaging clients must manage redundancy by using more than one simplex messaging server). In-memory persistence is recommended.
+
+- Any other information that may compromise privacy or [forward secrecy][4] of communication between clients using simplex messaging servers.
+
+## SMP commands
+
+Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
+
+Each transmission between the client and the server must have this format/syntax (after the decryption):
+
+```abnf
+transmission = [signature] SP signed SP pad ; pad to the fixed block size
+signed = [corrId] SP [queueId] SP cmd
+cmd = ping / recipientCmd / send / serverMsg
+recipientCmd = create / subscribe / secure / acknowledge / suspend / delete
+serverMsg = pong / queueIds / message / unsubscribed / ok / error
+corrId = 1*(%x21-7F) ; any characters other than control/whitespace
+queueId = encoded ; empty queue ID is used with "create" command
+signature = encoded
+; empty signature can be used with "create", "send" and "ping" commands and server messages
+encoded = <base64 encoded binary>
+```
+
+`base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
+
+The syntax of specific commands and responses is defined below.
+
+### Correlating responses with commands
+
+The server should send `queueIds`, `error` and `ok` responses in the same order within each queue ID as the commands received in the transport connection, so that they can be correlated by the clients. To simplify correlation of commands and responses, the server should use the same `corrId` in the response as in the command sent by the client.
+
+If the transport connection is closed before some responses are sent, these responses should be discarded.
+
+### Command authentication
+
+SMP servers must authenticate all transmissions (excluding `ping` and `send` commands) by verifying the provided signatures. Command signature should be generated by applying RSA-PSS algorithm to the `signed` block of the transmission using the key associated with the queue ID (sender's or recipient's, depending on which queue ID is used).
+
+### Keep-alive command
+
+To keep the transport connection alive and to generate noise traffic the clients should use `ping` command to which the server responds with `pong` response. This command should be sent unsigned and without queue ID.
+
+```abnf
+ping = %s"PING"
+pong = %s"PONG"
+```
+
+### Recipient commands
+
+Sending any of the commands in this section (other than `create`, that is sent without queue ID) is only allowed with recipient's ID (`RID`). If sender's ID is used the server must respond with `"ERR AUTH"` response (see [Error responses](#error-responses)).
+
+#### Create queue command
+
+This command is sent by the recipient to the SMP server to create a new queue. The syntax is:
+
+```abnf
+create = %s"NEW" SP recipientKey
+recipientKey = %s"rsa:" x509encoded ;  the recipient's RSA public key for this queue
+x509encoded = <base64 X509 key encoding>
+```
+
+If the queue is created successfully, the server must send `queueIds` response with the recipient's and sender's queue IDs:
+
+```abnf
+queueIds = %s"IDS" SP recipientId SP senderId
+recipientId = encoded
+senderId = encoded
+```
+
+This response should be sent with empty queue ID (the second part of the transmission).
+
+Once the queue is created, the recipient gets automatically subscribed to receive the messages from that queue, until the transport connection is closed. The `subscribe` command is needed only to start receiving the messages from the existing queue when the new transport connection is opened.
+
+NEW `transmission` must be signed using the `recipientKey` that was passed in the transmission.
+
+#### Subscribe to queue
+
+When the simplex queue was not created in the current transport connection, the recipient must use this command to start receiving messages from it:
+
+```abnf
+subscribe = %s"SUB"
+```
+
+If subscription is successful the server must respond with the first available message or with `ok` response if no messages are available. The recipient will continue receiving the messages from this queue until the transport connection is closed or until another transport connection subscribes to the same simplex queue - in this case the first subscription should be cancelled and [subscription END notification](#subscription-end-notification) delivered.
+
+The first message will be delivered either immediately or as soon as it is available; to receive the following message the recipient must acknowledge the reception of the message (see [Acknowledge message delivery](#acknowledge-message-delivery)).
+
+#### Secure queue command
+
+This command is sent by the recipient to the server to add sender's key to the queue:
+
+```abnf
+secure = %s"KEY" SP senderKey
+senderKey = %s"rsa:" x509encoded ; the sender's RSA public key for this queue
+```
+
+`senderKey` is received from the sender as part of the first message - see [Send Message Command](#send-message-command).
+
+Once the queue is secured only signed messages can be sent to it.
+
+#### Acknowledge message delivery
+
+The recipient should send the acknowledgement of message delivery once the message was stored in the client, to notify the server that the message should be deleted:
+
+```abnf
+acknowledge = %s"ACK"
+```
+
+Even if acknowledgement is not sent by the recipient, the server should limit the time of message storage, whether it was delivered to the recipient or not.
+
+Having received the acknowledgement, SMP server should immediately delete the message and then send the next available message or respond with `ok` if there are no more messages available in this simplex queue.
+
+#### Suspend queue
+
+The recipient can suspend a queue prior to deleting it to make sure that no messages are lost:
+
+```abnf
+suspend = %s"OFF"
+```
+
+The server must respond with `"ERR AUTH"` to any messages sent after the queue was suspended (see [Error responses](#error-responses)).
+
+The server must respond `ok` to this command if it was successful.
+
+This command can be sent multiple times (in case transport connection was interrupted and the response was not delivered), the server should still respond `ok` even if the queue is already suspended.
+
+There is no command to resume the queue. Servers must delete suspended queues that were not deleted after some period of time.
+
+#### Delete queue
+
+The recipient can delete the queue, whether it was suspended or not.
+
+All undelivered messages must be deleted as soon as this command is received, before the response is sent.
+
+```abnf
+delete = %s"DEL"
+```
+
+### Sender commands
+
+Currently SMP defines only one command that can be used by senders - `send` message. This command must be used with sender's ID, if recipient's ID is used the server must respond with `"ERR AUTH"` response (see [Error responses](#error-responses)).
+
+#### Send message
+
+This command is sent to the server by the sender both to confirm the queue after the sender received out-of-band message from the recipient and to send messages after the queue is secured:
+
+```abnf
+send = %s"SEND" SP size SP msgBody SP
+; the last SP is in addition to SP in the transmission
+size = 1*DIGIT ; size in bytes
+msgBody = *OCTET ; any binary content of specified size
+```
+
+The first message is sent to confirm the queue - it should contain sender's server key (see decrypted message syntax below) - this first message must be sent without signature.
+
+Once the queue is secured (see [Secure queue command](#secure-queue-command)), the following send commands must be sent with the signature.
+
+The server must respond with `"ERR AUTH"` response in the following cases:
+
+- the queue does not exist or is suspended
+- the queue is secured but the transmission does NOT have a signature
+- the queue is NOT secured but the transmission has a signature
+
+Until the queue is secured, the server should accept any number of unsigned messages - it both enables the legitimate sender to resend the confirmation in case of failure and also allows the simplex messaging client to ignore any confirmation messages that may be sent by the attackers (assuming they could have intercepted the queue ID in the server response, but do not have a correct encryption key passed to sender in out-of-band message).
+
+The body should be encrypted with the recipient's "public" key (`EK`); once decrypted it must have this format:
+
+```abnf
+decryptedBody = [clientHeader] CRLF clientBody CRLF
+clientHeader = senderKeyMsg
+senderKeyMsg = %s"KEY" SP senderKey
+senderKey = %s"rsa:" x509encoded ; the sender's RSA public key for this queue
+clientBody = *OCTET
+```
+
+`clientHeader` in the initial unsigned message is used to transmit sender's server key and can be used in the future revisions of SMP protocol for other purposes.
+
+### Server messages
+
+#### Queue IDs response
+
+Server must respond with this message when the new queue is created.
+
+See its syntax in [Create queue command](#create-queue-command)
+
+#### Deliver queue message
+
+The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is:
+
+```abnf
+message = %s"MSG" SP msgId SP timestamp SP size SP msgBody SP
+msgId = encoded
+timestamp = <date-time defined in RFC3339>
+```
+
+`msgId` - unique message ID generated by the server based on cryptographically strong random bytes. It should be used by the clients to detect messages that were delivered more than once (in case the transport connection was interrupted and the server did not receive the message delivery acknowledgement).
+
+`timestamp` - the UTC time when the server received the message from the sender, must be in date-time format defined by [RFC 3339][10]
+
+`binaryMsg` - see syntax in [Send message](#send-message)
+
+#### Subscription END notification
+
+When another transport connection is subscribed to the same simplex queue, the server should unsubscribe and to send the notification to the previously subscribed transport connection:
+
+```abnf
+unsubscribed = %s"END"
+```
+
+No further messages should be delivered to unsubscribed transport connection.
+
+#### Error responses
+
+- incorrect block format, encoding or signature size (`BLOCK`).
+- command errors (`CMD`):
+  - error parsing command (`SYNTAX`)
+  - prohibited command (`PROHIBITED`) - any server response sent from client or `ACK` sent without active subscription or without message delivery.
+  - incorrect RSA key size in `NEW` or `KEY` commands - only 1024, 2048 and 4096-bit keys are allowed (`KEY_SIZE`).
+  - transmission has no required signature or queue ID (`NO_AUTH`)
+  - transmission has unexpected credentials (`HAS_AUTH`)
+  - transmission has no required queue ID (`NO_QUEUE`)
+- authentication error (`AUTH`) - incorrect signature, unknown (or suspended) queue, sender's ID is used in place of recipient's and vice versa, and some other cases (see [Send message command](#send-message-command)).
+- incorrect message body size (`SIZE`).
+- internal server error (`INTERNAL`).
+
+The syntax for error responses:
+
+```abnf
+error = %s"ERR" SP errorType
+errorType = %s"BLOCK" / %s"CMD" SP cmdError / %s"AUTH" / %s"SIZE" /%s"INTERNAL"
+cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"KEY_SIZE" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
+```
+
+Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size).
+
+### OK response
+
+When the command is successfully executed by the server, it should respond with OK response:
+
+```abnf
+ok = %s"OK"
+```
+
+## Appendices
+
+### Appendix A.
+
+**SMP transport protocol.**
+
+Both the recipient and the sender can use TCP or some other, possibly higher level, transport protocol to communicate with the server. The default TCP port for SMP server is 5223.
+
+By default, the client and server should use the protocol presented below, that does not depend on a centralized certificate authority.
+
+Transport is encrypted with [AEAD-GCM][12] protocol with two random symmetric AES 256-bit keys and two random base IVs that will be agreed during the handshake. Both client and the server should maintain two 32-bit word counters, one for the sent and one for the received messages. The IV for each message should be computed by xor-ing the sequential message counter, starting from 0, with the first 32 bits of agreed base IV (the number is encoded in network byte order).
+
+To establish the session keys and base IVs, the server should have an asymmetric key pair generated during server deployment and unknown to the clients. The users should know the key hash (256 bits) in advance in order to be able to validate the server public key during transport connection handshake.
+
+The handshake sequence is the following:
+
+1. Once the connection is established, the server sends the `server_header` followed by its public RSA key encoded in X509 binary (not base-64 encoded) format to the client.
+2. The client compares the SHA256 hash of the received key with the hash it already has (e.g. received as part of connection invitation or as SMP server configuration). If the hash does not match, the client must terminate the connection.
+3. If the hash is the same, the client should generate two random symmetric 256-bit AES keys and two base IVs that will be used as session keys/IVs by the client and the server.
+4. The client then should create the `client_handshake` block and send it to the server, encrypted using [RSA-OAEP][2] scheme with the server public key: `rsa-encrypt(client_handshake)`. `snd_aes_key` and `snd_base_iv` will be used by the client to encrypt **sent** messages and by the server to decrypt them, `rcv_aes_key` and `rcv_base_iv` will be used by the client to decrypt **received** messages and by the server to encrypt them. `client_handshake` also contains `block_size` and reserved `protocol` blocks (see syntax).
+5. The server should decrypt the received AES keys and base IVs with its private RSA key.
+6. In case of successful decryption, the server should send encrypted welcome block (`encrypted_welcome_block`) that contains SMP protocol version supported by the server.
+
+All the subsequent data, both from the client and from the server, should be sent padded to the fixed agreed block size, encrypted with symmetric AES keys and base IVs (incremented by counters on both sides), that were sent by the client during the handshake. If the application needs to transmit a larger message, it should be broken down into fragments.
+
+Handshake blocks sent by the client and the server have this syntax:
+
+```abnf
+server_header = block_size protocol key_size
+block_size = 4*4(OCTET) ; 4-byte block size sent by the server
+protocol = 2*2(%x00) ; 0, reserved
+key_size = 2*2(OCTET) ; the size of the encoded key in bytes (binary encoded in X509 standard)
+
+client_handshake = client_block_size protocol snd_aes_key snd_base_iv rcv_aes_key rcv_base_iv
+client_block_size = 4*4(OCTET) ; 4-byte block size sent by the client,
+; to confirm or override the block size sent by the server
+client_protocol = 2*2(%x00) ; 0, reserved
+snd_aes_key = 32*32(OCTET)
+snd_base_iv = 16*16(OCTET)
+rcv_aes_key = 32*32(OCTET)
+rcv_base_iv = 16*16(OCTET)
+
+transport_block = aes_body_auth_tag aes_encrypted_body
+; size is sent by server during handshake, usually 4096 bytes
+aes_body_auth_tag = 16*16(OCTET)
+aes_encrypted_body = 1*OCTET
+
+encrypted_welcome_block = transport_block
+welcome_block = smp_version SP pad ; decrypt(encrypted_welcome_block)
+smp_version = %s"v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ["-" 1*ALPHA "." 1*DIGIT] ; in semver format
+  ; for example: v123.456.789-alpha.7
+pad = 1*OCTET
+```
+
+[1]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack
+[2]: https://en.wikipedia.org/wiki/End-to-end_encryption
+[3]: https://en.wikipedia.org/wiki/QR_code
+[4]: https://en.wikipedia.org/wiki/Unidirectional_network
+[5]: https://en.wikipedia.org/wiki/Forward_secrecy
+[6]: https://en.wikipedia.org/wiki/Off-the-Record_Messaging
+[8]: https://tools.ietf.org/html/rfc5234
+[8a]: https://tools.ietf.org/html/rfc7405
+[9]: https://tools.ietf.org/html/rfc4648#section-4
+[10]: https://tools.ietf.org/html/rfc3339
+[11]: https://tools.ietf.org/html/rfc5280
+[12]: https://tools.ietf.org/html/rfc7714

rfcs/2021-01-26-crypto.md

@@ -16,49 +16,60 @@ For initial implementation I propose approach to be as simple as possible as lon
 
 One of the consideration is to use [noise protocol framework](https://noiseprotocol.org/noise.html), this section describes ad hoc protocol though.
 
-During TCP session both client and server should use symmetric AES 256 bit encryption using the session key that will be established during the handshake.
+During TCP session both client and server should use symmetric AES 256 bit encryption using two session keys and two base IVs that will be agreed during the handshake. Both client and the server should maintain two 32-bit word counters, one for sent and one for the received messages. The IV for each message should be computed by xor-ing the sequential message counter, starting from 0, with the first 32 bits of agreed base IV. TODO - explain it in a more formal way, also document how 32-bit word is encoded - with the most or least significant byte first (currently encodeWord32 from Network.Transport.Internal is used)
 
-To establish the session key, the server should have an asymmetric key pair generated during server deployment and unknown to the clients. The users should know the key hash (256 bits) and additional server ID (256 bits) in advance in order to be able to establish connection.
+To establish the session keys and base IVs, the server should have an asymmetric key pair generated during server deployment and unknown to the clients. The users should know the key hash (256 bits) in advance in order to be able to establish connection.
 
-The handshake sequence could be the following:
+The handshake sequence is the following:
 
-1. Once the connection is established, the server sends its public key to the client
-2. The client compares the hash of the received key with the hash it already has (e.g. received as part of connection invitation or server in NEW command). If the hash does not match, the client must terminate the connection.
-3. If the hash is the same, the client should generate a random symmetric AES key and IV that will be used as a session key both by the client and the server.
-4. The client then should encrypt this symmetric key with the public key that the server sent and send back to the server the result and the server ID also shared with the client in advance: `rsa-encrypt(aes-key, iv, server-id)`.
-5. The server should decrypt the received key, IV and server id with its private key.
-6. The server should compare the `server-id` sent by the client and if it does not match its ID terminate the connection.
-7. In case of successful decryption and matching server ID, the server should send encrypted welcome header.
+1. Once the connection is established, the server sends server_header and its public RSA key encoded in X509 binary format to the client.
+2. The client compares the hash of the received key with the hash it already has (e.g. received as part of connection invitation or server in NEW command). If the hash does not match, the client must terminate the connection. TODO as the hash is optional in server syntax at the moment, hash comparison will be optional as well. Probably it should become required.
+3. If the hash is the same, the client should generate random symmetric AES keys and base IVs that will be used as session keys/IVs by the client and the server.
+4. The client then should construct client_handshake block and send it to the server encrypted with the server public key: `rsa-encrypt(client_handshake)`. `snd_aes_key` and `snd_base_iv` will be used by the client to encrypt **sent** messages and by the server to decrypt them, `rcv_aes_key` and `rcv_base_iv` will be used by the client to decrypt **received** messages and by the server to encrypt them.
+5. The server should decrypt the received keys and base IVs with its private key.
+6. In case of successful decryption, the server should send encrypted welcome block (encrypted_welcome_block) that contains SMP protocol version.
 
-```abnf
-aes_welcome_header = aes_header_auth_tag aes_encrypted_header
-welcome_header = smp_version ["," smp_mode] *SP ; decrypt(aes_encrypted_header) - 32 bytes
-smp_version = %s"v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ["-" 1*ALPHA "." 1*DIGIT] ; in semver format
-  ; for example: v123.456.789-alpha.7
-smp_mode = smp_public / smp_authenticated
-smp_public = %s"pub" ; public (default) - no auth to create and manage queues
-smp_authenticated = %s"auth" ; server authentication with AUTH command (TBD) is required to create and manage queues
-aes_header_auth_tag = aes_auth_tag
-aes_auth_tag = 16*16(OCTET)
-```
-
-No payload should follow this header, it is only used to confirm successful handshake and send the SMP protocol version that the server supports.
-
-All the subsequent data both from the client and from the server should be sent encrypted using symmetric AES key and IV sent by the client during the handshake.
+All the subsequent data both from the client and from the server should be sent encrypted using symmetric AES keys and base IVs (incremented by counters on both sides) sent by the client during the handshake.
 
 Each transport block sent by the client and the server has this syntax:
 
 ```abnf
-transport_block = aes_header_auth_tag aes_encrypted_header aes_body_auth_tag aes_encrypted_body
-aes_encrypted_header = 32*32(OCTET)
-header = padded_body_size payload_size reserved ; decrypt(aes_encrypted_header) - 32 bytes
+server_header = block_size protocol key_size
+block_size = 4*4(OCTET) ; 4-byte block size sent by the server, currently the client rejects if > 65536 bytes
+protocol = 2*2(OCTET) ; currently it is 0, that means binary RSA key
+key_size = 2*2(OCTET) ; the encoded key size in bytes (binary encoded in X509 standard)
+
+client_handshake = client_block_size client_protocol snd_aes_key snd_base_iv rcv_aes_key rcv_base_iv
+client_block_size = 4*4(OCTET) ; 4-byte block size sent by the client, currently it is ignored by the server - reserved
+client_protocol = 2*2(OCTET) ; currently it is 0 - reserved
+snd_aes_key = 32*32(OCTET)
+snd_base_iv = 16*16(OCTET)
+rcv_aes_key = 32*32(OCTET)
+rcv_base_iv = 16*16(OCTET)
+
+transport_block = aes_body_auth_tag aes_encrypted_body
+; size is sent by server during handshake, usually 8192 bytes
 aes_encrypted_body = 1*OCTET
-body = payload pad
-padded_body_size = size ; body size in bytes
-payload_size = size ; payload_size in bytes
-size = 4*4(OCTET)
-reserved = 24*24(OCTET)
-aes_body_auth_tag = aes_auth_tag
+aes_body_auth_tag = 16*16(OCTET)
+
+encrypted_welcome_block = transport_block
+welcome_block = smp_version SP pad ; decrypt(encrypted_welcome_block)
+smp_version = %s"v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ["-" 1*ALPHA "." 1*DIGIT] ; in semver format
+  ; for example: v123.456.789-alpha.7
+pad = 1*OCTET
+```
+
+## Possible future improvements/changes
+
+- server id (256 bits), so that only the users that have it can connect to the server. This ID will have to be passed to the server during the handshake
+- block size agreed during handshake
+- transport encryption protocol agreed during handshake
+- welcome block containing SMP mode (smp_mode)
+
+```abnf
+smp_mode = smp_public / smp_authenticated
+smp_public = %s"pub" ; public (default) - no auth to create and manage queues
+smp_authenticated = %s"auth" ; server authentication with AUTH command (TBD) is required to create and manage queues
 ```
 
 ## Initial handshake
@@ -105,7 +116,9 @@ Symmetric keys are generated per message and encrypted with receiver's public ke
 The syntax of each encrypted message body is the following:
 
 ```abnf
-encrypted_message_body = rsa_encrypted_header aes_encrypted_body
+encrypted_message_body = rsa_signature encrypted_body
+encrypted_body = rsa_encrypted_header aes_encrypted_body
+rsa_signature = 256*256(OCTET) ; sign(encrypted_body) - assuming 2048 bit key size
 rsa_encrypted_header = 256*256(OCTET) ; encrypt(header) - assuming 2048 bit key size
 aes_encrypted_body = 1*OCTET ; encrypt(body)
 
@@ -120,7 +133,6 @@ body = payload pad
 
 Future considerations:
 - Generation of symmetric keys per session and session rotation;
-- Signature and verification of messages.
 
 ## E2E implementation
 

rfcs/2021-02-28-streams.md

@@ -0,0 +1,48 @@
+# Streams
+
+Managing dedicated SMP queues for fast synchronous communication
+
+## Problem
+
+SMP agent protocol implementation provides the most secure way to distribute keys achieving the following qualities:
+
+- compromising the sender agent/device allows to send messages, but not to read them.
+- compromising the recipient agent/device allows to receive messages, but not to send them (neither public encryption key is stored - TBC if public key can be restored from the private - nor server authentication key is available).
+- compromising the server does not expose any information about messages content, as encrypted section has the same size.
+
+The current hybrid encryption scheme uses a new symmetric key for each message, and because the symmetric key is not persisted at any point, it is difficult to obtain it and send counterfeit messages on behalf of the sender (even in case both the server and recipient are compromised).
+
+There are 2 downsides of the current scheme:
+
+1. RSA encryption/decryption is relatively slow even for 2048 key size and gets much slower for larger key sizes. It is not a problem for the chat messages (and any content updates) that happen infrequently, but it makes the transmission of large files and any other streaming communication slow.
+
+2. If the large file or voice/video calls were to be sent via the same queue as normal messages/content updates, the server and any passive observer would be able to understand when such transmissions happen (even if performance was not a problem).
+
+## Proposed solution
+
+For every fast/dense data transmission use a separate short-lived connection with dedicated SMP queues that the agents would provision to receive such transmissions.
+
+Such connections that can be unidirectional or duplex can be managed by agents via additional set of agent commands using "stream" abstraction.
+
+The protocol to create and manage such stream could be the following:
+
+1. The sender client notifies the agent about the stream it has to create for a specific duplex connection (the connection must be duplex for it to be possible): `<conn_alias> SNEW <size>` (where `conn_alias` is the existing duplex connection, `size` is the size for the data to be transferred; 0 for unbounded streams), the response is `<conn_alias> STREAM <stream_id> <size>`.
+2. The sender agent sends to the recipient agent the "envelope" `STREAM <stream_id> <size>`
+3. The receiving agent would notify the client about availability of the stream by sending `<conn_alias> STREAM <stream_id> <size>` notification.
+4. Receiving client would send `<conn_alias> SJOIN <stream_id>` command to the receiving agent.
+5. Receiving agent provisions the SMP queue on the random SMP server (we planned to remove SMP server from NEW command anyway). Possibly, there will be a limited list of servers that support streams (that is un-throttled number of messages), and stream support can be communicated via welcome header and change with AUTH SMP command.
+6. Receiving agent sends the envelop to sending agent `SJOIN <stream_id> <invitation>` (where invitation has the same format as in out-of-band message, but it has symmetric AES key and IV instead of asymmetric RSA key - the encryption scheme should codified in the invitation to make it generic).
+7. Sending agent and receiving agent confirm and secure SMP queue as usual. This is still not solving the problem that the sending agent should sign each command. We might extend SMP protocol to create a new queue type that allows authenticating the sender only once per TCP session so that messages can be sent without signing - the server can see that these queues are special anyway, as there will be much faster traffic there.
+8. Sending agent, once the queue is confirmed notifies the sending client that the stream is ready to accept data by sending notification `<conn_alias> SREADY <stream_id> <max_chunk_size>`.
+9. Sending agent client can now send packets into the stream up to total `<size>` limit if it was specified by using command `<conn_alias> SPUT <stream_id> <chunk_no> <chunk_size> <binary> ` (the chunk size should not be bigger than `max_chunk_size`, the agent would pad it to this size before sending to the receiving agent)
+10. Sending agent would send the chunk to the receiving agent in `CHUNK <chunk_no> <ts> <chunk_size> <binary>` envelope, where the first 4 bytes in decrypted binary is chunk size.
+11. Receiving agent would send the chunk to the client as `<conn_alias> SDATA <stream_id> <chunk_no> <ts> <status> <chunk_size> <binary>` (possibly, with three IDs and timestamps as with messages).
+12. Both the receiving and sending clients can terminate the stream with `<conn_alias> SCLOSE <stream_id>` command. The agent would send `SCLOSED <stream_id>` envelope and the opposite client would receive `<conn_alias> SCLOSED <stream_id>` notification - no more data will be accepted into this stream.
+13. If the stream was bounded with some `size` then both the sending and receiving client would receive `SCLOSED` notification after the last chunk of correct size was sent (and the incorrect chunk would be rejected).
+14. If the stream was interrupted then the recipient client can request resuming this stream using `<conn_alias> SRESUME <stream_id> <from_chunk_no>`, the recipient agent would send "envelope" `SRESUME <stream_id> <from_chunk_no> <invitation>`.
+
+To be clarified:
+1. Possibly the internal stream ID used by clients should be different from stream ID communicated between agents, and in any case it should be connection scoped (same as with messages).
+2. There seems to be no need to rotate symmetric keys, disconnections can be handled.
+3. Same as we plan for redundant SMP queues with one connection, agents could use multiple queues per stream to increase the bandwidth and/or transmission reliability (e.g. for file transfers, where interruptions are not problematic multiple queues can be used in parallel, while for calls agents can duplicate all transmitted bytes so that losing some queues or TCP disconnects do not result in communication interruption).
+4. Possibly the stream creation could be initiated by the receiving agent, to have it more similar to connection creation procedure.

rfcs/2021-03-18-groups.md

@@ -0,0 +1,25 @@
+# SMP agent groups
+
+## Problems
+
+- device/user profile synchronisation
+- chat group communication
+
+Both problems would require message broadcast between a group of SMP agents.
+
+## Solution: basic symmetric groups via SMP agent protocol
+
+Additional commands and message envelopes to SMP agent protocol to provide an abstraction layer for device synchronisation and chat groups.
+
+The groups are fully symmetric, all agent who are members of the group have equal rights and can join and leave group at any time.
+
+All the information about the groups is stored only in agents, the commands are used to synchronise the group state between the agents.
+
+```abnf
+group_command = create_group / add_to_group / remove_from_group / leave_group
+group_response = group_created / added_to_group / removed_from_group
+group_notification = added_to_group_by / removed_from_group_by / left_group
+create_group = %s"GNEW " group_name ; cAlias must be empty
+add_to_group = %s"GADD " group_name ; cAlias is the connection to add to the group
+added_to_group = %s"GADDED " name ; cAlias is the connection added to the group
+```

src/Simplex/Messaging/Agent.hs

@@ -8,13 +8,27 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+-- |
+-- Module      : Simplex.Messaging.Agent
+-- Copyright   : (c) simplex.chat
+-- License     : AGPL-3
+--
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : non-portable
+--
+-- This module defines SMP protocol agent with SQLite persistence.
+--
+-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
 module Simplex.Messaging.Agent
   ( runSMPAgent,
+    runSMPAgentBlocking,
     getSMPAgentClient,
     runSMPAgentClient,
   )
 where
 
+import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logInfo, showText)
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
@@ -22,44 +36,59 @@ import Control.Monad.Reader
 import Crypto.Random (MonadRandom)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as L
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8)
 import Data.Time.Clock
+import Database.SQLite.Simple (SQLError)
 import Simplex.Messaging.Agent.Client
 import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, connectSQLiteStore)
-import Simplex.Messaging.Agent.Transmission
 import Simplex.Messaging.Client (SMPServerTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (CorrId (..), MsgBody, SenderPublicKey)
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Transport (putLn, runTCPServer)
-import Simplex.Messaging.Util (liftError)
-import System.IO (Handle)
+import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), runTransportServer)
+import Simplex.Messaging.Util (bshow)
+import System.Random (randomR)
 import UnliftIO.Async (race_)
-import UnliftIO.Exception (SomeException)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
-runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m ()
-runSMPAgent cfg@AgentConfig {tcpPort} = runReaderT smpAgent =<< newSMPAgentEnv cfg
+-- | Runs an SMP agent as a TCP service using passed configuration.
+--
+-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
+runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> m ()
+runSMPAgent t cfg = do
+  started <- newEmptyTMVarIO
+  runSMPAgentBlocking t started cfg
+
+-- | Runs an SMP agent as a TCP service using passed configuration with signalling.
+--
+-- 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
   where
-    smpAgent :: (MonadUnliftIO m', MonadReader Env m') => m' ()
-    smpAgent = runTCPServer tcpPort $ \h -> do
-      liftIO $ putLn h "Welcome to SMP v0.2.0 agent"
+    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 v0.3.2 agent"
       c <- getSMPAgentClient
       logConnection c True
       race_ (connectClient h c) (runSMPAgentClient c)
         `E.finally` (closeSMPServerClients c >> logConnection c False)
 
+-- | Creates an SMP agent instance that receives commands and sends responses via 'TBQueue's.
 getSMPAgentClient :: (MonadUnliftIO m, MonadReader Env m) => m AgentClient
 getSMPAgentClient = do
   n <- asks clientCounter
   cfg <- asks config
   atomically $ newAgentClient n cfg
 
-connectClient :: MonadUnliftIO m => Handle -> AgentClient -> m ()
+connectClient :: Transport c => MonadUnliftIO m => c -> AgentClient -> m ()
 connectClient h c = race_ (send h c) (receive h c)
 
 logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m ()
@@ -67,6 +96,7 @@ logConnection c connected =
   let event = if connected then "connected to" else "disconnected from"
    in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"]
 
+-- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
 runSMPAgentClient :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
 runSMPAgentClient c = do
   db <- asks $ dbFile . config
@@ -74,7 +104,7 @@ runSMPAgentClient c = do
   s2 <- connectSQLiteStore db
   race_ (subscriber c s1) (client c s2)
 
-receive :: forall m. MonadUnliftIO m => Handle -> AgentClient -> m ()
+receive :: forall c m. (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
 receive h c@AgentClient {rcvQ, sndQ} = forever $ do
   (corrId, cAlias, cmdOrErr) <- tGet SClient h
   case cmdOrErr of
@@ -86,7 +116,7 @@ receive h c@AgentClient {rcvQ, sndQ} = forever $ do
       logClient c "-->" t
       atomically $ writeTBQueue q t
 
-send :: MonadUnliftIO m => Handle -> AgentClient -> m ()
+send :: (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
 send h c@AgentClient {sndQ} = forever $ do
   t <- atomically $ readTBQueue sndQ
   tPut h t
@@ -94,7 +124,7 @@ send h c@AgentClient {sndQ} = forever $ do
 
 logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m ()
 logClient AgentClient {clientId} dir (CorrId corrId, cAlias, cmd) = do
-  logInfo . decodeUtf8 $ B.unwords [B.pack $ show clientId, dir, "A :", corrId, cAlias, B.takeWhile (/= ' ') $ serializeCommand cmd]
+  logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, cAlias, B.takeWhile (/= ' ') $ serializeCommand cmd]
 
 client :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> SQLiteStore -> m ()
 client c@AgentClient {rcvQ, sndQ} st = forever $ do
@@ -110,15 +140,20 @@ withStore ::
 withStore action = do
   runExceptT (action `E.catch` handleInternal) >>= \case
     Right c -> return c
-    Left _ -> throwError STORE
+    Left e -> throwError $ storeError e
   where
-    handleInternal :: (MonadError StoreError m') => SomeException -> m' a
-    handleInternal _ = throwError SEInternal
+    handleInternal :: (MonadError StoreError m') => SQLError -> m' a
+    handleInternal e = throwError . SEInternal $ bshow e
+    storeError :: StoreError -> AgentErrorType
+    storeError = \case
+      SEConnNotFound -> CONN UNKNOWN
+      SEConnDuplicate -> CONN DUPLICATE
+      e -> INTERNAL $ show e
 
 processCommand :: forall m. AgentMonad m => AgentClient -> SQLiteStore -> ATransmission 'Client -> m ()
 processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) =
   case cmd of
-    NEW smpServer -> createNewConnection smpServer
+    NEW -> createNewConnection
     JOIN smpQueueInfo replyMode -> joinConnection smpQueueInfo replyMode
     SUB -> subscribeConnection connAlias
     SUBALL -> subscribeAll
@@ -126,35 +161,41 @@ processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) =
     OFF -> suspendConnection
     DEL -> deleteConnection
   where
-    createNewConnection :: SMPServer -> m ()
-    createNewConnection server = do
+    createNewConnection :: m ()
+    createNewConnection = do
       -- TODO create connection alias if not passed
       -- make connAlias Maybe?
-      (rq, qInfo) <- newReceiveQueue c server connAlias
+      srv <- getSMPServer
+      (rq, qInfo) <- newReceiveQueue c srv connAlias
       withStore $ createRcvConn st rq
       respond $ INV qInfo
 
+    getSMPServer :: m SMPServer
+    getSMPServer =
+      asks (smpServers . config) >>= \case
+        srv :| [] -> pure srv
+        servers -> do
+          gen <- asks randomServer
+          i <- atomically . stateTVar gen $ randomR (0, L.length servers - 1)
+          pure $ servers L.!! i
+
     joinConnection :: SMPQueueInfo -> ReplyMode -> m ()
-    joinConnection qInfo@(SMPQueueInfo srv _ _) replyMode = do
+    joinConnection qInfo (ReplyMode replyMode) = do
       -- TODO create connection alias if not passed
       -- make connAlias Maybe?
       (sq, senderKey, verifyKey) <- newSendQueue qInfo connAlias
       withStore $ createSndConn st sq
       connectToSendQueue c st sq senderKey verifyKey
-      case replyMode of
-        ReplyOn -> sendReplyQInfo srv sq
-        ReplyVia srv' -> sendReplyQInfo srv' sq
-        ReplyOff -> return ()
-      respond CON
+      when (replyMode == On) $ createReplyQueue sq
+    -- TODO this response is disabled to avoid two responses in terminal client (OK + CON),
+    -- respond OK
 
     subscribeConnection :: ConnAlias -> m ()
     subscribeConnection cAlias =
       withStore (getConn st cAlias) >>= \case
         SomeConn _ (DuplexConnection _ rq _) -> subscribe rq
         SomeConn _ (RcvConnection _ rq) -> subscribe rq
-        -- TODO possibly there should be a separate error type trying
-        -- TODO to send the message to the connection without RcvQueue
-        _ -> throwError PROHIBITED
+        _ -> throwError $ CONN SIMPLEX
       where
         subscribe rq = subscribeQueue c rq cAlias >> respond' cAlias OK
 
@@ -167,22 +208,32 @@ processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) =
       withStore (getConn st connAlias) >>= \case
         SomeConn _ (DuplexConnection _ _ sq) -> sendMsg sq
         SomeConn _ (SndConnection _ sq) -> sendMsg sq
-        -- TODO possibly there should be a separate error type trying
-        -- TODO to send the message to the connection without SndQueue
-        _ -> throwError PROHIBITED -- NOT_READY ?
+        _ -> throwError $ CONN SIMPLEX
       where
         sendMsg sq = do
-          senderTs <- liftIO getCurrentTime
-          senderId <- withStore $ createSndMsg st connAlias msgBody senderTs
-          sendAgentMessage c sq senderTs $ A_MSG msgBody
-          respond $ SENT (unId senderId)
+          internalTs <- liftIO getCurrentTime
+          (internalId, internalSndId, previousMsgHash) <- withStore $ updateSndIds st sq
+          let msgStr =
+                serializeSMPMessage
+                  SMPMessage
+                    { senderMsgId = unSndId internalSndId,
+                      senderTimestamp = internalTs,
+                      previousMsgHash,
+                      agentMessage = A_MSG msgBody
+                    }
+              msgHash = C.sha256Hash msgStr
+          withStore $
+            createSndMsg st sq $
+              SndMsgData {internalId, internalSndId, internalTs, msgBody, internalHash = msgHash}
+          sendAgentMessage c sq msgStr
+          respond $ SENT (unId internalId)
 
     suspendConnection :: m ()
     suspendConnection =
       withStore (getConn st connAlias) >>= \case
         SomeConn _ (DuplexConnection _ rq _) -> suspend rq
         SomeConn _ (RcvConnection _ rq) -> suspend rq
-        _ -> throwError PROHIBITED
+        _ -> throwError $ CONN SIMPLEX
       where
         suspend rq = suspendQueue c rq >> respond OK
 
@@ -191,20 +242,27 @@ processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) =
       withStore (getConn st connAlias) >>= \case
         SomeConn _ (DuplexConnection _ rq _) -> delete rq
         SomeConn _ (RcvConnection _ rq) -> delete rq
-        _ -> throwError PROHIBITED
+        _ -> delConn
       where
+        delConn = withStore (deleteConn st connAlias) >> respond OK
         delete rq = do
           deleteQueue c rq
           removeSubscription c connAlias
-          withStore (deleteConn st connAlias)
-          respond OK
+          delConn
 
-    sendReplyQInfo :: SMPServer -> SndQueue -> m ()
-    sendReplyQInfo srv sq = do
+    createReplyQueue :: SndQueue -> m ()
+    createReplyQueue sq = do
+      srv <- getSMPServer
       (rq, qInfo) <- newReceiveQueue c srv connAlias
       withStore $ upgradeSndConnToDuplex st connAlias rq
-      senderTs <- liftIO getCurrentTime
-      sendAgentMessage c sq senderTs $ REPLY qInfo
+      senderTimestamp <- liftIO getCurrentTime
+      sendAgentMessage c sq . serializeSMPMessage $
+        SMPMessage
+          { senderMsgId = 0,
+            senderTimestamp,
+            previousMsgHash = "",
+            agentMessage = REPLY qInfo
+          }
 
     respond :: ACommand 'Agent -> m ()
     respond = respond' connAlias
@@ -222,13 +280,44 @@ subscriber c@AgentClient {msgQ} st = forever $ do
 
 processSMPTransmission :: forall m. AgentMonad m => AgentClient -> SQLiteStore -> SMPServerTransmission -> m ()
 processSMPTransmission c@AgentClient {sndQ} st (srv, rId, cmd) = do
-  rq@RcvQueue {connAlias, decryptKey, status} <- withStore $ getRcvQueue st srv rId
-  case cmd of
-    SMP.MSG srvMsgId srvTs msgBody -> do
-      -- TODO deduplicate with previously received
-      agentMsg <- liftEither . parseSMPMessage =<< decryptMessage decryptKey msgBody
-      case agentMsg of
-        SMPConfirmation senderKey -> do
+  withStore (getRcvConn st srv rId) >>= \case
+    SomeConn SCDuplex (DuplexConnection _ rq _) -> processSMP SCDuplex rq
+    SomeConn SCRcv (RcvConnection _ rq) -> processSMP SCRcv rq
+    _ -> atomically $ writeTBQueue sndQ ("", "", ERR $ CONN SIMPLEX)
+  where
+    processSMP :: SConnType c -> RcvQueue -> m ()
+    processSMP cType rq@RcvQueue {connAlias, status} =
+      case cmd of
+        SMP.MSG srvMsgId srvTs msgBody -> do
+          -- TODO deduplicate with previously received
+          msg <- decryptAndVerify rq msgBody
+          let msgHash = C.sha256Hash msg
+          agentMsg <- liftEither $ parseSMPMessage msg
+          case agentMsg of
+            SMPConfirmation senderKey -> smpConfirmation senderKey
+            SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} ->
+              case agentMessage of
+                HELLO verifyKey _ -> helloMsg verifyKey msgBody
+                REPLY qInfo -> replyMsg qInfo
+                A_MSG body -> agentClientMsg previousMsgHash (senderMsgId, senderTimestamp) (srvMsgId, srvTs) body msgHash
+          sendAck c rq
+          return ()
+        SMP.END -> do
+          removeSubscription c connAlias
+          logServer "<--" c srv rId "END"
+          notify END
+        _ -> do
+          logServer "<--" c srv rId $ "unexpected: " <> bshow cmd
+          notify . ERR $ BROKER UNEXPECTED
+      where
+        notify :: ACommand 'Agent -> m ()
+        notify msg = atomically $ writeTBQueue sndQ ("", connAlias, msg)
+
+        prohibited :: m ()
+        prohibited = notify . ERR $ AGENT A_PROHIBITED
+
+        smpConfirmation :: SenderPublicKey -> m ()
+        smpConfirmation senderKey = do
           logServer "<--" c srv rId "MSG <KEY>"
           case status of
             New -> do
@@ -238,50 +327,70 @@ processSMPTransmission c@AgentClient {sndQ} st (srv, rId, cmd) = do
               -- TODO update sender key in the store?
               secureQueue c rq senderKey
               withStore $ setRcvQueueStatus st rq Secured
-              sendAck c rq
-            s ->
-              -- TODO maybe send notification to the user
-              liftIO . putStrLn $ "unexpected SMP confirmation, queue status " <> show s
-        SMPMessage {agentMessage, senderMsgId, senderTimestamp} ->
-          case agentMessage of
-            HELLO _verifyKey _ -> do
-              logServer "<--" c srv rId "MSG <HELLO>"
-              -- TODO send status update to the user?
-              withStore $ setRcvQueueStatus st rq Active
-              sendAck c rq
-            REPLY qInfo -> do
-              logServer "<--" c srv rId "MSG <REPLY>"
-              -- TODO move senderKey inside SndQueue
+            _ -> prohibited
+
+        helloMsg :: SenderPublicKey -> ByteString -> m ()
+        helloMsg verifyKey msgBody = do
+          logServer "<--" c srv rId "MSG <HELLO>"
+          case status of
+            Active -> prohibited
+            _ -> do
+              void $ verifyMessage (Just verifyKey) msgBody
+              withStore $ setRcvQueueActive st rq verifyKey
+              case cType of
+                SCDuplex -> notify CON
+                _ -> pure ()
+
+        replyMsg :: SMPQueueInfo -> m ()
+        replyMsg qInfo = do
+          logServer "<--" c srv rId "MSG <REPLY>"
+          case cType of
+            SCRcv -> do
               (sq, senderKey, verifyKey) <- newSendQueue qInfo connAlias
               withStore $ upgradeRcvConnToDuplex st connAlias sq
               connectToSendQueue c st sq senderKey verifyKey
-              notify connAlias CON
-              sendAck c rq
-            A_MSG body -> do
-              logServer "<--" c srv rId "MSG <MSG>"
-              -- TODO check message status
-              recipientTs <- liftIO getCurrentTime
-              let m_sender = (senderMsgId, senderTimestamp)
-              let m_broker = (srvMsgId, srvTs)
-              recipientId <- withStore $ createRcvMsg st connAlias body recipientTs m_sender m_broker
-              notify connAlias $
+              notify CON
+            _ -> prohibited
+
+        agentClientMsg :: PrevRcvMsgHash -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> MsgBody -> MsgHash -> m ()
+        agentClientMsg receivedPrevMsgHash senderMeta brokerMeta msgBody msgHash = do
+          logServer "<--" c srv rId "MSG <MSG>"
+          case status of
+            Active -> do
+              internalTs <- liftIO getCurrentTime
+              (internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- withStore $ updateRcvIds st rq
+              let msgIntegrity = checkMsgIntegrity prevExtSndId (fst senderMeta) prevRcvMsgHash receivedPrevMsgHash
+              withStore $
+                createRcvMsg st rq $
+                  RcvMsgData
+                    { internalId,
+                      internalRcvId,
+                      internalTs,
+                      senderMeta,
+                      brokerMeta,
+                      msgBody,
+                      internalHash = msgHash,
+                      externalPrevSndHash = receivedPrevMsgHash,
+                      msgIntegrity
+                    }
+              notify
                 MSG
-                  { m_status = MsgOk,
-                    m_recipient = (unId recipientId, recipientTs),
-                    m_sender,
-                    m_broker,
-                    m_body = body
+                  { recipientMeta = (unId internalId, internalTs),
+                    senderMeta,
+                    brokerMeta,
+                    msgBody,
+                    msgIntegrity
                   }
-              sendAck c rq
-      return ()
-    SMP.END -> do
-      removeSubscription c connAlias
-      logServer "<--" c srv rId "END"
-      notify connAlias END
-    _ -> logServer "<--" c srv rId $ "unexpected:" <> (B.pack . show) cmd
-  where
-    notify :: ConnAlias -> ACommand 'Agent -> m ()
-    notify connAlias msg = atomically $ writeTBQueue sndQ ("", connAlias, msg)
+            _ -> prohibited
+
+        checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
+        checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash
+          | extSndId == prevExtSndId + 1 && internalPrevMsgHash == receivedPrevMsgHash = MsgOk
+          | extSndId < prevExtSndId = MsgError $ MsgBadId extSndId
+          | extSndId == prevExtSndId = MsgError MsgDuplicate -- ? deduplicate
+          | extSndId > prevExtSndId + 1 = MsgError $ MsgSkipped (prevExtSndId + 1) (extSndId - 1)
+          | internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
+          | otherwise = MsgError MsgDuplicate -- this case is not possible
 
 connectToSendQueue :: AgentMonad m => AgentClient -> SQLiteStore -> SndQueue -> SenderPublicKey -> VerificationKey -> m ()
 connectToSendQueue c st sq senderKey verifyKey = do
@@ -290,9 +399,6 @@ connectToSendQueue c st sq senderKey verifyKey = do
   sendHello c sq verifyKey
   withStore $ setSndQueueStatus st sq Active
 
-decryptMessage :: (MonadUnliftIO m, MonadError AgentErrorType m) => DecryptionKey -> ByteString -> m ByteString
-decryptMessage decryptKey msg = liftError CRYPTO $ C.decrypt decryptKey msg
-
 newSendQueue ::
   (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> ConnAlias -> m (SndQueue, SenderPublicKey, VerificationKey)
 newSendQueue (SMPQueueInfo smpServer senderId encryptKey) connAlias = do

src/Simplex/Messaging/Agent/Client.hs

@@ -19,11 +19,14 @@ module Simplex.Messaging.Agent.Client
     sendHello,
     secureQueue,
     sendAgentMessage,
+    decryptAndVerify,
+    verifyMessage,
     sendAck,
     suspendQueue,
     deleteQueue,
     logServer,
     removeSubscription,
+    cryptoError,
   )
 where
 
@@ -42,12 +45,12 @@ 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.Store
-import Simplex.Messaging.Agent.Transmission
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey)
-import Simplex.Messaging.Util (liftError)
+import Simplex.Messaging.Util (bshow, liftEitherError, liftError)
 import UnliftIO.Concurrent
 import UnliftIO.Exception (IOException)
 import qualified UnliftIO.Exception as E
@@ -86,15 +89,17 @@ getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
     newSMPClient = do
       smp <- connectClient
       logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
-      -- TODO how can agent know client lost the connection?
       atomically . modifyTVar smpClients $ M.insert srv smp
       return smp
 
     connectClient :: m SMPClient
     connectClient = do
       cfg <- asks $ smpCfg . config
-      liftIO (getSMPClient srv cfg msgQ clientDisconnected)
-        `E.catch` \(_ :: IOException) -> throwError (BROKER smpErrTCPConnection)
+      liftEitherError smpClientError (getSMPClient srv cfg msgQ clientDisconnected)
+        `E.catch` internalError
+      where
+        internalError :: IOException -> m SMPClient
+        internalError = throwError . INTERNAL . show
 
     clientDisconnected :: IO ()
     clientDisconnected = do
@@ -118,31 +123,41 @@ getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
 closeSMPServerClients :: MonadUnliftIO m => AgentClient -> m ()
 closeSMPServerClients c = liftIO $ readTVarIO (smpClients c) >>= mapM_ closeSMPClient
 
-withSMP :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
-withSMP c srv action =
-  (getSMPServerClient c srv >>= runAction) `catchError` logServerError
+withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
+withSMP_ c srv action =
+  (getSMPServerClient c srv >>= action) `catchError` logServerError
   where
-    runAction :: SMPClient -> m a
-    runAction smp = liftError smpClientError $ action smp
-
-    smpClientError :: SMPClientError -> AgentErrorType
-    smpClientError = \case
-      SMPServerError e -> SMP e
-      -- TODO handle other errors
-      _ -> INTERNAL
-
     logServerError :: AgentErrorType -> m a
     logServerError e = do
-      logServer "<--" c srv "" $ (B.pack . show) e
+      logServer "<--" c srv "" $ bshow e
       throwError e
 
-withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
-withLogSMP c srv qId cmdStr action = do
+withLogSMP_ :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> m a) -> m a
+withLogSMP_ c srv qId cmdStr action = do
   logServer "-->" c srv qId cmdStr
-  res <- withSMP c srv action
+  res <- withSMP_ c srv action
   logServer "<--" c srv qId "OK"
   return res
 
+withSMP :: AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
+withSMP c srv action = withSMP_ c srv $ liftSMP . action
+
+withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
+withLogSMP c srv qId cmdStr action = withLogSMP_ c srv qId cmdStr $ liftSMP . action
+
+liftSMP :: AgentMonad m => ExceptT SMPClientError IO a -> m a
+liftSMP = liftError smpClientError
+
+smpClientError :: SMPClientError -> AgentErrorType
+smpClientError = \case
+  SMPServerError e -> SMP e
+  SMPResponseError e -> BROKER $ RESPONSE e
+  SMPUnexpectedResponse -> BROKER UNEXPECTED
+  SMPResponseTimeout -> BROKER TIMEOUT
+  SMPNetworkError -> BROKER NETWORK
+  SMPTransportError e -> BROKER $ TRANSPORT e
+  e -> INTERNAL $ show e
+
 newReceiveQueue :: AgentMonad m => AgentClient -> SMPServer -> ConnAlias -> m (RcvQueue, SMPQueueInfo)
 newReceiveQueue c srv connAlias = do
   size <- asks $ rsaKeySize . config
@@ -196,7 +211,7 @@ removeSubscription AgentClient {subscrConns, subscrSrvrs} connAlias = atomically
 
 logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
 logServer dir AgentClient {clientId} srv qId cmdStr =
-  logInfo . decodeUtf8 $ B.unwords ["A", "(" <> (B.pack . show) clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
+  logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
 
 showServer :: SMPServer -> ByteString
 showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv)
@@ -205,35 +220,38 @@ logSecret :: ByteString -> ByteString
 logSecret bs = encode $ B.take 3 bs
 
 sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> m ()
-sendConfirmation c SndQueue {server, sndId, encryptKey} senderKey = do
-  msg <- mkConfirmation
-  withLogSMP c server sndId "SEND <KEY>" $ \smp ->
-    sendSMPMessage smp Nothing sndId msg
+sendConfirmation c sq@SndQueue {server, sndId} senderKey =
+  withLogSMP_ c server sndId "SEND <KEY>" $ \smp -> do
+    msg <- mkConfirmation smp
+    liftSMP $ sendSMPMessage smp Nothing sndId msg
   where
-    mkConfirmation :: m MsgBody
-    mkConfirmation = do
-      let msg = serializeSMPMessage $ SMPConfirmation senderKey
-      paddedSize <- asks paddedMsgSize
-      liftError CRYPTO $ C.encrypt encryptKey paddedSize msg
+    mkConfirmation :: SMPClient -> m MsgBody
+    mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey
 
 sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> m ()
-sendHello c SndQueue {server, sndId, sndPrivateKey, encryptKey} verifyKey = do
-  msg <- mkHello $ AckMode On
-  withLogSMP c server sndId "SEND <HELLO> (retrying)" $
-    send 20 msg
+sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey =
+  withLogSMP_ c server sndId "SEND <HELLO> (retrying)" $ \smp -> do
+    msg <- mkHello smp $ AckMode On
+    liftSMP $ send 8 100000 msg smp
   where
-    mkHello :: AckMode -> m ByteString
-    mkHello ackMode = do
-      senderTs <- liftIO getCurrentTime
-      mkAgentMessage encryptKey senderTs $ HELLO verifyKey ackMode
+    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
+          }
 
-    send :: Int -> ByteString -> SMPClient -> ExceptT SMPClientError IO ()
-    send 0 _ _ = throwE SMPResponseTimeout -- TODO different error
-    send retry msg smp =
+    send :: Int -> Int -> ByteString -> SMPClient -> ExceptT SMPClientError IO ()
+    send 0 _ _ _ = throwE $ SMPServerError AUTH
+    send retry delay msg smp =
       sendSMPMessage smp (Just sndPrivateKey) sndId msg `catchE` \case
         SMPServerError AUTH -> do
-          threadDelay 100000
-          send (retry - 1) msg smp
+          threadDelay delay
+          send (retry - 1) (delay * 3 `div` 2) msg smp
         e -> throwE e
 
 secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()
@@ -256,21 +274,39 @@ deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
   withLogSMP c server rcvId "DEL" $ \smp ->
     deleteSMPQueue smp rcvPrivateKey rcvId
 
-sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> SenderTimestamp -> AMessage -> m ()
-sendAgentMessage c SndQueue {server, sndId, sndPrivateKey, encryptKey} senderTs agentMsg = do
-  msg <- mkAgentMessage encryptKey senderTs agentMsg
-  withLogSMP c server sndId "SEND <message>" $ \smp ->
-    sendSMPMessage smp (Just sndPrivateKey) sndId msg
+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'
 
-mkAgentMessage :: AgentMonad m => EncryptionKey -> SenderTimestamp -> AMessage -> m ByteString
-mkAgentMessage encKey senderTs agentMessage = do
-  let msg =
-        serializeSMPMessage
-          SMPMessage
-            { senderMsgId = 0,
-              senderTimestamp = senderTs,
-              previousMsgHash = "1234", -- TODO hash of the previous message
-              agentMessage
-            }
-  paddedSize <- asks paddedMsgSize
-  liftError CRYPTO $ C.encrypt encKey paddedSize 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
+
+decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString
+decryptAndVerify RcvQueue {decryptKey, verifyKey} msg =
+  verifyMessage verifyKey msg
+    >>= liftError cryptoError . C.decrypt decryptKey
+
+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
+
+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
+  e -> INTERNAL $ show e

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -7,14 +7,18 @@ module Simplex.Messaging.Agent.Env.SQLite where
 
 import Control.Monad.IO.Unlift
 import Crypto.Random
+import Data.List.NonEmpty (NonEmpty)
 import Network.Socket
 import Numeric.Natural
+import Simplex.Messaging.Agent.Protocol (SMPServer)
 import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Client
+import System.Random (StdGen, newStdGen)
 import UnliftIO.STM
 
 data AgentConfig = AgentConfig
   { tcpPort :: ServiceName,
+    smpServers :: NonEmpty SMPServer,
     rsaKeySize :: Int,
     connIdBytes :: Int,
     tbqSize :: Natural,
@@ -26,18 +30,20 @@ data Env = Env
   { config :: AgentConfig,
     idsDrg :: TVar ChaChaDRG,
     clientCounter :: TVar Int,
-    paddedMsgSize :: Int
+    reservedMsgSize :: Int,
+    randomServer :: TVar StdGen
   }
 
 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
 newSMPAgentEnv config = do
-  idsDrg <- drgNew >>= newTVarIO
+  idsDrg <- newTVarIO =<< drgNew
   _ <- createSQLiteStore $ dbFile config
   clientCounter <- newTVarIO 0
-  return Env {config, idsDrg, clientCounter, paddedMsgSize}
+  randomServer <- newTVarIO =<< liftIO newStdGen
+  return Env {config, idsDrg, clientCounter, reservedMsgSize, randomServer}
   where
-    -- one rsaKeySize is used by the RSA signature in each command,
-    -- another - by encrypted message body header
+    -- 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
-    paddedMsgSize = blockSize smp - 2 * rsaKeySize config - smpCommandSize smp
-    smp = smpCfg config
+    reservedMsgSize = 3 * rsaKeySize config + smpCommandSize (smpCfg config)

src/Simplex/Messaging/Agent/Protocol.hs

@@ -0,0 +1,600 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
+-- |
+-- Module      : Simplex.Messaging.Agent.Protocol
+-- Copyright   : (c) simplex.chat
+-- License     : AGPL-3
+--
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : non-portable
+--
+-- Types, parsers, serializers and functions to send and receive SMP agent protocol commands and responses.
+--
+-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
+module Simplex.Messaging.Agent.Protocol
+  ( -- * SMP agent protocol types
+    ACommand (..),
+    AParty (..),
+    SAParty (..),
+    SMPMessage (..),
+    AMessage (..),
+    SMPServer (..),
+    SMPQueueInfo (..),
+    AgentErrorType (..),
+    CommandErrorType (..),
+    ConnectionErrorType (..),
+    BrokerErrorType (..),
+    SMPAgentError (..),
+    ATransmission,
+    ATransmissionOrError,
+    ARawTransmission,
+    ConnAlias,
+    ReplyMode (..),
+    AckMode (..),
+    OnOff (..),
+    MsgIntegrity (..),
+    MsgErrorType (..),
+    QueueStatus (..),
+    SignatureKey,
+    VerificationKey,
+    EncryptionKey,
+    DecryptionKey,
+
+    -- * Parse and serialize
+    serializeCommand,
+    serializeSMPMessage,
+    serializeMsgIntegrity,
+    serializeServer,
+    serializeSmpQueueInfo,
+    serializeAgentError,
+    commandP,
+    parseSMPMessage,
+    smpServerP,
+    smpQueueInfoP,
+    msgIntegrityP,
+    agentErrorTypeP,
+
+    -- * TCP transport functions
+    tPut,
+    tGet,
+    tPutRaw,
+    tGetRaw,
+  )
+where
+
+import Control.Applicative (optional, (<|>))
+import Control.Monad.IO.Class
+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.Int (Int64)
+import Data.Kind (Type)
+import Data.String (IsString (..))
+import Data.Time.Clock (UTCTime)
+import Data.Time.ISO8601
+import Data.Type.Equality
+import Data.Typeable ()
+import GHC.Generics (Generic)
+import Generic.Random (genericArbitraryU)
+import Network.Socket
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Parsers
+import Simplex.Messaging.Protocol
+  ( CorrId (..),
+    ErrorType,
+    MsgBody,
+    MsgId,
+    SenderPublicKey,
+  )
+import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
+import Simplex.Messaging.Util
+import Test.QuickCheck (Arbitrary (..))
+import Text.Read
+import UnliftIO.Exception
+
+-- | Raw (unparsed) SMP agent protocol transmission.
+type ARawTransmission = (ByteString, ByteString, ByteString)
+
+-- | Parsed SMP agent protocol transmission.
+type ATransmission p = (CorrId, ConnAlias, ACommand p)
+
+-- | SMP agent protocol transmission or transmission error.
+type ATransmissionOrError p = (CorrId, ConnAlias, Either AgentErrorType (ACommand p))
+
+-- | SMP agent protocol participants.
+data AParty = Agent | Client
+  deriving (Eq, Show)
+
+-- | Singleton types for SMP agent protocol participants.
+data SAParty :: AParty -> Type where
+  SAgent :: SAParty Agent
+  SClient :: SAParty Client
+
+deriving instance Show (SAParty p)
+
+deriving instance Eq (SAParty p)
+
+instance TestEquality SAParty where
+  testEquality SAgent SAgent = Just Refl
+  testEquality SClient SClient = Just Refl
+  testEquality _ _ = Nothing
+
+data ACmd = forall p. ACmd (SAParty p) (ACommand p)
+
+deriving instance Show ACmd
+
+-- | Parameterized type for SMP agent protocol commands and responses from all participants.
+data ACommand (p :: AParty) where
+  NEW :: ACommand Client -- response INV
+  INV :: SMPQueueInfo -> ACommand Agent
+  JOIN :: SMPQueueInfo -> ReplyMode -> ACommand Client -- response OK
+  CON :: ACommand Agent -- notification that connection is established
+  -- TODO currently it automatically allows whoever sends the confirmation
+  -- CONF :: OtherPartyId -> ACommand Agent
+  -- LET :: OtherPartyId -> ACommand Client
+  SUB :: ACommand Client
+  SUBALL :: ACommand Client -- TODO should be moved to chat protocol - hack for subscribing to all
+  END :: ACommand Agent
+  -- QST :: QueueDirection -> ACommand Client
+  -- STAT :: QueueDirection -> Maybe QueueStatus -> Maybe SubMode -> ACommand Agent
+  SEND :: MsgBody -> ACommand Client
+  SENT :: AgentMsgId -> ACommand Agent
+  MSG ::
+    { recipientMeta :: (AgentMsgId, UTCTime),
+      brokerMeta :: (MsgId, UTCTime),
+      senderMeta :: (AgentMsgId, UTCTime),
+      msgIntegrity :: MsgIntegrity,
+      msgBody :: MsgBody
+    } ->
+    ACommand Agent
+  -- ACK :: AgentMsgId -> ACommand Client
+  -- RCVD :: AgentMsgId -> ACommand Agent
+  OFF :: ACommand Client
+  DEL :: ACommand Client
+  OK :: ACommand Agent
+  ERR :: AgentErrorType -> ACommand Agent
+
+deriving instance Eq (ACommand p)
+
+deriving instance Show (ACommand p)
+
+-- | 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 SenderPublicKey
+  | -- | 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 :: ByteString,
+        -- | messages sent between agents once queue is secured
+        agentMessage :: AMessage
+      }
+  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 :: SMPQueueInfo -> AMessage
+  -- | agent envelope for the client message
+  A_MSG :: MsgBody -> AMessage
+  deriving (Show)
+
+-- | Parse SMP message.
+parseSMPMessage :: ByteString -> Either AgentErrorType SMPMessage
+parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE
+  where
+    smpMessageP :: Parser SMPMessage
+    smpMessageP =
+      smpConfirmationP <* A.endOfLine
+        <|> A.endOfLine *> smpClientMessageP
+
+    smpConfirmationP :: Parser SMPMessage
+    smpConfirmationP = SMPConfirmation <$> ("KEY " *> C.pubKeyP <* 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
+
+-- | Serialize SMP message.
+serializeSMPMessage :: SMPMessage -> ByteString
+serializeSMPMessage = \case
+  SMPConfirmation sKey -> smpMessage ("KEY " <> C.serializePubKey sKey) "" ""
+  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, ""]
+
+agentMessageP :: Parser AMessage
+agentMessageP =
+  "HELLO " *> hello
+    <|> "REPLY " *> reply
+    <|> "MSG " *> a_msg
+  where
+    hello = HELLO <$> C.pubKeyP <*> ackMode
+    reply = REPLY <$> smpQueueInfoP
+    a_msg = do
+      size :: Int <- A.decimal <* A.endOfLine
+      A_MSG <$> A.take size <* A.endOfLine
+    ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On)
+
+-- | SMP queue information parser.
+smpQueueInfoP :: Parser SMPQueueInfo
+smpQueueInfoP =
+  "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.pubKeyP)
+
+-- | 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)
+
+serializeAgentMessage :: AMessage -> ByteString
+serializeAgentMessage = \case
+  HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else ""
+  REPLY qInfo -> "REPLY " <> serializeSmpQueueInfo qInfo
+  A_MSG body -> "MSG " <> serializeMsg body <> "\n"
+
+-- | Serialize SMP queue information that is sent out-of-band.
+serializeSmpQueueInfo :: SMPQueueInfo -> ByteString
+serializeSmpQueueInfo (SMPQueueInfo srv qId ek) =
+  B.intercalate "::" ["smp", serializeServer srv, encode qId, C.serializePubKey ek]
+
+-- | Serialize SMP server location.
+serializeServer :: SMPServer -> ByteString
+serializeServer SMPServer {host, port, keyHash} =
+  B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . encode . C.unKeyHash) keyHash
+
+-- | 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.
+type ConnAlias = ByteString
+
+-- | Connection modes.
+data OnOff = On | Off deriving (Eq, Show, Read)
+
+-- | Message acknowledgement mode of the connection.
+newtype AckMode = AckMode OnOff deriving (Eq, Show)
+
+-- | SMP queue information sent out-of-band.
+--
+-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
+data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId EncryptionKey
+  deriving (Eq, Show)
+
+-- | Connection reply mode (used in JOIN command).
+newtype ReplyMode = ReplyMode OnOff deriving (Eq, Show)
+
+-- | 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.SafePrivateKey
+
+-- | Public key used by SMP server to authorize (verify) SMP commands.
+type VerificationKey = C.PublicKey
+
+data QueueDirection = SND | RCV deriving (Show)
+
+-- | SMP queue status.
+data QueueStatus
+  = -- | queue is created
+    New
+  | -- | queue is confirmed by the sender
+    Confirmed
+  | -- | queue is secured with sender key (only used by the queue recipient)
+    Secured
+  | -- | queue is active
+    Active
+  | -- | queue is disabled (only used by the queue recipient)
+    Disabled
+  deriving (Eq, Show, Read)
+
+type AgentMsgId = Int64
+
+type SenderTimestamp = UTCTime
+
+-- | Result of received message integrity validation.
+data MsgIntegrity = MsgOk | MsgError MsgErrorType
+  deriving (Eq, Show)
+
+-- | Error of message integrity validation.
+data MsgErrorType = MsgSkipped AgentMsgId AgentMsgId | MsgBadId AgentMsgId | MsgBadHash | MsgDuplicate
+  deriving (Eq, Show)
+
+-- | Error type used in errors sent to agent clients.
+data AgentErrorType
+  = -- | command or response error
+    CMD CommandErrorType
+  | -- | connection errors
+    CONN ConnectionErrorType
+  | -- | SMP protocol errors forwarded to agent clients
+    SMP ErrorType
+  | -- | SMP server errors
+    BROKER BrokerErrorType
+  | -- | errors of other agents
+    AGENT SMPAgentError
+  | -- | agent implementation or dependency errors
+    INTERNAL String
+  deriving (Eq, Generic, Read, Show, Exception)
+
+-- | SMP agent protocol command or response error.
+data CommandErrorType
+  = -- | command is prohibited
+    PROHIBITED
+  | -- | command syntax is invalid
+    SYNTAX
+  | -- | connection alias is required with this command
+    NO_CONN
+  | -- | message size is not correct (no terminating space)
+    SIZE
+  | -- | message does not fit in SMP block
+    LARGE
+  deriving (Eq, Generic, Read, Show, Exception)
+
+-- | Connection error.
+data ConnectionErrorType
+  = -- | connection alias is not in the database
+    UNKNOWN
+  | -- | connection alias already exists
+    DUPLICATE
+  | -- | connection is simplex, but operation requires another queue
+    SIMPLEX
+  deriving (Eq, Generic, Read, Show, Exception)
+
+-- | SMP server errors.
+data BrokerErrorType
+  = -- | invalid server response (failed to parse)
+    RESPONSE ErrorType
+  | -- | unexpected response
+    UNEXPECTED
+  | -- | network error
+    NETWORK
+  | -- | handshake or other transport error
+    TRANSPORT TransportError
+  | -- | command response timeout
+    TIMEOUT
+  deriving (Eq, Generic, Read, Show, Exception)
+
+-- | Errors of another SMP agent.
+data SMPAgentError
+  = -- | possibly should include bytestring that failed to parse
+    A_MESSAGE
+  | -- | possibly should include the prohibited SMP/agent message
+    A_PROHIBITED
+  | -- | cannot RSA/AES-decrypt or parse decrypted header
+    A_ENCRYPTION
+  | -- | invalid RSA signature
+    A_SIGNATURE
+  deriving (Eq, Generic, Read, Show, Exception)
+
+instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
+
+instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU
+
+instance Arbitrary ConnectionErrorType where arbitrary = genericArbitraryU
+
+instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU
+
+instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
+
+-- | AMP agent command and response parser
+commandP :: Parser ACmd
+commandP =
+  "NEW" $> ACmd SClient NEW
+    <|> "INV " *> invResp
+    <|> "JOIN " *> joinCmd
+    <|> "SUB" $> ACmd SClient SUB
+    <|> "SUBALL" $> ACmd SClient SUBALL -- TODO remove - hack for subscribing to all
+    <|> "END" $> ACmd SAgent END
+    <|> "SEND " *> sendCmd
+    <|> "SENT " *> sentResp
+    <|> "MSG " *> message
+    <|> "OFF" $> ACmd SClient OFF
+    <|> "DEL" $> ACmd SClient DEL
+    <|> "ERR " *> agentError
+    <|> "CON" $> ACmd SAgent CON
+    <|> "OK" $> ACmd SAgent OK
+  where
+    invResp = ACmd SAgent . INV <$> smpQueueInfoP
+    joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <*> replyMode)
+    sendCmd = ACmd SClient . SEND <$> A.takeByteString
+    sentResp = ACmd SAgent . SENT <$> A.decimal
+    message = do
+      msgIntegrity <- msgIntegrityP <* A.space
+      recipientMeta <- "R=" *> partyMeta A.decimal
+      brokerMeta <- "B=" *> partyMeta base64P
+      senderMeta <- "S=" *> partyMeta A.decimal
+      msgBody <- A.takeByteString
+      return $ ACmd SAgent MSG {recipientMeta, brokerMeta, senderMeta, msgIntegrity, msgBody}
+    replyMode = ReplyMode <$> (" NO_REPLY" $> Off <|> pure On)
+    partyMeta idParser = (,) <$> idParser <* "," <*> tsISO8601P <* A.space
+    agentError = ACmd SAgent . ERR <$> agentErrorTypeP
+
+-- | Message integrity validation result parser.
+msgIntegrityP :: Parser MsgIntegrity
+msgIntegrityP = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> msgErrorType)
+  where
+    msgErrorType =
+      "ID " *> (MsgBadId <$> A.decimal)
+        <|> "IDS " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal)
+        <|> "HASH" $> MsgBadHash
+        <|> "DUPLICATE" $> MsgDuplicate
+
+parseCommand :: ByteString -> Either AgentErrorType ACmd
+parseCommand = parse commandP $ CMD SYNTAX
+
+-- | Serialize SMP agent command.
+serializeCommand :: ACommand p -> ByteString
+serializeCommand = \case
+  NEW -> "NEW"
+  INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo
+  JOIN qInfo rMode -> "JOIN " <> serializeSmpQueueInfo qInfo <> replyMode rMode
+  SUB -> "SUB"
+  SUBALL -> "SUBALL" -- TODO remove - hack for subscribing to all
+  END -> "END"
+  SEND msgBody -> "SEND " <> serializeMsg msgBody
+  SENT mId -> "SENT " <> bshow mId
+  MSG {recipientMeta = (rmId, rTs), brokerMeta = (bmId, bTs), senderMeta = (smId, sTs), msgIntegrity, msgBody} ->
+    B.unwords
+      [ "MSG",
+        serializeMsgIntegrity msgIntegrity,
+        "R=" <> bshow rmId <> "," <> showTs rTs,
+        "B=" <> encode bmId <> "," <> showTs bTs,
+        "S=" <> bshow smId <> "," <> showTs sTs,
+        serializeMsg msgBody
+      ]
+  OFF -> "OFF"
+  DEL -> "DEL"
+  CON -> "CON"
+  ERR e -> "ERR " <> serializeAgentError e
+  OK -> "OK"
+  where
+    replyMode :: ReplyMode -> ByteString
+    replyMode = \case
+      ReplyMode Off -> " NO_REPLY"
+      ReplyMode On -> ""
+    showTs :: UTCTime -> ByteString
+    showTs = B.pack . formatISO8601Millis
+
+-- | Serialize message integrity validation result.
+serializeMsgIntegrity :: MsgIntegrity -> ByteString
+serializeMsgIntegrity = \case
+  MsgOk -> "OK"
+  MsgError e ->
+    "ERR " <> case e of
+      MsgSkipped fromMsgId toMsgId ->
+        B.unwords ["NO_ID", bshow fromMsgId, bshow toMsgId]
+      MsgBadId aMsgId -> "ID " <> bshow aMsgId
+      MsgBadHash -> "HASH"
+      MsgDuplicate -> "DUPLICATE"
+
+-- | SMP agent protocol error parser.
+agentErrorTypeP :: Parser AgentErrorType
+agentErrorTypeP =
+  "SMP " *> (SMP <$> SMP.errorTypeP)
+    <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> SMP.errorTypeP)
+    <|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP)
+    <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
+    <|> parseRead2
+
+-- | Serialize SMP agent protocol error.
+serializeAgentError :: AgentErrorType -> ByteString
+serializeAgentError = \case
+  SMP e -> "SMP " <> SMP.serializeErrorType e
+  BROKER (RESPONSE e) -> "BROKER RESPONSE " <> SMP.serializeErrorType e
+  BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
+  e -> bshow e
+
+serializeMsg :: ByteString -> ByteString
+serializeMsg body = bshow (B.length body) <> "\n" <> body
+
+-- | Send raw (unparsed) SMP agent protocol transmission to TCP connection.
+tPutRaw :: Transport c => c -> ARawTransmission -> IO ()
+tPutRaw h (corrId, connAlias, command) = do
+  putLn h corrId
+  putLn h connAlias
+  putLn h command
+
+-- | Receive raw (unparsed) SMP agent protocol transmission from TCP connection.
+tGetRaw :: Transport c => c -> IO ARawTransmission
+tGetRaw h = (,,) <$> getLn h <*> getLn h <*> getLn h
+
+-- | Send SMP agent protocol command (or response) to TCP connection.
+tPut :: (Transport c, MonadIO m) => c -> ATransmission p -> m ()
+tPut h (CorrId corrId, connAlias, command) =
+  liftIO $ tPutRaw h (corrId, connAlias, 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)
+tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
+  where
+    tParseLoadBody :: ARawTransmission -> m (ATransmissionOrError p)
+    tParseLoadBody t@(corrId, connAlias, command) = do
+      let cmd = parseCommand command >>= fromParty >>= tConnAlias t
+      fullCmd <- either (return . Left) cmdWithMsgBody cmd
+      return (CorrId corrId, connAlias, fullCmd)
+
+    fromParty :: ACmd -> Either AgentErrorType (ACommand p)
+    fromParty (ACmd (p :: p1) cmd) = case testEquality party p of
+      Just Refl -> Right cmd
+      _ -> Left $ CMD PROHIBITED
+
+    tConnAlias :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p)
+    tConnAlias (_, connAlias, _) cmd = case cmd of
+      -- NEW and JOIN have optional connAlias
+      NEW -> Right cmd
+      JOIN _ _ -> Right cmd
+      -- ERROR response does not always have connAlias
+      ERR _ -> Right cmd
+      -- other responses must have connAlias
+      _
+        | B.null connAlias -> Left $ CMD NO_CONN
+        | otherwise -> Right cmd
+
+    cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p))
+    cmdWithMsgBody = \case
+      SEND body -> SEND <$$> getMsgBody body
+      MSG agentMsgId srvTS agentTS integrity body -> MSG agentMsgId srvTS agentTS integrity <$$> getMsgBody body
+      cmd -> return $ Right cmd
+
+    -- TODO refactor with server
+    getMsgBody :: MsgBody -> m (Either AgentErrorType MsgBody)
+    getMsgBody msgBody =
+      case B.unpack msgBody of
+        ':' : body -> return . Right $ B.pack body
+        str -> case readMaybe str :: Maybe Int of
+          Just size -> liftIO $ do
+            body <- cGet h size
+            s <- getLn h
+            return $ if B.null s then Right body else Left $ CMD SIZE
+          Nothing -> return . Left $ CMD SYNTAX

src/Simplex/Messaging/Agent/Store.hs

@@ -10,11 +10,12 @@
 module Simplex.Messaging.Agent.Store where
 
 import Control.Exception (Exception)
+import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Kind (Type)
 import Data.Time (UTCTime)
 import Data.Type.Equality
-import Simplex.Messaging.Agent.Transmission
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Protocol
   ( MsgBody,
     MsgId,
@@ -33,16 +34,21 @@ class Monad m => MonadAgentStore s m where
   createSndConn :: s -> SndQueue -> m ()
   getConn :: s -> ConnAlias -> m SomeConn
   getAllConnAliases :: s -> m [ConnAlias] -- TODO remove - hack for subscribing to all
-  getRcvQueue :: s -> SMPServer -> SMP.RecipientId -> m RcvQueue
+  getRcvConn :: s -> SMPServer -> SMP.RecipientId -> m SomeConn
   deleteConn :: s -> ConnAlias -> m ()
   upgradeRcvConnToDuplex :: s -> ConnAlias -> SndQueue -> m ()
   upgradeSndConnToDuplex :: s -> ConnAlias -> RcvQueue -> m ()
   setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
+  setRcvQueueActive :: s -> RcvQueue -> VerificationKey -> m ()
   setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
 
   -- Msg management
-  createRcvMsg :: s -> ConnAlias -> MsgBody -> InternalTs -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> m InternalId
-  createSndMsg :: s -> ConnAlias -> MsgBody -> InternalTs -> m InternalId
+  updateRcvIds :: s -> RcvQueue -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+  createRcvMsg :: s -> RcvQueue -> RcvMsgData -> m ()
+
+  updateSndIds :: s -> SndQueue -> m (InternalId, InternalSndId, PrevSndMsgHash)
+  createSndMsg :: s -> SndQueue -> SndMsgData -> m ()
+
   getMsg :: s -> ConnAlias -> InternalId -> m Msg
 
 -- * Queue types
@@ -102,6 +108,11 @@ data SConnType :: ConnType -> Type where
   SCSnd :: SConnType CSnd
   SCDuplex :: SConnType CDuplex
 
+connType :: SConnType c -> ConnType
+connType SCRcv = CRcv
+connType SCSnd = CSnd
+connType SCDuplex = CDuplex
+
 deriving instance Eq (SConnType d)
 
 deriving instance Show (SConnType d)
@@ -123,6 +134,43 @@ instance Eq SomeConn where
 
 deriving instance Show SomeConn
 
+-- * Message integrity validation types
+
+type MsgHash = ByteString
+
+-- | Corresponds to `last_external_snd_msg_id` in `connections` table
+type PrevExternalSndId = Int64
+
+-- | Corresponds to `last_rcv_msg_hash` in `connections` table
+type PrevRcvMsgHash = MsgHash
+
+-- | 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
+  { internalId :: InternalId,
+    internalRcvId :: InternalRcvId,
+    internalTs :: InternalTs,
+    senderMeta :: (ExternalSndId, ExternalSndTs),
+    brokerMeta :: (BrokerId, BrokerTs),
+    msgBody :: MsgBody,
+    internalHash :: MsgHash,
+    externalPrevSndHash :: MsgHash,
+    msgIntegrity :: MsgIntegrity
+  }
+
+data SndMsgData = SndMsgData
+  { internalId :: InternalId,
+    internalSndId :: InternalSndId,
+    internalTs :: InternalTs,
+    msgBody :: MsgBody,
+    internalHash :: MsgHash
+  }
+
 -- * Message types
 
 -- | A message in either direction that is stored by the agent.
@@ -149,7 +197,10 @@ data RcvMsg = RcvMsg
     -- | 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
+    ackSenderTs :: AckSenderTs,
+    -- | Hash of previous message as received from sender - stored for integrity forensics.
+    externalPrevSndHash :: MsgHash,
+    msgIntegrity :: MsgIntegrity
   }
   deriving (Eq, Show)
 
@@ -209,7 +260,9 @@ data MsgBase = MsgBase
     -- due to a possibility of implementation errors in different agents.
     internalId :: InternalId,
     internalTs :: InternalTs,
-    msgBody :: MsgBody
+    msgBody :: MsgBody,
+    -- | Hash of the message as computed by agent.
+    internalHash :: MsgHash
   }
   deriving (Eq, Show)
 
@@ -219,13 +272,21 @@ type InternalTs = UTCTime
 
 -- * Store errors
 
--- TODO revise
+-- | Agent store error.
 data StoreError
-  = SEInternal
-  | SENotFound
-  | SEBadConn
-  | SEBadConnType ConnType
-  | SEBadQueueStatus
-  | SEBadQueueDirection
-  | SENotImplemented -- TODO remove
+  = -- | IO exceptions in store actions.
+    SEInternal ByteString
+  | -- | Connection alias not found (or both queues absent).
+    SEConnNotFound
+  | -- | Connection alias 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.
+    SEBadConnType ConnType
+  | -- | Currently not used. The intention was to pass current expected queue status in methods,
+    -- 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
+  | -- | Used in `getMsg` that is not implemented/used. TODO remove.
+    SENotImplemented
   deriving (Eq, Show, Exception)

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -1,9 +1,12 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -18,27 +21,30 @@ module Simplex.Messaging.Agent.Store.SQLite
   )
 where
 
+import Control.Concurrent (threadDelay)
 import Control.Monad (when)
 import Control.Monad.Except (MonadError (throwError), MonadIO (liftIO))
 import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Data.Bifunctor (first)
 import Data.List (find)
 import Data.Maybe (fromMaybe)
 import Data.Text (isPrefixOf)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8)
-import Database.SQLite.Simple as DB
+import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLData (..), SQLError, field)
+import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
 import Database.SQLite.Simple.QQ (sql)
 import Database.SQLite.Simple.ToField (ToField (..))
-import Network.Socket (HostName, ServiceName)
+import Network.Socket (ServiceName)
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite.Schema (createSchema)
-import Simplex.Messaging.Agent.Transmission
-import Simplex.Messaging.Protocol (MsgBody)
+import Simplex.Messaging.Parsers (blobFieldParser)
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Util (liftIOEither)
+import Simplex.Messaging.Util (bshow, liftIOEither)
 import System.Exit (ExitCode (ExitFailure), exitWith)
 import System.FilePath (takeDirectory)
 import Text.Read (readMaybe)
@@ -72,79 +78,185 @@ createSQLiteStore dbFilePath = do
 connectSQLiteStore :: MonadUnliftIO m => FilePath -> m SQLiteStore
 connectSQLiteStore dbFilePath = do
   dbConn <- liftIO $ DB.open dbFilePath
-  liftIO $ DB.execute_ dbConn "PRAGMA foreign_keys = ON;"
+  liftIO $
+    DB.execute_
+      dbConn
+      [sql|
+        PRAGMA foreign_keys = ON;
+        PRAGMA journal_mode = WAL;
+      |]
   return SQLiteStore {dbFilePath, dbConn}
 
+checkDuplicate :: (MonadUnliftIO m, MonadError StoreError m) => IO () -> m ()
+checkDuplicate action = liftIOEither $ first handleError <$> E.try action
+  where
+    handleError :: SQLError -> StoreError
+    handleError e
+      | DB.sqlError e == DB.ErrorConstraint = SEConnDuplicate
+      | otherwise = SEInternal $ bshow e
+
+withTransaction :: forall a. DB.Connection -> IO a -> IO a
+withTransaction db a = loop 100 100_000
+  where
+    loop :: Int -> Int -> IO a
+    loop t tLim =
+      DB.withImmediateTransaction db a `E.catch` \(e :: SQLError) ->
+        if tLim > t && DB.sqlError e == DB.ErrorBusy
+          then do
+            threadDelay t
+            loop (t * 9 `div` 8) (tLim - t)
+          else E.throwIO e
+
 instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where
   createRcvConn :: SQLiteStore -> RcvQueue -> m ()
-  createRcvConn SQLiteStore {dbConn} rcvQueue =
-    liftIO $
-      createRcvQueueAndConn dbConn rcvQueue
+  createRcvConn SQLiteStore {dbConn} q@RcvQueue {server} =
+    checkDuplicate $
+      withTransaction dbConn $ do
+        upsertServer_ dbConn server
+        insertRcvQueue_ dbConn q
+        insertRcvConnection_ dbConn q
 
   createSndConn :: SQLiteStore -> SndQueue -> m ()
-  createSndConn SQLiteStore {dbConn} sndQueue =
-    liftIO $
-      createSndQueueAndConn dbConn sndQueue
+  createSndConn SQLiteStore {dbConn} q@SndQueue {server} =
+    checkDuplicate $
+      withTransaction dbConn $ do
+        upsertServer_ dbConn server
+        insertSndQueue_ dbConn q
+        insertSndConnection_ dbConn q
 
   getConn :: SQLiteStore -> ConnAlias -> m SomeConn
-  getConn SQLiteStore {dbConn} connAlias = do
-    queues <-
-      liftIO $
-        retrieveConnQueues dbConn connAlias
-    case queues of
-      (Just rcvQ, Just sndQ) -> return $ SomeConn SCDuplex (DuplexConnection connAlias rcvQ sndQ)
-      (Just rcvQ, Nothing) -> return $ SomeConn SCRcv (RcvConnection connAlias rcvQ)
-      (Nothing, Just sndQ) -> return $ SomeConn SCSnd (SndConnection connAlias sndQ)
-      _ -> throwError SEBadConn
+  getConn SQLiteStore {dbConn} connAlias =
+    liftIOEither . withTransaction dbConn $
+      getConn_ dbConn connAlias
 
   getAllConnAliases :: SQLiteStore -> m [ConnAlias]
   getAllConnAliases SQLiteStore {dbConn} =
-    liftIO $
-      retrieveAllConnAliases dbConn
+    liftIO $ do
+      r <- DB.query_ dbConn "SELECT conn_alias FROM connections;" :: IO [[ConnAlias]]
+      return (concat r)
 
-  getRcvQueue :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m RcvQueue
-  getRcvQueue SQLiteStore {dbConn} SMPServer {host, port} rcvId = do
-    rcvQueue <-
-      liftIO $
-        retrieveRcvQueue dbConn host port rcvId
-    case rcvQueue of
-      Just rcvQ -> return rcvQ
-      _ -> throwError SENotFound
+  getRcvConn :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m SomeConn
+  getRcvConn SQLiteStore {dbConn} SMPServer {host, port} rcvId =
+    liftIOEither . withTransaction dbConn $
+      DB.queryNamed
+        dbConn
+        [sql|
+          SELECT q.conn_alias
+          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]
+        >>= \case
+          [Only connAlias] -> getConn_ dbConn connAlias
+          _ -> pure $ Left SEConnNotFound
 
   deleteConn :: SQLiteStore -> ConnAlias -> m ()
   deleteConn SQLiteStore {dbConn} connAlias =
     liftIO $
-      deleteConnCascade dbConn connAlias
+      DB.executeNamed
+        dbConn
+        "DELETE FROM connections WHERE conn_alias = :conn_alias;"
+        [":conn_alias" := connAlias]
 
   upgradeRcvConnToDuplex :: SQLiteStore -> ConnAlias -> SndQueue -> m ()
-  upgradeRcvConnToDuplex SQLiteStore {dbConn} connAlias sndQueue =
-    liftIOEither $
-      updateRcvConnWithSndQueue dbConn connAlias sndQueue
+  upgradeRcvConnToDuplex SQLiteStore {dbConn} connAlias sq@SndQueue {server} =
+    liftIOEither . withTransaction dbConn $
+      getConn_ dbConn connAlias >>= \case
+        Right (SomeConn SCRcv (RcvConnection _ _)) -> do
+          upsertServer_ dbConn server
+          insertSndQueue_ dbConn sq
+          updateConnWithSndQueue_ dbConn connAlias sq
+          pure $ Right ()
+        Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+        _ -> pure $ Left SEConnNotFound
 
   upgradeSndConnToDuplex :: SQLiteStore -> ConnAlias -> RcvQueue -> m ()
-  upgradeSndConnToDuplex SQLiteStore {dbConn} connAlias rcvQueue =
-    liftIOEither $
-      updateSndConnWithRcvQueue dbConn connAlias rcvQueue
+  upgradeSndConnToDuplex SQLiteStore {dbConn} connAlias rq@RcvQueue {server} =
+    liftIOEither . withTransaction dbConn $
+      getConn_ dbConn connAlias >>= \case
+        Right (SomeConn SCSnd (SndConnection _ _)) -> do
+          upsertServer_ dbConn server
+          insertRcvQueue_ dbConn rq
+          updateConnWithRcvQueue_ dbConn connAlias rq
+          pure $ Right ()
+        Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c
+        _ -> pure $ Left SEConnNotFound
 
   setRcvQueueStatus :: SQLiteStore -> RcvQueue -> QueueStatus -> m ()
-  setRcvQueueStatus SQLiteStore {dbConn} rcvQueue status =
+  setRcvQueueStatus SQLiteStore {dbConn} RcvQueue {rcvId, server = SMPServer {host, port}} status =
+    -- ? throw error if queue doesn't exist?
     liftIO $
-      updateRcvQueueStatus dbConn rcvQueue status
+      DB.executeNamed
+        dbConn
+        [sql|
+          UPDATE rcv_queues
+          SET status = :status
+          WHERE host = :host AND port = :port AND rcv_id = :rcv_id;
+        |]
+        [":status" := status, ":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId]
+
+  setRcvQueueActive :: SQLiteStore -> RcvQueue -> VerificationKey -> m ()
+  setRcvQueueActive SQLiteStore {dbConn} RcvQueue {rcvId, server = SMPServer {host, port}} verifyKey =
+    -- ? throw error if queue doesn't exist?
+    liftIO $
+      DB.executeNamed
+        dbConn
+        [sql|
+          UPDATE rcv_queues
+          SET verify_key = :verify_key, status = :status
+          WHERE host = :host AND port = :port AND rcv_id = :rcv_id;
+        |]
+        [ ":verify_key" := Just verifyKey,
+          ":status" := Active,
+          ":host" := host,
+          ":port" := serializePort_ port,
+          ":rcv_id" := rcvId
+        ]
 
   setSndQueueStatus :: SQLiteStore -> SndQueue -> QueueStatus -> m ()
-  setSndQueueStatus SQLiteStore {dbConn} sndQueue status =
+  setSndQueueStatus SQLiteStore {dbConn} SndQueue {sndId, server = SMPServer {host, port}} status =
+    -- ? throw error if queue doesn't exist?
     liftIO $
-      updateSndQueueStatus dbConn sndQueue status
+      DB.executeNamed
+        dbConn
+        [sql|
+          UPDATE snd_queues
+          SET status = :status
+          WHERE host = :host AND port = :port AND snd_id = :snd_id;
+        |]
+        [":status" := status, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId]
 
-  createRcvMsg :: SQLiteStore -> ConnAlias -> MsgBody -> InternalTs -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> m InternalId
-  createRcvMsg SQLiteStore {dbConn} connAlias msgBody internalTs (externalSndId, externalSndTs) (brokerId, brokerTs) =
-    liftIOEither $
-      insertRcvMsg dbConn connAlias msgBody internalTs (externalSndId, externalSndTs) (brokerId, brokerTs)
+  updateRcvIds :: SQLiteStore -> RcvQueue -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+  updateRcvIds SQLiteStore {dbConn} RcvQueue {connAlias} =
+    liftIO . withTransaction dbConn $ do
+      (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ dbConn connAlias
+      let internalId = InternalId $ unId lastInternalId + 1
+          internalRcvId = InternalRcvId $ unRcvId lastInternalRcvId + 1
+      updateLastIdsRcv_ dbConn connAlias internalId internalRcvId
+      pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash)
 
-  createSndMsg :: SQLiteStore -> ConnAlias -> MsgBody -> InternalTs -> m InternalId
-  createSndMsg SQLiteStore {dbConn} connAlias msgBody internalTs =
-    liftIOEither $
-      insertSndMsg dbConn connAlias msgBody internalTs
+  createRcvMsg :: SQLiteStore -> RcvQueue -> RcvMsgData -> m ()
+  createRcvMsg SQLiteStore {dbConn} RcvQueue {connAlias} rcvMsgData =
+    liftIO . withTransaction dbConn $ do
+      insertRcvMsgBase_ dbConn connAlias rcvMsgData
+      insertRcvMsgDetails_ dbConn connAlias rcvMsgData
+      updateHashRcv_ dbConn connAlias rcvMsgData
+
+  updateSndIds :: SQLiteStore -> SndQueue -> m (InternalId, InternalSndId, PrevSndMsgHash)
+  updateSndIds SQLiteStore {dbConn} SndQueue {connAlias} =
+    liftIO . withTransaction dbConn $ do
+      (lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ dbConn connAlias
+      let internalId = InternalId $ unId lastInternalId + 1
+          internalSndId = InternalSndId $ unSndId lastInternalSndId + 1
+      updateLastIdsSnd_ dbConn connAlias internalId internalSndId
+      pure (internalId, internalSndId, prevSndHash)
+
+  createSndMsg :: SQLiteStore -> SndQueue -> SndMsgData -> m ()
+  createSndMsg SQLiteStore {dbConn} SndQueue {connAlias} sndMsgData =
+    liftIO . withTransaction dbConn $ do
+      insertSndMsgBase_ dbConn connAlias sndMsgData
+      insertSndMsgDetails_ dbConn connAlias sndMsgData
+      updateHashSnd_ dbConn connAlias sndMsgData
 
   getMsg :: SQLiteStore -> ConnAlias -> InternalId -> m Msg
   getMsg _st _connAlias _id = throwError SENotImplemented
@@ -179,6 +291,10 @@ instance ToField RcvMsgStatus where toField = toField . show
 
 instance ToField SndMsgStatus where toField = toField . show
 
+instance ToField MsgIntegrity where toField = toField . serializeMsgIntegrity
+
+instance FromField MsgIntegrity where fromField = blobFieldParser msgIntegrityP
+
 fromFieldToReadable_ :: forall a. (Read a, E.Typeable a) => Field -> Ok a
 fromFieldToReadable_ = \case
   f@(Field (SQLText t) _) ->
@@ -217,13 +333,6 @@ upsertServer_ dbConn SMPServer {host, port, keyHash} = do
 
 -- * createRcvConn helpers
 
-createRcvQueueAndConn :: DB.Connection -> RcvQueue -> IO ()
-createRcvQueueAndConn dbConn rcvQueue =
-  DB.withTransaction dbConn $ do
-    upsertServer_ dbConn (server (rcvQueue :: RcvQueue))
-    insertRcvQueue_ dbConn rcvQueue
-    insertRcvConnection_ dbConn rcvQueue
-
 insertRcvQueue_ :: DB.Connection -> RcvQueue -> IO ()
 insertRcvQueue_ dbConn RcvQueue {..} = do
   let port_ = serializePort_ $ port server
@@ -255,22 +364,16 @@ insertRcvConnection_ dbConn RcvQueue {server, rcvId, connAlias} = do
     [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_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,:rcv_host,:rcv_port,:rcv_id,     NULL,     NULL,   NULL,
-                            0,                        0,                        0);
+          0, 0, 0, 0, x'', x'');
     |]
     [":conn_alias" := connAlias, ":rcv_host" := host server, ":rcv_port" := port_, ":rcv_id" := rcvId]
 
 -- * createSndConn helpers
 
-createSndQueueAndConn :: DB.Connection -> SndQueue -> IO ()
-createSndQueueAndConn dbConn sndQueue =
-  DB.withTransaction dbConn $ do
-    upsertServer_ dbConn (server (sndQueue :: SndQueue))
-    insertSndQueue_ dbConn sndQueue
-    insertSndConnection_ dbConn sndQueue
-
 insertSndQueue_ :: DB.Connection -> SndQueue -> IO ()
 insertSndQueue_ dbConn SndQueue {..} = do
   let port_ = serializePort_ $ port server
@@ -300,28 +403,25 @@ insertSndConnection_ dbConn SndQueue {server, sndId, connAlias} = do
     [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_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, 0, 0, 0, x'', x'');
     |]
     [":conn_alias" := connAlias, ":snd_host" := host server, ":snd_port" := port_, ":snd_id" := sndId]
 
 -- * getConn helpers
 
-retrieveConnQueues :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue, Maybe SndQueue)
-retrieveConnQueues dbConn connAlias =
-  DB.withTransaction -- Avoid inconsistent state between queue reads
-    dbConn
-    $ retrieveConnQueues_ dbConn connAlias
-
--- Separate transactionless version of retrieveConnQueues to be reused in other functions that already wrap
--- multiple statements in transaction - otherwise they'd be attempting to start a transaction within a transaction
-retrieveConnQueues_ :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue, Maybe SndQueue)
-retrieveConnQueues_ dbConn connAlias = do
-  rcvQ <- retrieveRcvQueueByConnAlias_ dbConn connAlias
-  sndQ <- retrieveSndQueueByConnAlias_ dbConn connAlias
-  return (rcvQ, sndQ)
+getConn_ :: DB.Connection -> ConnAlias -> IO (Either StoreError SomeConn)
+getConn_ dbConn connAlias = do
+  rQ <- retrieveRcvQueueByConnAlias_ dbConn connAlias
+  sQ <- retrieveSndQueueByConnAlias_ dbConn connAlias
+  pure $ case (rQ, sQ) of
+    (Just rcvQ, Just sndQ) -> Right $ SomeConn SCDuplex (DuplexConnection connAlias rcvQ sndQ)
+    (Just rcvQ, Nothing) -> Right $ SomeConn SCRcv (RcvConnection connAlias rcvQ)
+    (Nothing, Just sndQ) -> Right $ SomeConn SCSnd (SndConnection connAlias sndQ)
+    _ -> Left SEConnNotFound
 
 retrieveRcvQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue)
 retrieveRcvQueueByConnAlias_ dbConn connAlias = do
@@ -363,60 +463,8 @@ retrieveSndQueueByConnAlias_ dbConn connAlias = do
       return . Just $ SndQueue srv sndId cAlias sndPrivateKey encryptKey signKey status
     _ -> return Nothing
 
--- * getAllConnAliases helper
-
-retrieveAllConnAliases :: DB.Connection -> IO [ConnAlias]
-retrieveAllConnAliases dbConn = do
-  r <- DB.query_ dbConn "SELECT conn_alias FROM connections;" :: IO [[ConnAlias]]
-  return (concat r)
-
--- * getRcvQueue helper
-
-retrieveRcvQueue :: DB.Connection -> HostName -> Maybe ServiceName -> SMP.RecipientId -> IO (Maybe RcvQueue)
-retrieveRcvQueue dbConn host port rcvId = do
-  r <-
-    DB.queryNamed
-      dbConn
-      [sql|
-        SELECT
-          s.key_hash, q.host, q.port, q.rcv_id, q.conn_alias, q.rcv_private_key,
-          q.snd_id, q.snd_key, q.decrypt_key, q.verify_key, q.status
-        FROM rcv_queues q
-        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
-        WHERE q.host = :host AND q.port = :port AND q.rcv_id = :rcv_id;
-      |]
-      [":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId]
-  case r of
-    [(keyHash, hst, prt, rId, connAlias, rcvPrivateKey, sndId, sndKey, decryptKey, verifyKey, status)] -> do
-      let srv = SMPServer hst (deserializePort_ prt) keyHash
-      return . Just $ RcvQueue srv rId connAlias rcvPrivateKey sndId sndKey decryptKey verifyKey status
-    _ -> return Nothing
-
--- * deleteConn helper
-
-deleteConnCascade :: DB.Connection -> ConnAlias -> IO ()
-deleteConnCascade dbConn connAlias =
-  DB.executeNamed
-    dbConn
-    "DELETE FROM connections WHERE conn_alias = :conn_alias;"
-    [":conn_alias" := connAlias]
-
 -- * upgradeRcvConnToDuplex helpers
 
-updateRcvConnWithSndQueue :: DB.Connection -> ConnAlias -> SndQueue -> IO (Either StoreError ())
-updateRcvConnWithSndQueue dbConn connAlias sndQueue =
-  DB.withTransaction dbConn $ do
-    queues <- retrieveConnQueues_ dbConn connAlias
-    case queues of
-      (Just _rcvQ, Nothing) -> do
-        upsertServer_ dbConn (server (sndQueue :: SndQueue))
-        insertSndQueue_ dbConn sndQueue
-        updateConnWithSndQueue_ dbConn connAlias sndQueue
-        return $ Right ()
-      (Nothing, Just _sndQ) -> return $ Left (SEBadConnType CSnd)
-      (Just _rcvQ, Just _sndQ) -> return $ Left (SEBadConnType CDuplex)
-      _ -> return $ Left SEBadConn
-
 updateConnWithSndQueue_ :: DB.Connection -> ConnAlias -> SndQueue -> IO ()
 updateConnWithSndQueue_ dbConn connAlias SndQueue {server, sndId} = do
   let port_ = serializePort_ $ port server
@@ -431,20 +479,6 @@ updateConnWithSndQueue_ dbConn connAlias SndQueue {server, sndId} = do
 
 -- * upgradeSndConnToDuplex helpers
 
-updateSndConnWithRcvQueue :: DB.Connection -> ConnAlias -> RcvQueue -> IO (Either StoreError ())
-updateSndConnWithRcvQueue dbConn connAlias rcvQueue =
-  DB.withTransaction dbConn $ do
-    queues <- retrieveConnQueues_ dbConn connAlias
-    case queues of
-      (Nothing, Just _sndQ) -> do
-        upsertServer_ dbConn (server (rcvQueue :: RcvQueue))
-        insertRcvQueue_ dbConn rcvQueue
-        updateConnWithRcvQueue_ dbConn connAlias rcvQueue
-        return $ Right ()
-      (Just _rcvQ, Nothing) -> return $ Left (SEBadConnType CRcv)
-      (Just _rcvQ, Just _sndQ) -> return $ Left (SEBadConnType CDuplex)
-      _ -> return $ Left SEBadConn
-
 updateConnWithRcvQueue_ :: DB.Connection -> ConnAlias -> RcvQueue -> IO ()
 updateConnWithRcvQueue_ dbConn connAlias RcvQueue {server, rcvId} = do
   let port_ = serializePort_ $ port server
@@ -457,74 +491,40 @@ updateConnWithRcvQueue_ dbConn connAlias RcvQueue {server, rcvId} = do
     |]
     [":rcv_host" := host server, ":rcv_port" := port_, ":rcv_id" := rcvId, ":conn_alias" := connAlias]
 
--- * setRcvQueueStatus helper
+-- * updateRcvIds helpers
 
--- ? throw error if queue doesn't exist?
-updateRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO ()
-updateRcvQueueStatus dbConn RcvQueue {rcvId, server = SMPServer {host, port}} status =
-  DB.executeNamed
-    dbConn
-    [sql|
-      UPDATE rcv_queues
-      SET status = :status
-      WHERE host = :host AND port = :port AND rcv_id = :rcv_id;
-    |]
-    [":status" := status, ":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId]
-
--- * setSndQueueStatus helper
-
--- ? throw error if queue doesn't exist?
-updateSndQueueStatus :: DB.Connection -> SndQueue -> QueueStatus -> IO ()
-updateSndQueueStatus dbConn SndQueue {sndId, server = SMPServer {host, port}} status =
-  DB.executeNamed
-    dbConn
-    [sql|
-      UPDATE snd_queues
-      SET status = :status
-      WHERE host = :host AND port = :port AND snd_id = :snd_id;
-    |]
-    [":status" := status, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId]
-
--- * createRcvMsg helpers
-
-insertRcvMsg ::
-  DB.Connection ->
-  ConnAlias ->
-  MsgBody ->
-  InternalTs ->
-  (ExternalSndId, ExternalSndTs) ->
-  (BrokerId, BrokerTs) ->
-  IO (Either StoreError InternalId)
-insertRcvMsg dbConn connAlias msgBody internalTs (externalSndId, externalSndTs) (brokerId, brokerTs) =
-  DB.withTransaction dbConn $ do
-    queues <- retrieveConnQueues_ dbConn connAlias
-    case queues of
-      (Just _rcvQ, _) -> do
-        (lastInternalId, lastInternalRcvId) <- retrieveLastInternalIdsRcv_ dbConn connAlias
-        let internalId = InternalId $ unId lastInternalId + 1
-        let internalRcvId = InternalRcvId $ unRcvId lastInternalRcvId + 1
-        insertRcvMsgBase_ dbConn connAlias internalId internalTs internalRcvId msgBody
-        insertRcvMsgDetails_ dbConn connAlias internalRcvId internalId (externalSndId, externalSndTs) (brokerId, brokerTs)
-        updateLastInternalIdsRcv_ dbConn connAlias internalId internalRcvId
-        return $ Right internalId
-      (Nothing, Just _sndQ) -> return $ Left (SEBadConnType CSnd)
-      _ -> return $ Left SEBadConn
-
-retrieveLastInternalIdsRcv_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalRcvId)
-retrieveLastInternalIdsRcv_ dbConn connAlias = do
-  [(lastInternalId, lastInternalRcvId)] <-
+retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
+retrieveLastIdsAndHashRcv_ dbConn connAlias = do
+  [(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)] <-
     DB.queryNamed
       dbConn
       [sql|
-        SELECT last_internal_msg_id, last_internal_rcv_msg_id
+        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;
       |]
       [":conn_alias" := connAlias]
-  return (lastInternalId, lastInternalRcvId)
+  return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)
 
-insertRcvMsgBase_ :: DB.Connection -> ConnAlias -> InternalId -> InternalTs -> InternalRcvId -> MsgBody -> IO ()
-insertRcvMsgBase_ dbConn connAlias internalId internalTs internalRcvId msgBody = do
+updateLastIdsRcv_ :: DB.Connection -> ConnAlias -> InternalId -> InternalRcvId -> IO ()
+updateLastIdsRcv_ dbConn connAlias newInternalId newInternalRcvId =
+  DB.executeNamed
+    dbConn
+    [sql|
+      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;
+    |]
+    [ ":last_internal_msg_id" := newInternalId,
+      ":last_internal_rcv_msg_id" := newInternalRcvId,
+      ":conn_alias" := connAlias
+    ]
+
+-- * createRcvMsg helpers
+
+insertRcvMsgBase_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO ()
+insertRcvMsgBase_ dbConn connAlias RcvMsgData {..} = do
   DB.executeNamed
     dbConn
     [sql|
@@ -540,82 +540,85 @@ insertRcvMsgBase_ dbConn connAlias internalId internalTs internalRcvId msgBody =
       ":body" := decodeUtf8 msgBody
     ]
 
-insertRcvMsgDetails_ ::
-  DB.Connection ->
-  ConnAlias ->
-  InternalRcvId ->
-  InternalId ->
-  (ExternalSndId, ExternalSndTs) ->
-  (BrokerId, BrokerTs) ->
-  IO ()
-insertRcvMsgDetails_ dbConn connAlias internalRcvId internalId (externalSndId, externalSndTs) (brokerId, brokerTs) =
+insertRcvMsgDetails_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO ()
+insertRcvMsgDetails_ dbConn connAlias RcvMsgData {..} =
   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)
+          broker_id, broker_ts, rcv_status, ack_brocker_ts, ack_sender_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);
+         :broker_id,:broker_ts,:rcv_status,           NULL,          NULL,
+         :internal_hash,:external_prev_snd_hash,:integrity);
     |]
     [ ":conn_alias" := connAlias,
       ":internal_rcv_id" := internalRcvId,
       ":internal_id" := internalId,
-      ":external_snd_id" := externalSndId,
-      ":external_snd_ts" := externalSndTs,
-      ":broker_id" := brokerId,
-      ":broker_ts" := brokerTs,
-      ":rcv_status" := Received
+      ":external_snd_id" := fst senderMeta,
+      ":external_snd_ts" := snd senderMeta,
+      ":broker_id" := fst brokerMeta,
+      ":broker_ts" := snd brokerMeta,
+      ":rcv_status" := Received,
+      ":internal_hash" := internalHash,
+      ":external_prev_snd_hash" := externalPrevSndHash,
+      ":integrity" := msgIntegrity
     ]
 
-updateLastInternalIdsRcv_ :: DB.Connection -> ConnAlias -> InternalId -> InternalRcvId -> IO ()
-updateLastInternalIdsRcv_ dbConn connAlias newInternalId newInternalRcvId =
+updateHashRcv_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO ()
+updateHashRcv_ dbConn connAlias RcvMsgData {..} =
+  DB.executeNamed
+    dbConn
+    -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved
+    [sql|
+      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
+        AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id;
+    |]
+    [ ":last_external_snd_msg_id" := fst senderMeta,
+      ":last_rcv_msg_hash" := internalHash,
+      ":conn_alias" := connAlias,
+      ":last_internal_rcv_msg_id" := internalRcvId
+    ]
+
+-- * updateSndIds helpers
+
+retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalSndId, PrevSndMsgHash)
+retrieveLastIdsAndHashSnd_ dbConn connAlias = do
+  [(lastInternalId, lastInternalSndId, lastSndHash)] <-
+    DB.queryNamed
+      dbConn
+      [sql|
+        SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash
+        FROM connections
+        WHERE conn_alias = :conn_alias;
+      |]
+      [":conn_alias" := connAlias]
+  return (lastInternalId, lastInternalSndId, lastSndHash)
+
+updateLastIdsSnd_ :: DB.Connection -> ConnAlias -> InternalId -> InternalSndId -> IO ()
+updateLastIdsSnd_ dbConn connAlias newInternalId newInternalSndId =
   DB.executeNamed
     dbConn
     [sql|
       UPDATE connections
-      SET last_internal_msg_id = :last_internal_msg_id, last_internal_rcv_msg_id = :last_internal_rcv_msg_id
+      SET last_internal_msg_id = :last_internal_msg_id,
+          last_internal_snd_msg_id = :last_internal_snd_msg_id
       WHERE conn_alias = :conn_alias;
     |]
     [ ":last_internal_msg_id" := newInternalId,
-      ":last_internal_rcv_msg_id" := newInternalRcvId,
+      ":last_internal_snd_msg_id" := newInternalSndId,
       ":conn_alias" := connAlias
     ]
 
 -- * createSndMsg helpers
 
-insertSndMsg :: DB.Connection -> ConnAlias -> MsgBody -> InternalTs -> IO (Either StoreError InternalId)
-insertSndMsg dbConn connAlias msgBody internalTs =
-  DB.withTransaction dbConn $ do
-    queues <- retrieveConnQueues_ dbConn connAlias
-    case queues of
-      (_, Just _sndQ) -> do
-        (lastInternalId, lastInternalSndId) <- retrieveLastInternalIdsSnd_ dbConn connAlias
-        let internalId = InternalId $ unId lastInternalId + 1
-        let internalSndId = InternalSndId $ unSndId lastInternalSndId + 1
-        insertSndMsgBase_ dbConn connAlias internalId internalTs internalSndId msgBody
-        insertSndMsgDetails_ dbConn connAlias internalSndId internalId
-        updateLastInternalIdsSnd_ dbConn connAlias internalId internalSndId
-        return $ Right internalId
-      (Just _rcvQ, Nothing) -> return $ Left (SEBadConnType CRcv)
-      _ -> return $ Left SEBadConn
-
-retrieveLastInternalIdsSnd_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalSndId)
-retrieveLastInternalIdsSnd_ dbConn connAlias = do
-  [(lastInternalId, lastInternalSndId)] <-
-    DB.queryNamed
-      dbConn
-      [sql|
-        SELECT last_internal_msg_id, last_internal_snd_msg_id
-        FROM connections
-        WHERE conn_alias = :conn_alias;
-      |]
-      [":conn_alias" := connAlias]
-  return (lastInternalId, lastInternalSndId)
-
-insertSndMsgBase_ :: DB.Connection -> ConnAlias -> InternalId -> InternalTs -> InternalSndId -> MsgBody -> IO ()
-insertSndMsgBase_ dbConn connAlias internalId internalTs internalSndId msgBody = do
+insertSndMsgBase_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO ()
+insertSndMsgBase_ dbConn connAlias SndMsgData {..} = do
   DB.executeNamed
     dbConn
     [sql|
@@ -631,32 +634,35 @@ insertSndMsgBase_ dbConn connAlias internalId internalTs internalSndId msgBody =
       ":body" := decodeUtf8 msgBody
     ]
 
-insertSndMsgDetails_ :: DB.Connection -> ConnAlias -> InternalSndId -> InternalId -> IO ()
-insertSndMsgDetails_ dbConn connAlias internalSndId internalId =
+insertSndMsgDetails_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO ()
+insertSndMsgDetails_ dbConn connAlias SndMsgData {..} =
   DB.executeNamed
     dbConn
     [sql|
       INSERT INTO snd_messages
-        ( conn_alias, internal_snd_id, internal_id, snd_status, sent_ts, delivered_ts)
+        ( conn_alias, internal_snd_id, internal_id, snd_status, sent_ts, delivered_ts, internal_hash)
       VALUES
-        (:conn_alias,:internal_snd_id,:internal_id,:snd_status,    NULL,         NULL);
+        (:conn_alias,:internal_snd_id,:internal_id,:snd_status,    NULL,         NULL,:internal_hash);
     |]
     [ ":conn_alias" := connAlias,
       ":internal_snd_id" := internalSndId,
       ":internal_id" := internalId,
-      ":snd_status" := Created
+      ":snd_status" := Created,
+      ":internal_hash" := internalHash
     ]
 
-updateLastInternalIdsSnd_ :: DB.Connection -> ConnAlias -> InternalId -> InternalSndId -> IO ()
-updateLastInternalIdsSnd_ dbConn connAlias newInternalId newInternalSndId =
+updateHashSnd_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO ()
+updateHashSnd_ dbConn connAlias SndMsgData {..} =
   DB.executeNamed
     dbConn
+    -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved
     [sql|
       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;
+      SET last_snd_msg_hash = :last_snd_msg_hash
+      WHERE conn_alias = :conn_alias
+        AND last_internal_snd_msg_id = :last_internal_snd_msg_id;
     |]
-    [ ":last_internal_msg_id" := newInternalId,
-      ":last_internal_snd_msg_id" := newInternalSndId,
-      ":conn_alias" := connAlias
+    [ ":last_snd_msg_hash" := internalHash,
+      ":conn_alias" := connAlias,
+      ":last_internal_snd_msg_id" := internalSndId
     ]

src/Simplex/Messaging/Agent/Store/SQLite/Schema.hs

@@ -90,6 +90,9 @@ connections =
       last_internal_msg_id INTEGER NOT NULL,
       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)
@@ -135,6 +138,9 @@ rcvMessages =
       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)
@@ -152,6 +158,7 @@ sndMessages =
       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)

src/Simplex/Messaging/Agent/Transmission.hs

@@ -1,437 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
-
-module Simplex.Messaging.Agent.Transmission where
-
-import Control.Applicative ((<|>))
-import Control.Monad.IO.Class
-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.Int (Int64)
-import Data.Kind
-import Data.Time.Clock (UTCTime)
-import Data.Time.ISO8601
-import Data.Type.Equality
-import Data.Typeable ()
-import Network.Socket
-import Numeric.Natural
-import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Parsers
-import Simplex.Messaging.Protocol
-  ( CorrId (..),
-    Encoded,
-    ErrorType,
-    MsgBody,
-    MsgId,
-    SenderPublicKey,
-    errMessageBody,
-  )
-import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Util
-import System.IO
-import Text.Read
-import UnliftIO.Exception
-
-type ARawTransmission = (ByteString, ByteString, ByteString)
-
-type ATransmission p = (CorrId, ConnAlias, ACommand p)
-
-type ATransmissionOrError p = (CorrId, ConnAlias, Either AgentErrorType (ACommand p))
-
-data AParty = Agent | Client
-  deriving (Eq, Show)
-
-data SAParty :: AParty -> Type where
-  SAgent :: SAParty Agent
-  SClient :: SAParty Client
-
-deriving instance Show (SAParty p)
-
-deriving instance Eq (SAParty p)
-
-instance TestEquality SAParty where
-  testEquality SAgent SAgent = Just Refl
-  testEquality SClient SClient = Just Refl
-  testEquality _ _ = Nothing
-
-data ACmd = forall p. ACmd (SAParty p) (ACommand p)
-
-deriving instance Show ACmd
-
-data ACommand (p :: AParty) where
-  NEW :: SMPServer -> ACommand Client -- response INV
-  INV :: SMPQueueInfo -> ACommand Agent
-  JOIN :: SMPQueueInfo -> ReplyMode -> ACommand Client -- response OK
-  CON :: ACommand Agent -- notification that connection is established
-  -- TODO currently it automatically allows whoever sends the confirmation
-  -- CONF :: OtherPartyId -> ACommand Agent
-  -- LET :: OtherPartyId -> ACommand Client
-  SUB :: ACommand Client
-  SUBALL :: ACommand Client -- TODO should be moved to chat protocol - hack for subscribing to all
-  END :: ACommand Agent
-  -- QST :: QueueDirection -> ACommand Client
-  -- STAT :: QueueDirection -> Maybe QueueStatus -> Maybe SubMode -> ACommand Agent
-  SEND :: MsgBody -> ACommand Client
-  SENT :: AgentMsgId -> ACommand Agent
-  MSG ::
-    { m_recipient :: (AgentMsgId, UTCTime),
-      m_broker :: (MsgId, UTCTime),
-      m_sender :: (AgentMsgId, UTCTime),
-      m_status :: MsgStatus,
-      m_body :: MsgBody
-    } ->
-    ACommand Agent
-  -- ACK :: AgentMsgId -> ACommand Client
-  -- RCVD :: AgentMsgId -> ACommand Agent
-  OFF :: ACommand Client
-  DEL :: ACommand Client
-  OK :: ACommand Agent
-  ERR :: AgentErrorType -> ACommand Agent
-
-deriving instance Eq (ACommand p)
-
-deriving instance Show (ACommand p)
-
-type Message = ByteString
-
-data SMPMessage
-  = SMPConfirmation SenderPublicKey
-  | SMPMessage
-      { senderMsgId :: AgentMsgId,
-        senderTimestamp :: SenderTimestamp,
-        previousMsgHash :: ByteString,
-        agentMessage :: AMessage
-      }
-  deriving (Show)
-
-data AMessage where
-  HELLO :: VerificationKey -> AckMode -> AMessage
-  REPLY :: SMPQueueInfo -> AMessage
-  A_MSG :: MsgBody -> AMessage
-  deriving (Show)
-
-parseSMPMessage :: ByteString -> Either AgentErrorType SMPMessage
-parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ SYNTAX errBadMessage
-  where
-    smpMessageP :: Parser SMPMessage
-    smpMessageP =
-      smpConfirmationP <* A.endOfLine
-        <|> A.endOfLine *> smpClientMessageP
-
-    smpConfirmationP :: Parser SMPMessage
-    smpConfirmationP = SMPConfirmation <$> ("KEY " *> C.pubKeyP <* A.endOfLine)
-
-    smpClientMessageP :: Parser SMPMessage
-    smpClientMessageP =
-      SMPMessage
-        <$> A.decimal <* A.space
-        <*> tsISO8601P <* A.space
-        <*> base64P <* A.endOfLine
-        <*> agentMessageP
-
-serializeSMPMessage :: SMPMessage -> ByteString
-serializeSMPMessage = \case
-  SMPConfirmation sKey -> smpMessage ("KEY " <> C.serializePubKey sKey) "" ""
-  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 [B.pack $ show msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash]
-    smpMessage smpHeader aHeader aBody = B.intercalate "\n" [smpHeader, aHeader, aBody, ""]
-
-agentMessageP :: Parser AMessage
-agentMessageP =
-  "HELLO " *> hello
-    <|> "REPLY " *> reply
-    <|> "MSG " *> a_msg
-  where
-    hello = HELLO <$> C.pubKeyP <*> ackMode
-    reply = REPLY <$> smpQueueInfoP
-    a_msg = do
-      size :: Int <- A.decimal
-      A_MSG <$> (A.endOfLine *> A.take size <* A.endOfLine)
-    ackMode = " NO_ACK" $> AckMode Off <|> pure (AckMode On)
-
-smpQueueInfoP :: Parser SMPQueueInfo
-smpQueueInfoP =
-  "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.pubKeyP)
-
-smpServerP :: Parser SMPServer
-smpServerP = SMPServer <$> server <*> port <*> msgHash
-  where
-    server = B.unpack <$> A.takeTill (A.inClass ":# ")
-    port = A.char ':' *> (Just . show <$> (A.decimal :: Parser Int)) <|> pure Nothing
-    msgHash = A.char '#' *> (Just <$> base64P) <|> pure Nothing
-
-parseAgentMessage :: ByteString -> Either AgentErrorType AMessage
-parseAgentMessage = parse agentMessageP $ SYNTAX errBadMessage
-
-serializeAgentMessage :: AMessage -> ByteString
-serializeAgentMessage = \case
-  HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else ""
-  REPLY qInfo -> "REPLY " <> serializeSmpQueueInfo qInfo
-  A_MSG body -> "MSG " <> serializeMsg body <> "\n"
-
-serializeSmpQueueInfo :: SMPQueueInfo -> ByteString
-serializeSmpQueueInfo (SMPQueueInfo srv qId ek) =
-  B.intercalate "::" ["smp", serializeServer srv, encode qId, C.serializePubKey ek]
-
-serializeServer :: SMPServer -> ByteString
-serializeServer SMPServer {host, port, keyHash} =
-  B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack) keyHash
-
-data SMPServer = SMPServer
-  { host :: HostName,
-    port :: Maybe ServiceName,
-    keyHash :: Maybe KeyHash
-  }
-  deriving (Eq, Ord, Show)
-
-type KeyHash = Encoded
-
-type ConnAlias = ByteString
-
-type OtherPartyId = Encoded
-
-data Mode = On | Off deriving (Eq, Show, Read)
-
-newtype AckMode = AckMode Mode deriving (Eq, Show)
-
-data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId EncryptionKey
-  deriving (Eq, Show)
-
-data ReplyMode = ReplyOff | ReplyOn | ReplyVia SMPServer deriving (Eq, Show)
-
-type EncryptionKey = C.PublicKey
-
-type DecryptionKey = C.PrivateKey
-
-type SignatureKey = C.PrivateKey
-
-type VerificationKey = C.PublicKey
-
-data QueueDirection = SND | RCV deriving (Show)
-
-data QueueStatus = New | Confirmed | Secured | Active | Disabled
-  deriving (Eq, Show, Read)
-
-type AgentMsgId = Int64
-
-type SenderTimestamp = UTCTime
-
-data MsgStatus = MsgOk | MsgError MsgErrorType
-  deriving (Eq, Show)
-
-data MsgErrorType = MsgSkipped AgentMsgId AgentMsgId | MsgBadId AgentMsgId | MsgBadHash
-  deriving (Eq, Show)
-
-data AgentErrorType
-  = UNKNOWN
-  | PROHIBITED
-  | SYNTAX Int
-  | BROKER Natural
-  | SMP ErrorType
-  | CRYPTO C.CryptoError
-  | SIZE
-  | STORE
-  | INTERNAL -- etc. TODO SYNTAX Natural
-  deriving (Eq, Show, Exception)
-
-data AckStatus = AckOk | AckError AckErrorType
-  deriving (Show)
-
-data AckErrorType = AckUnknown | AckProhibited | AckSyntax Int -- etc.
-  deriving (Show)
-
-errBadEncoding :: Int
-errBadEncoding = 10
-
-errBadCommand :: Int
-errBadCommand = 11
-
-errBadInvitation :: Int
-errBadInvitation = 12
-
-errNoConnAlias :: Int
-errNoConnAlias = 13
-
-errBadMessage :: Int
-errBadMessage = 14
-
-errBadServer :: Int
-errBadServer = 15
-
-smpErrTCPConnection :: Natural
-smpErrTCPConnection = 1
-
-smpErrCorrelationId :: Natural
-smpErrCorrelationId = 2
-
-smpUnexpectedResponse :: Natural
-smpUnexpectedResponse = 3
-
-commandP :: Parser ACmd
-commandP =
-  "NEW " *> newCmd
-    <|> "INV " *> invResp
-    <|> "JOIN " *> joinCmd
-    <|> "SUB" $> ACmd SClient SUB
-    <|> "SUBALL" $> ACmd SClient SUBALL -- TODO remove - hack for subscribing to all
-    <|> "END" $> ACmd SAgent END
-    <|> "SEND " *> sendCmd
-    <|> "SENT " *> sentResp
-    <|> "MSG " *> message
-    <|> "OFF" $> ACmd SClient OFF
-    <|> "DEL" $> ACmd SClient DEL
-    <|> "ERR " *> agentError
-    <|> "CON" $> ACmd SAgent CON
-    <|> "OK" $> ACmd SAgent OK
-  where
-    newCmd = ACmd SClient . NEW <$> smpServerP
-    invResp = ACmd SAgent . INV <$> smpQueueInfoP
-    joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <*> replyMode)
-    sendCmd = ACmd SClient . SEND <$> A.takeByteString
-    sentResp = ACmd SAgent . SENT <$> A.decimal
-    message = do
-      m_status <- status <* A.space
-      m_recipient <- "R=" *> partyMeta A.decimal
-      m_broker <- "B=" *> partyMeta base64P
-      m_sender <- "S=" *> partyMeta A.decimal
-      m_body <- A.takeByteString
-      return $ ACmd SAgent MSG {m_recipient, m_broker, m_sender, m_status, m_body}
-    -- TODO other error types
-    agentError = ACmd SAgent . ERR <$> ("SMP " *> smpErrorType)
-    smpErrorType = "AUTH" $> SMP SMP.AUTH
-    replyMode =
-      " NO_REPLY" $> ReplyOff
-        <|> A.space *> (ReplyVia <$> smpServerP)
-        <|> pure ReplyOn
-    partyMeta idParser = (,) <$> idParser <* "," <*> tsISO8601P <* A.space
-    status = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> msgErrorType)
-    msgErrorType =
-      "ID " *> (MsgBadId <$> A.decimal)
-        <|> "NO_ID " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal)
-        <|> "HASH" $> MsgBadHash
-
-parseCommand :: ByteString -> Either AgentErrorType ACmd
-parseCommand = parse commandP $ SYNTAX errBadCommand
-
-serializeCommand :: ACommand p -> ByteString
-serializeCommand = \case
-  NEW srv -> "NEW " <> serializeServer srv
-  INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo
-  JOIN qInfo rMode -> "JOIN " <> serializeSmpQueueInfo qInfo <> replyMode rMode
-  SUB -> "SUB"
-  SUBALL -> "SUBALL" -- TODO remove - hack for subscribing to all
-  END -> "END"
-  SEND msgBody -> "SEND " <> serializeMsg msgBody
-  SENT mId -> "SENT " <> bshow mId
-  MSG {m_recipient = (rmId, rTs), m_broker = (bmId, bTs), m_sender = (smId, sTs), m_status, m_body} ->
-    B.unwords
-      [ "MSG",
-        msgStatus m_status,
-        "R=" <> bshow rmId <> "," <> showTs rTs,
-        "B=" <> encode bmId <> "," <> showTs bTs,
-        "S=" <> bshow smId <> "," <> showTs sTs,
-        serializeMsg m_body
-      ]
-  OFF -> "OFF"
-  DEL -> "DEL"
-  CON -> "CON"
-  ERR e -> "ERR " <> B.pack (show e)
-  OK -> "OK"
-  where
-    replyMode :: ReplyMode -> ByteString
-    replyMode = \case
-      ReplyOff -> " NO_REPLY"
-      ReplyVia srv -> " " <> serializeServer srv
-      ReplyOn -> ""
-    showTs :: UTCTime -> ByteString
-    showTs = B.pack . formatISO8601Millis
-    msgStatus :: MsgStatus -> ByteString
-    msgStatus = \case
-      MsgOk -> "OK"
-      MsgError e ->
-        "ERR" <> case e of
-          MsgSkipped fromMsgId toMsgId ->
-            B.unwords ["NO_ID", B.pack $ show fromMsgId, B.pack $ show toMsgId]
-          MsgBadId aMsgId -> "ID " <> B.pack (show aMsgId)
-          MsgBadHash -> "HASH"
-
--- TODO - save function as in the server Transmission - re-use?
-serializeMsg :: ByteString -> ByteString
-serializeMsg body = B.pack (show $ B.length body) <> "\n" <> body
-
-tPutRaw :: Handle -> ARawTransmission -> IO ()
-tPutRaw h (corrId, connAlias, command) = do
-  putLn h corrId
-  putLn h connAlias
-  putLn h command
-
-tGetRaw :: Handle -> IO ARawTransmission
-tGetRaw h = (,,) <$> getLn h <*> getLn h <*> getLn h
-
-tPut :: MonadIO m => Handle -> ATransmission p -> m ()
-tPut h (CorrId corrId, connAlias, command) =
-  liftIO $ tPutRaw h (corrId, connAlias, serializeCommand command)
-
--- | get client and agent transmissions
-tGet :: forall m p. MonadIO m => SAParty p -> Handle -> m (ATransmissionOrError p)
-tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
-  where
-    tParseLoadBody :: ARawTransmission -> m (ATransmissionOrError p)
-    tParseLoadBody t@(corrId, connAlias, command) = do
-      let cmd = parseCommand command >>= fromParty >>= tConnAlias t
-      fullCmd <- either (return . Left) cmdWithMsgBody cmd
-      return (CorrId corrId, connAlias, fullCmd)
-
-    fromParty :: ACmd -> Either AgentErrorType (ACommand p)
-    fromParty (ACmd (p :: p1) cmd) = case testEquality party p of
-      Just Refl -> Right cmd
-      _ -> Left PROHIBITED
-
-    tConnAlias :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p)
-    tConnAlias (_, connAlias, _) cmd = case cmd of
-      -- NEW and JOIN have optional connAlias
-      NEW _ -> Right cmd
-      JOIN _ _ -> Right cmd
-      -- ERROR response does not always have connAlias
-      ERR _ -> Right cmd
-      -- other responses must have connAlias
-      _
-        | B.null connAlias -> Left $ SYNTAX errNoConnAlias
-        | otherwise -> Right cmd
-
-    cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p))
-    cmdWithMsgBody = \case
-      SEND body -> SEND <$$> getMsgBody body
-      MSG agentMsgId srvTS agentTS status body -> MSG agentMsgId srvTS agentTS status <$$> getMsgBody body
-      cmd -> return $ Right cmd
-
-    -- TODO refactor with server
-    getMsgBody :: MsgBody -> m (Either AgentErrorType MsgBody)
-    getMsgBody msgBody =
-      case B.unpack msgBody of
-        ':' : body -> return . Right $ B.pack body
-        str -> case readMaybe str :: Maybe Int of
-          Just size -> liftIO $ do
-            body <- B.hGet h size
-            s <- getLn h
-            return $ if B.null s then Right body else Left SIZE
-          Nothing -> return . Left $ SYNTAX errMessageBody

src/Simplex/Messaging/Client.hs

@@ -1,24 +1,43 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
+-- |
+-- Module      : Simplex.Messaging.Client
+-- Copyright   : (c) simplex.chat
+-- License     : AGPL-3
+--
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : non-portable
+--
+-- This module provides a functional client API for SMP protocol.
+--
+-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
 module Simplex.Messaging.Client
-  ( SMPClient,
+  ( -- * Connect (disconnect) client to (from) SMP server
+    SMPClient (blockSize),
     getSMPClient,
     closeSMPClient,
+
+    -- * SMP protocol command functions
     createSMPQueue,
     subscribeSMPQueue,
     secureSMPQueue,
     sendSMPMessage,
     ackSMPMessage,
-    sendSMPCommand,
     suspendSMPQueue,
     deleteSMPQueue,
+    sendSMPCommand,
+
+    -- * Supporting types and client configuration
     SMPClientError (..),
     SMPClientConfig (..),
     smpDefaultConfig,
@@ -33,153 +52,199 @@ import Control.Exception
 import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
-import qualified Crypto.PubKey.RSA.Types as RSA
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe
-import GHC.IO.Exception (IOErrorType (..))
 import Network.Socket (ServiceName)
 import Numeric.Natural
-import Simplex.Messaging.Agent.Transmission (SMPServer (..))
+import Simplex.Messaging.Agent.Protocol (SMPServer (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Transport
-import Simplex.Messaging.Util (liftEitherError, raceAny_)
-import System.IO
-import System.IO.Error
+import Simplex.Messaging.Transport (ATransport (..), TCP, THandle (..), TProxy, Transport (..), TransportError, clientHandshake, runTransportClient)
+import Simplex.Messaging.Transport.WebSockets (WS)
+import Simplex.Messaging.Util (bshow, liftError, raceAny_)
 import System.Timeout
 
+-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
+--
+-- The only exported selector is blockSize that is negotiated
+-- with the server during the TCP transport handshake.
+--
+-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
 data SMPClient = SMPClient
   { action :: Async (),
     connected :: TVar Bool,
     smpServer :: SMPServer,
+    tcpTimeout :: Int,
     clientCorrId :: TVar Natural,
     sentCommands :: TVar (Map CorrId Request),
     sndQ :: TBQueue SignedRawTransmission,
     rcvQ :: TBQueue SignedTransmissionOrError,
-    msgQ :: TBQueue SMPServerTransmission
+    msgQ :: TBQueue SMPServerTransmission,
+    blockSize :: Int
   }
 
+-- | Type synonym for transmission from some SPM server queue.
 type SMPServerTransmission = (SMPServer, RecipientId, Command 'Broker)
 
+-- | SMP client configuration.
 data SMPClientConfig = SMPClientConfig
-  { qSize :: Natural,
-    defaultPort :: ServiceName,
+  { -- | size of TBQueue to use for server commands and responses
+    qSize :: Natural,
+    -- | default SMP server port if port is not specified in SMPServer
+    defaultTransport :: (ServiceName, ATransport),
+    -- | timeout of TCP commands (microseconds)
     tcpTimeout :: Int,
+    -- | period for SMP ping commands (microseconds)
     smpPing :: Int,
-    blockSize :: Int,
+    -- | estimated maximum size of SMP command excluding message body,
+    -- determines the maximum allowed message size
     smpCommandSize :: Int
   }
 
+-- | Default SMP client configuration.
 smpDefaultConfig :: SMPClientConfig
 smpDefaultConfig =
   SMPClientConfig
     { qSize = 16,
-      defaultPort = "5223",
-      tcpTimeout = 2_000_000,
+      defaultTransport = ("5223", transport @TCP),
+      tcpTimeout = 4_000_000,
       smpPing = 30_000_000,
-      blockSize = 8_192, -- 16_384,
       smpCommandSize = 256
     }
 
 data Request = Request
   { queueId :: QueueId,
-    responseVar :: TMVar (Either SMPClientError Cmd)
+    responseVar :: TMVar Response
   }
 
-getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO SMPClient
-getSMPClient
-  smpServer@SMPServer {host, port}
-  SMPClientConfig {qSize, defaultPort, tcpTimeout, smpPing}
-  msgQ
-  disconnected = do
-    c <- atomically mkSMPClient
-    started <- newEmptyTMVarIO
-    action <-
-      async $
-        runTCPClient host (fromMaybe defaultPort port) (client c started)
-          `finally` atomically (putTMVar started False)
-    tcpTimeout `timeout` atomically (takeTMVar started) >>= \case
-      Just True -> return c {action}
-      _ -> throwIO err
-    where
-      err :: IOException
-      err = mkIOError TimeExpired "connection timeout" Nothing Nothing
+type Response = Either SMPClientError Cmd
 
-      mkSMPClient :: STM SMPClient
-      mkSMPClient = do
-        connected <- newTVar False
-        clientCorrId <- newTVar 0
-        sentCommands <- newTVar M.empty
-        sndQ <- newTBQueue qSize
-        rcvQ <- newTBQueue qSize
-        return
-          SMPClient
-            { action = undefined,
-              connected,
-              smpServer,
-              clientCorrId,
-              sentCommands,
-              sndQ,
-              rcvQ,
-              msgQ
-            }
+-- | Connects to 'SMPServer' using passed client configuration
+-- and queue for messages and notifications.
+--
+-- 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} msgQ disconnected =
+  atomically mkSMPClient >>= runClient useTransport
+  where
+    mkSMPClient :: STM SMPClient
+    mkSMPClient = do
+      connected <- newTVar False
+      clientCorrId <- newTVar 0
+      sentCommands <- newTVar M.empty
+      sndQ <- newTBQueue qSize
+      rcvQ <- newTBQueue qSize
+      return
+        SMPClient
+          { action = undefined,
+            blockSize = undefined,
+            connected,
+            smpServer,
+            tcpTimeout,
+            clientCorrId,
+            sentCommands,
+            sndQ,
+            rcvQ,
+            msgQ
+          }
 
-      client :: SMPClient -> TMVar Bool -> Handle -> IO ()
-      client c started h = do
-        _ <- getLn h -- "Welcome to SMP"
-        atomically $ do
-          modifyTVar (connected c) (const True)
-          putTMVar started True
-        raceAny_ [send c h, process c, receive c h, ping c]
-          `finally` disconnected
+    runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
+    runClient (port', ATransport t) c = do
+      thVar <- newEmptyTMVarIO
+      action <-
+        async $
+          runTransportClient (host smpServer) port' (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}
+        Just (Left e) -> Left e
+        Nothing -> Left SMPNetworkError
 
-      send :: SMPClient -> Handle -> IO ()
-      send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
+    useTransport :: (ServiceName, ATransport)
+    useTransport = case port smpServer of
+      Nothing -> defaultTransport cfg
+      Just "80" -> ("80", transport @WS)
+      Just p -> (p, transport @TCP)
 
-      receive :: SMPClient -> Handle -> IO ()
-      receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ
+    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
+    client _ c thVar h =
+      runExceptT (clientHandshake h $ keyHash smpServer) >>= \case
+        Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
+        Right th -> 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]
+            `finally` disconnected
 
-      ping :: SMPClient -> IO ()
-      ping c = forever $ do
-        threadDelay smpPing
-        runExceptT $ sendSMPCommand c Nothing "" (Cmd SSender PING)
+    send :: Transport c => SMPClient -> THandle c -> IO ()
+    send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h
 
-      process :: SMPClient -> IO ()
-      process SMPClient {rcvQ, sentCommands} = forever $ do
-        (_, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
-        cs <- readTVarIO sentCommands
-        case M.lookup corrId cs of
-          Nothing -> do
-            case respOrErr of
-              Right (Cmd SBroker cmd) -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd)
-              -- TODO send everything else to errQ and log in agent
-              _ -> return ()
-          Just Request {queueId, responseVar} -> atomically $ do
-            modifyTVar sentCommands $ M.delete corrId
-            putTMVar responseVar $
-              if queueId == qId
-                then case respOrErr of
-                  Left e -> Left $ SMPResponseError e
-                  Right (Cmd _ (ERR e)) -> Left $ SMPServerError e
-                  Right r -> Right r
-                else Left SMPQueueIdError
+    receive :: Transport c => SMPClient -> THandle c -> IO ()
+    receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ
 
+    ping :: SMPClient -> IO ()
+    ping c = forever $ do
+      threadDelay smpPing
+      runExceptT $ sendSMPCommand c Nothing "" (Cmd SSender PING)
+
+    process :: SMPClient -> IO ()
+    process SMPClient {rcvQ, sentCommands} = forever $ do
+      (_, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
+      cs <- readTVarIO sentCommands
+      case M.lookup corrId cs of
+        Nothing -> do
+          case respOrErr of
+            Right (Cmd SBroker cmd) -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd)
+            -- TODO send everything else to errQ and log in agent
+            _ -> return ()
+        Just Request {queueId, responseVar} -> atomically $ do
+          modifyTVar sentCommands $ M.delete corrId
+          putTMVar responseVar $
+            if queueId == qId
+              then case respOrErr of
+                Left e -> Left $ SMPResponseError e
+                Right (Cmd _ (ERR e)) -> Left $ SMPServerError e
+                Right r -> Right r
+              else Left SMPUnexpectedResponse
+
+-- | Disconnects SMP client from the server and terminates client threads.
 closeSMPClient :: SMPClient -> IO ()
 closeSMPClient = uninterruptibleCancel . action
 
+-- | SMP client error type.
 data SMPClientError
-  = SMPServerError ErrorType
-  | SMPResponseError ErrorType
-  | SMPQueueIdError
-  | SMPUnexpectedResponse
-  | SMPResponseTimeout
-  | SMPCryptoError RSA.Error
-  | SMPClientError
+  = -- | Correctly parsed SMP server ERR response.
+    -- This error is forwarded to the agent client as `ERR SMP err`.
+    SMPServerError ErrorType
+  | -- | Invalid server response that failed to parse.
+    -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
+    SMPResponseError ErrorType
+  | -- | Different response from what is expected to a certain SMP command,
+    -- e.g. server should respond `IDS` or `ERR` to `NEW` command,
+    -- other responses would result in this error.
+    -- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
+    SMPUnexpectedResponse
+  | -- | Used for TCP connection and command response timeouts.
+    -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
+    SMPResponseTimeout
+  | -- | Failure to establish TCP connection.
+    -- Forwarded to the agent client as `ERR BROKER NETWORK`.
+    SMPNetworkError
+  | -- | TCP transport handshake or some other transport error.
+    -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
+    SMPTransportError TransportError
+  | -- | Error when cryptographically "signing" the command.
+    SMPSignatureError C.CryptoError
   deriving (Eq, Show, Exception)
 
+-- | Create a new SMP queue.
+--
+-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
 createSMPQueue ::
   SMPClient ->
   RecipientPrivateKey ->
@@ -191,6 +256,9 @@ createSMPQueue c rpKey rKey =
     Cmd _ (IDS rId sId) -> return (rId, sId)
     _ -> 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 c@SMPClient {smpServer, msgQ} rpKey rId =
   sendSMPCommand c (Just rpKey) rId (Cmd SRecipient SUB) >>= \case
@@ -199,15 +267,24 @@ subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =
       lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
     _ -> throwE SMPUnexpectedResponse
 
+-- | 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
 
+-- | 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 c spKey sId msg =
   sendSMPCommand c spKey sId (Cmd SSender $ SEND msg) >>= \case
     Cmd _ OK -> return ()
     _ -> 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 c@SMPClient {smpServer, msgQ} rpKey rId =
   sendSMPCommand c (Just rpKey) rId (Cmd SRecipient ACK) >>= \case
@@ -216,20 +293,28 @@ ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =
       lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd)
     _ -> throwE SMPUnexpectedResponse
 
+-- | Irreversibly suspend SMP queue.
+-- 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
 
+-- | 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
 
-okSMPCommand :: Cmd -> SMPClient -> C.PrivateKey -> QueueId -> ExceptT SMPClientError IO ()
+okSMPCommand :: Cmd -> SMPClient -> C.SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
 okSMPCommand cmd c pKey qId =
   sendSMPCommand c (Just pKey) qId cmd >>= \case
     Cmd _ OK -> return ()
     _ -> throwE SMPUnexpectedResponse
 
-sendSMPCommand :: SMPClient -> Maybe C.PrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd
-sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId} pKey qId cmd = do
+-- | 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
   corrId <- lift_ getNextCorrId
   t <- signTransmission $ serializeTransmission (corrId, qId, cmd)
   ExceptT $ sendRecv corrId t
@@ -239,22 +324,23 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId} pKey qId cmd = do
 
     getNextCorrId :: STM CorrId
     getNextCorrId = do
-      i <- (+ 1) <$> readTVar clientCorrId
-      writeTVar clientCorrId i
-      return . CorrId . B.pack $ show i
+      i <- stateTVar clientCorrId $ \i -> (i, i + 1)
+      pure . CorrId $ bshow i
 
     signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission
     signTransmission t = case pKey of
       Nothing -> return ("", t)
       Just pk -> do
-        sig <- liftEitherError SMPCryptoError $ C.sign pk t
+        sig <- liftError SMPSignatureError $ C.sign pk t
         return (sig, t)
 
     -- two separate "atomically" needed to avoid blocking
-    sendRecv :: CorrId -> SignedRawTransmission -> IO (Either SMPClientError Cmd)
-    sendRecv corrId t = atomically (send corrId t) >>= atomically . takeTMVar
+    sendRecv :: CorrId -> SignedRawTransmission -> 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 (Either SMPClientError Cmd))
+    send :: CorrId -> SignedRawTransmission -> STM (TMVar Response)
     send corrId t = do
       r <- newEmptyTMVar
       modifyTVar sentCommands . M.insert corrId $ Request qId r

src/Simplex/Messaging/Crypto.hs

@@ -1,26 +1,78 @@
 {-# 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  : [email protected]
+-- 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
-  ( PrivateKey (..),
+  ( -- * RSA keys
+    PrivateKey (rsaPrivateKey),
+    SafePrivateKey, -- constructor is not exported
+    FullPrivateKey (..),
     PublicKey (..),
-    Signature (..),
-    CryptoError (..),
+    SafeKeyPair,
+    FullKeyPair,
+    KeyHash (..),
     generateKeyPair,
-    sign,
-    verify,
+    publicKey,
+    publicKeySize,
+    validKeySize,
+    safePrivateKey,
+
+    -- * 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,
-    parsePrivKey,
-    parsePubKey,
+    encodePubKey,
+    publicKeyHash,
     privKeyP,
     pubKeyP,
+    binaryPubKeyP,
+
+    -- * SHA256 hash
+    sha256Hash,
+
+    -- * Cryptography error type
+    CryptoError (..),
   )
 where
 
@@ -30,75 +82,114 @@ import Control.Monad.Trans.Except
 import Crypto.Cipher.AES (AES256)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Error as CE
-import Crypto.Hash.Algorithms (SHA256 (..))
+import Crypto.Hash (Digest, SHA256 (..), hash)
 import Crypto.Number.Generate (generateMax)
 import Crypto.Number.Prime (findPrimeFrom)
-import Crypto.Number.Serialize (i2osp, os2ip)
 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 (first)
+import Data.Bifunctor (bimap, first)
 import qualified Data.ByteArray as BA
-import Data.ByteString.Base64
+import Data.ByteString.Base64 (decode, encode)
 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 Database.SQLite.Simple as DB
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.Internal (Field (..))
-import Database.SQLite.Simple.Ok (Ok (Ok))
+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)
-import Simplex.Messaging.Util (bshow, liftEitherError, (<$$>))
+import Simplex.Messaging.Parsers (base64P, blobFieldParser, parseAll, parseString)
+import Simplex.Messaging.Util (liftEitherError, (<$?>))
 
+-- | A newtype of 'Crypto.PubKey.RSA.PublicKey'.
 newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show)
 
-data PrivateKey = PrivateKey
-  { private_size :: Int,
-    private_n :: Integer,
-    private_d :: Integer
-  }
-  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)
 
-instance ToField PrivateKey where toField = toField . serializePrivKey
+-- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (with PublicKey inside).
+newtype FullPrivateKey = FullPrivateKey {unPrivateKey :: R.PrivateKey} deriving (Eq, Show)
 
-instance ToField PublicKey where toField = toField . serializePubKey
+-- | Type-class used for both private key types: SafePrivateKey and FullPrivateKey.
+class PrivateKey k where
+  -- unwraps 'Crypto.PubKey.RSA.PrivateKey'
+  rsaPrivateKey :: k -> R.PrivateKey
 
-instance FromField PrivateKey where
-  fromField f@(Field (SQLBlob b) _) =
-    case parsePrivKey b of
-      Right k -> Ok k
-      Left e -> returnError ConversionFailed f ("couldn't parse PrivateKey field: " ++ e)
-  fromField f = returnError ConversionFailed f "expecting SQLBlob column type"
+  -- equivalent to data type constructor, not exported
+  _privateKey :: R.PrivateKey -> k
 
-instance FromField PublicKey where
-  fromField f@(Field (SQLBlob b) _) =
-    case parsePubKey b of
-      Right k -> Ok k
-      Left e -> returnError ConversionFailed f ("couldn't parse PublicKey field: " ++ e)
-  fromField f = returnError ConversionFailed f "expecting SQLBlob column type"
+  -- smart constructor removing public key from SafePrivateKey but keeping it in FullPrivateKey
+  mkPrivateKey :: R.PrivateKey -> k
 
-type KeyPair = (PublicKey, PrivateKey)
+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)
 
+instance PrivateKey FullPrivateKey where
+  rsaPrivateKey = unPrivateKey
+  _privateKey = FullPrivateKey
+  mkPrivateKey = FullPrivateKey
+
+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 PublicKey where toField = toField . encodePubKey
+
+instance FromField SafePrivateKey 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
 
-newtype Verified = Verified ByteString deriving (Show)
-
+-- | Various cryptographic or related errors.
 data CryptoError
-  = CryptoRSAError R.Error
-  | CryptoCipherError CE.CryptoError
-  | CryptoIVError
-  | CryptoDecryptError
-  | CryptoLargeMsgError
-  | CryptoHeaderError String
+  = -- | 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
@@ -110,19 +201,34 @@ aesKeySize = 256 `div` 8
 authTagSize :: Int
 authTagSize = 128 `div` 8
 
-generateKeyPair :: Int -> IO KeyPair
+-- | 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
-    privateKey s n d = PrivateKey {private_size = s, private_n = n, private_d = d}
     loop = do
-      (pub, priv) <- R.generate size =<< publicExponent
-      let s = R.public_size pub
-          n = R.public_n pub
-          d = R.private_d priv
-       in if d * d < n
-            then loop
-            else return (PublicKey pub, privateKey s n d)
+      (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
+  512 -> True
+  _ -> False
 
 data Header = Header
   { aesKey :: Key,
@@ -131,56 +237,99 @@ data Header = Header
     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 <- Key <$> A.take aesKeySize
-  ivBytes <- IV <$> A.take (ivSize @AES256)
+  aesKey <- aesKeyP
+  ivBytes <- ivP
   authTag <- bsToAuthTag <$> A.take authTagSize
   msgSize <- fromIntegral . decodeWord32 <$> A.take 4
   return Header {aesKey, ivBytes, authTag, msgSize}
 
-parseHeader :: ByteString -> Either CryptoError Header
-parseHeader = first CryptoHeaderError . A.parseOnly (headerP <* A.endOfInput)
+-- | 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 <- Key <$> randomBytes aesKeySize
-  ivBytes <- IV <$> randomBytes (ivSize @AES256)
+  aesKey <- liftIO randomAesKey
+  ivBytes <- liftIO randomIV
+  (authTag, msg') <- encryptAES aesKey ivBytes paddedSize msg
+  let header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg}
+  encHeader <- encryptOAEP k $ serializeHeader header
+  return $ encHeader <> msg'
+
+-- | 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
-  let (authTag, msg'') = encryptAES aead msg'
-      header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg}
-  encHeader <- encryptOAEP k $ serializeHeader header
-  return $ encHeader <> msg''
+  return $ AES.aeadSimpleEncrypt aead B.empty msg' authTagSize
   where
     len = B.length msg
     paddedMsg
       | len >= paddedSize = throwE CryptoLargeMsgError
       | otherwise = return (msg <> B.replicate (paddedSize - len) '#')
 
-decrypt :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString
-decrypt pk msg'' = do
-  let (encHeader, msg') = B.splitAt (private_size pk) msg''
-  header <- decryptOAEP pk encHeader
-  Header {aesKey, ivBytes, authTag, msgSize} <- ExceptT . return $ parseHeader header
+-- | 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
-  msg <- decryptAES aead msg' authTag
-  return $ B.take msgSize msg
-
-encryptAES :: AES.AEAD AES256 -> ByteString -> (AES.AuthTag, ByteString)
-encryptAES aead plaintext = AES.aeadSimpleEncrypt aead B.empty plaintext authTagSize
-
-decryptAES :: AES.AEAD AES256 -> ByteString -> AES.AuthTag -> ExceptT CryptoError IO ByteString
-decryptAES aead ciphertext authTag =
-  maybeError CryptoDecryptError $ AES.aeadSimpleDecrypt aead B.empty ciphertext authTag
+  maybeError 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
@@ -189,94 +338,146 @@ initAEAD (Key aesKey) (IV ivBytes) = 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
 
-randomBytes :: Int -> ExceptT CryptoError IO ByteString
-randomBytes n = ExceptT $ Right <$> getRandomBytes n
-
 maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a
 maybeError e = maybe (throwE e) return
 
+-- | 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 CryptoCipherError . CE.eitherCryptoError
+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 CryptoRSAError $
+  liftEitherError RSAEncryptError $
     OAEP.encrypt oaepParams k aesKey
 
-decryptOAEP :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString
+-- | 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 CryptoRSAError $
+  liftEitherError RSADecryptError $
     OAEP.decryptSafer oaepParams (rsaPrivateKey pk) encKey
 
 pssParams :: PSS.PSSParams SHA256 ByteString ByteString
 pssParams = PSS.defaultPSSParams SHA256
 
-sign :: PrivateKey -> ByteString -> IO (Either R.Error Signature)
-sign pk msg = Signature <$$> PSS.signSafer pssParams (rsaPrivateKey pk) msg
+-- | 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 (PublicKey k) = serializeKey_ (R.public_size k, R.public_n k, R.public_e k)
+serializePubKey = ("rsa:" <>) . encode . encodePubKey
 
-serializePrivKey :: PrivateKey -> ByteString
-serializePrivKey pk = serializeKey_ (private_size pk, private_n pk, private_d pk)
-
-serializeKey_ :: (Int, Integer, Integer) -> ByteString
-serializeKey_ (size, n, ex) = bshow size <> "," <> encInt n <> "," <> encInt ex
-  where
-    encInt = encode . i2osp
+-- | 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 = do
-  (public_size, public_n, public_e) <- keyParser_
-  return . PublicKey $ R.PublicKey {R.public_size, R.public_n, R.public_e}
+pubKeyP = decodePubKey <$?> ("rsa:" *> base64P)
 
-privKeyP :: Parser PrivateKey
-privKeyP = do
-  (private_size, private_n, private_d) <- keyParser_
-  return PrivateKey {private_size, private_n, private_d}
+-- Binary X509 RSA public key parser.
+binaryPubKeyP :: Parser PublicKey
+binaryPubKeyP = decodePubKey <$?> A.takeByteString
 
-parsePubKey :: ByteString -> Either String PublicKey
-parsePubKey = A.parseOnly (pubKeyP <* A.endOfInput)
+-- Base-64 PKCS8 RSA private key parser.
+privKeyP :: PrivateKey k => Parser k
+privKeyP = decodePrivKey <$?> ("rsa:" *> base64P)
 
-parsePrivKey :: ByteString -> Either String PrivateKey
-parsePrivKey = A.parseOnly (privKeyP <* A.endOfInput)
+-- Binary PKCS8 RSA private key parser.
+binaryPrivKeyP :: PrivateKey k => Parser k
+binaryPrivKeyP = decodePrivKey <$?> A.takeByteString
 
-keyParser_ :: Parser (Int, Integer, Integer)
-keyParser_ = (,,) <$> (A.decimal <* ",") <*> (intP <* ",") <*> intP
-  where
-    intP = os2ip <$> base64P
+-- | Construct 'SafePrivateKey' from three numbers - used internally and in the tests.
+safePrivateKey :: (Int, Integer, Integer) -> SafePrivateKey
+safePrivateKey = SafePrivateKey . safeRsaPrivateKey
 
-rsaPrivateKey :: PrivateKey -> R.PrivateKey
-rsaPrivateKey pk =
+safeRsaPrivateKey :: (Int, Integer, Integer) -> R.PrivateKey
+safeRsaPrivateKey (size, n, d) =
   R.PrivateKey
-    { R.private_pub =
+    { private_pub =
         R.PublicKey
-          { R.public_size = private_size pk,
-            R.public_n = private_n pk,
-            R.public_e = undefined
+          { public_size = size,
+            public_n = n,
+            public_e = 0
           },
-      R.private_d = private_d pk,
-      R.private_p = 0,
-      R.private_q = 0,
-      R.private_dP = undefined,
-      R.private_dQ = undefined,
-      R.private_qinv = undefined
+      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"
+  _ -> Left "more than one key"

src/Simplex/Messaging/Parsers.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Simplex.Messaging.Parsers where
 
 import Data.Attoparsec.ByteString.Char8 (Parser)
@@ -9,15 +12,51 @@ import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
 import Data.Time.Clock (UTCTime)
 import Data.Time.ISO8601 (parseISO8601)
+import Data.Typeable (Typeable)
+import Database.SQLite.Simple (ResultError (..), SQLData (..))
+import Database.SQLite.Simple.FromField (FieldParser, returnError)
+import Database.SQLite.Simple.Internal (Field (..))
+import Database.SQLite.Simple.Ok (Ok (Ok))
+import Simplex.Messaging.Util ((<$?>))
+import Text.Read (readMaybe)
 
 base64P :: Parser ByteString
-base64P = do
+base64P = decode <$?> base64StringP
+
+base64StringP :: Parser ByteString
+base64StringP = do
   str <- A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
   pad <- A.takeWhile (== '=')
-  either fail pure $ decode (str <> pad)
+  pure $ str <> pad
 
 tsISO8601P :: Parser UTCTime
 tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill (== ' ')
 
 parse :: Parser a -> e -> (ByteString -> Either e a)
-parse parser err = first (const err) . A.parseOnly (parser <* A.endOfInput)
+parse parser err = first (const err) . parseAll parser
+
+parseAll :: Parser a -> (ByteString -> Either String a)
+parseAll parser = A.parseOnly (parser <* A.endOfInput)
+
+parseRead :: Read a => Parser ByteString -> Parser a
+parseRead = (>>= maybe (fail "cannot read") pure . readMaybe . B.unpack)
+
+parseRead1 :: Read a => Parser a
+parseRead1 = parseRead $ A.takeTill (== ' ')
+
+parseRead2 :: Read a => Parser a
+parseRead2 = parseRead $ do
+  w1 <- A.takeTill (== ' ') <* A.char ' '
+  w2 <- A.takeTill (== ' ')
+  pure $ w1 <> " " <> w2
+
+parseString :: (ByteString -> Either String a) -> (String -> a)
+parseString p = either error id . p . B.pack
+
+blobFieldParser :: Typeable k => Parser k -> FieldParser k
+blobFieldParser p = \case
+  f@(Field (SQLBlob b) _) ->
+    case parseAll p 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

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -9,11 +10,62 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
-module Simplex.Messaging.Protocol where
+-- |
+-- Module      : Simplex.Messaging.Protocol
+-- Copyright   : (c) simplex.chat
+-- License     : AGPL-3
+--
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : non-portable
+--
+-- Types, parsers, serializers and functions to send and receive SMP protocol commands and responses.
+--
+-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
+module Simplex.Messaging.Protocol
+  ( -- * SMP protocol types
+    Command (..),
+    Party (..),
+    Cmd (..),
+    SParty (..),
+    ErrorType (..),
+    CommandError (..),
+    Transmission,
+    SignedTransmission,
+    SignedTransmissionOrError,
+    RawTransmission,
+    SignedRawTransmission,
+    CorrId (..),
+    QueueId,
+    RecipientId,
+    SenderId,
+    RecipientPrivateKey,
+    RecipientPublicKey,
+    SenderPrivateKey,
+    SenderPublicKey,
+    Encoded,
+    MsgId,
+    MsgBody,
+
+    -- * Parse and serialize
+    serializeTransmission,
+    serializeCommand,
+    serializeErrorType,
+    transmissionP,
+    commandP,
+    errorTypeP,
+
+    -- * TCP transport functions
+    tPut,
+    tGet,
+    fromClient,
+    fromServer,
+  )
+where
 
 import Control.Applicative ((<|>))
 import Control.Monad
-import Control.Monad.IO.Class
+import Control.Monad.Except
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Base64
@@ -24,16 +76,19 @@ import Data.Kind
 import Data.String
 import Data.Time.Clock
 import Data.Time.ISO8601
+import GHC.Generics (Generic)
+import Generic.Random (genericArbitraryU)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Parsers
-import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport (THandle, Transport, TransportError (..), tGetEncrypted, tPutEncrypted)
 import Simplex.Messaging.Util
-import System.IO
-import Text.Read
+import Test.QuickCheck (Arbitrary (..))
 
+-- | SMP protocol participants.
 data Party = Broker | Recipient | Sender
   deriving (Show)
 
+-- | Singleton types for SMP protocol participants.
 data SParty :: Party -> Type where
   SBroker :: SParty Broker
   SRecipient :: SParty Recipient
@@ -41,28 +96,38 @@ data SParty :: Party -> Type where
 
 deriving instance Show (SParty a)
 
+-- | Type for command or response of any participant.
 data Cmd = forall a. Cmd (SParty a) (Command a)
 
 deriving instance Show Cmd
 
+-- | SMP transmission without signature.
 type Transmission = (CorrId, QueueId, Cmd)
 
+-- | SMP transmission with signature.
 type SignedTransmission = (C.Signature, Transmission)
 
 type TransmissionOrError = (CorrId, QueueId, Either ErrorType Cmd)
 
+-- | signed parsed transmission, with parsing error.
 type SignedTransmissionOrError = (C.Signature, TransmissionOrError)
 
+-- | unparsed SMP transmission with signature.
 type RawTransmission = (ByteString, ByteString, ByteString, ByteString)
 
+-- | unparsed SMP transmission with signature.
 type SignedRawTransmission = (C.Signature, ByteString)
 
+-- | SMP queue ID for the recipient.
 type RecipientId = QueueId
 
+-- | SMP queue ID for the sender.
 type SenderId = QueueId
 
+-- | SMP queue ID on the server.
 type QueueId = Encoded
 
+-- | Parameterized type for SMP protocol commands from all participants.
 data Command (a :: Party) where
   -- SMP recipient commands
   NEW :: RecipientPublicKey -> Command Recipient
@@ -86,48 +151,87 @@ deriving instance Show (Command a)
 
 deriving instance Eq (Command a)
 
+-- | Base-64 encoded string.
 type Encoded = ByteString
 
--- newtype to avoid accidentally changing order of transmission parts
+-- | 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
 
--- only used by Agent, kept here so its definition is close to respective public key
-type RecipientPrivateKey = C.PrivateKey
+-- | 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
 
+-- | Recipient's public key used by SMP server to verify authorization of SMP commands.
 type RecipientPublicKey = C.PublicKey
 
--- only used by Agent, kept here so its definition is close to respective public key
-type SenderPrivateKey = C.PrivateKey
+-- | 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
 
+-- | Sender's public key used by SMP server to verify authorization of SMP commands.
 type SenderPublicKey = C.PublicKey
 
+-- | SMP message server ID.
 type MsgId = Encoded
 
+-- | SMP message body.
 type MsgBody = ByteString
 
-data ErrorType = PROHIBITED | SYNTAX Int | SIZE | AUTH | INTERNAL | DUPLICATE deriving (Show, Eq)
+-- | Type for protocol errors.
+data ErrorType
+  = -- | incorrect block format, encoding or signature size
+    BLOCK
+  | -- | SMP command is unknown or has invalid syntax
+    CMD CommandError
+  | -- | command authorization error - bad signature or non-existing SMP queue
+    AUTH
+  | -- | ACK command is sent without message to be acknowledged
+    NO_MSG
+  | -- | internal server error
+    INTERNAL
+  | -- | used internally, never returned by the server (to be removed)
+    DUPLICATE_ -- TODO remove, not part of SMP protocol
+  deriving (Eq, Generic, Read, Show)
 
-errBadTransmission :: Int
-errBadTransmission = 1
+-- | 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
+  | -- | error parsing command
+    SYNTAX
+  | -- | transmission has no required credentials (signature or queue ID)
+    NO_AUTH
+  | -- | transmission has credentials that are not allowed for this command
+    HAS_AUTH
+  | -- | transmission has no required queue ID
+    NO_QUEUE
+  deriving (Eq, Generic, Read, Show)
 
-errBadSMPCommand :: Int
-errBadSMPCommand = 2
+instance Arbitrary ErrorType where arbitrary = genericArbitraryU
 
-errNoCredentials :: Int
-errNoCredentials = 3
+instance Arbitrary CommandError where arbitrary = genericArbitraryU
 
-errHasCredentials :: Int
-errHasCredentials = 4
-
-errNoQueueId :: Int
-errNoQueueId = 5
-
-errMessageBody :: Int
-errMessageBody = 6
+-- | SMP transmission parser.
+transmissionP :: Parser RawTransmission
+transmissionP = do
+  signature <- segment
+  corrId <- segment
+  queueId <- segment
+  command <- A.takeByteString
+  return (signature, corrId, queueId, command)
+  where
+    segment = A.takeTill (== ' ') <* " "
 
+-- | SMP command parser.
 commandP :: Parser Cmd
 commandP =
   "NEW " *> newCmd
@@ -148,132 +252,127 @@ commandP =
     newCmd = Cmd SRecipient . NEW <$> C.pubKeyP
     idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P)
     keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP
-    sendCmd = Cmd SSender . SEND <$> A.takeWhile A.isDigit
+    sendCmd = do
+      size <- A.decimal <* A.space
+      Cmd SSender . SEND <$> A.take size <* A.space
     message = do
       msgId <- base64P <* A.space
       ts <- tsISO8601P <* A.space
-      Cmd SBroker . MSG msgId ts <$> A.takeWhile A.isDigit
-    serverError = Cmd SBroker . ERR <$> errorType
-    errorType =
-      "PROHIBITED" $> PROHIBITED
-        <|> "SYNTAX " *> (SYNTAX <$> A.decimal)
-        <|> "SIZE" $> SIZE
-        <|> "AUTH" $> AUTH
-        <|> "INTERNAL" $> INTERNAL
+      size <- A.decimal <* A.space
+      Cmd SBroker . MSG msgId ts <$> A.take size <* A.space
+    serverError = Cmd SBroker . ERR <$> errorTypeP
 
+-- TODO ignore the end of block, no need to parse it
+
+-- | Parse SMP command.
 parseCommand :: ByteString -> Either ErrorType Cmd
-parseCommand = parse commandP $ SYNTAX errBadSMPCommand
+parseCommand = parse (commandP <* " " <* A.takeByteString) $ CMD SYNTAX
 
+-- | 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 -> B.pack $ show cmd
-  Cmd SSender (SEND msgBody) -> "SEND" <> serializeMsg msgBody
+  Cmd SRecipient cmd -> bshow cmd
+  Cmd SSender (SEND msgBody) -> "SEND " <> serializeMsg msgBody
   Cmd SSender PING -> "PING"
   Cmd SBroker (MSG msgId ts msgBody) ->
-    B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts] <> serializeMsg msgBody
+    B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, serializeMsg msgBody]
   Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId]
-  Cmd SBroker (ERR err) -> "ERR " <> B.pack (show err)
-  Cmd SBroker resp -> B.pack $ show resp
+  Cmd SBroker (ERR err) -> "ERR " <> serializeErrorType err
+  Cmd SBroker resp -> bshow resp
   where
-    serializeMsg msgBody = " " <> B.pack (show $ B.length msgBody) <> "\r\n" <> msgBody
+    serializeMsg msgBody = bshow (B.length msgBody) <> " " <> msgBody <> " "
 
-tPutRaw :: Handle -> RawTransmission -> IO ()
-tPutRaw h (signature, corrId, queueId, command) = do
-  putLn h signature
-  putLn h corrId
-  putLn h queueId
-  putLn h command
+-- | SMP error parser.
+errorTypeP :: Parser ErrorType
+errorTypeP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
 
-tGetRaw :: Handle -> IO RawTransmission
-tGetRaw h = do
-  signature <- getLn h
-  corrId <- getLn h
-  queueId <- getLn h
-  command <- getLn h
-  return (signature, corrId, queueId, command)
+-- | Serialize SMP error.
+serializeErrorType :: ErrorType -> ByteString
+serializeErrorType = bshow
 
-tPut :: Handle -> SignedRawTransmission -> IO ()
-tPut h (C.Signature sig, t) = do
-  putLn h $ encode sig
-  putLn h t
+-- | 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 <> " "
 
+-- | Serialize SMP transmission.
 serializeTransmission :: Transmission -> ByteString
 serializeTransmission (CorrId corrId, queueId, command) =
-  B.intercalate "\r\n" [corrId, encode queueId, serializeCommand command]
+  B.intercalate " " [corrId, encode queueId, serializeCommand command]
 
+-- | 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 PROHIBITED
+  Cmd SBroker _ -> Left $ CMD PROHIBITED
   cmd -> Right cmd
 
+-- | 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 PROHIBITED
+  _ -> Left $ CMD PROHIBITED
 
--- | get client and server transmissions
--- `fromParty` is used to limit allowed senders - `fromClient` or `fromServer` should be used
-tGet :: forall m. MonadIO m => (Cmd -> Either ErrorType Cmd) -> Handle -> m SignedTransmissionOrError
-tGet fromParty h = do
-  (signature, corrId, queueId, command) <- liftIO $ tGetRaw h
-  let decodedTransmission = liftM2 (,corrId,,command) (decode signature) (decode queueId)
-  either (const $ tError corrId) tParseLoadBody decodedTransmission
+-- | Receive and parse transmission from the TCP transport.
+tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
+tGetParse th = (>>= parse transmissionP TEBadBlock) <$> tGetEncrypted 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
   where
-    tError :: ByteString -> m SignedTransmissionOrError
-    tError corrId = return (C.Signature B.empty, (CorrId corrId, B.empty, Left $ SYNTAX errBadTransmission))
+    decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError
+    decodeParseValidate = \case
+      Right (signature, corrId, queueId, command) ->
+        let decodedTransmission = liftM2 (,corrId,,command) (validSig =<< decode signature) (decode queueId)
+         in either (const $ tError corrId) tParseValidate decodedTransmission
+      Left _ -> tError ""
 
-    tParseLoadBody :: RawTransmission -> m SignedTransmissionOrError
-    tParseLoadBody t@(sig, corrId, queueId, command) = do
+    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
-      fullCmd <- either (return . Left) cmdWithMsgBody cmd
-      return (C.Signature sig, (CorrId corrId, queueId, fullCmd))
+      return (C.Signature sig, (CorrId corrId, queueId, cmd))
 
     tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd
     tCredentials (signature, _, queueId, _) cmd = case cmd of
-      -- IDS response should not have queue ID
+      -- 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 should not have queue ID
+      -- PONG response must not have queue ID
       Cmd SBroker PONG
         | B.null queueId -> Right cmd
-        | otherwise -> Left $ SYNTAX errHasCredentials
+        | otherwise -> Left $ CMD HAS_AUTH
       -- other responses must have queue ID
       Cmd SBroker _
-        | B.null queueId -> Left $ SYNTAX errNoQueueId
+        | B.null queueId -> Left $ CMD NO_QUEUE
         | otherwise -> Right cmd
-      -- NEW must NOT have signature or queue ID
+      -- NEW must have signature but NOT queue ID
       Cmd SRecipient (NEW _)
-        | B.null signature -> Left $ SYNTAX errNoCredentials
-        | not (B.null queueId) -> Left $ SYNTAX errHasCredentials
+        | 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 $ SYNTAX errNoQueueId
+        | 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 $ SYNTAX errHasCredentials
+        | otherwise -> Left $ CMD HAS_AUTH
       -- other client commands must have both signature and queue ID
       Cmd SRecipient _
-        | B.null signature || B.null queueId -> Left $ SYNTAX errNoCredentials
+        | B.null signature || B.null queueId -> Left $ CMD NO_AUTH
         | otherwise -> Right cmd
-
-    cmdWithMsgBody :: Cmd -> m (Either ErrorType Cmd)
-    cmdWithMsgBody = \case
-      Cmd SSender (SEND sizeStr) ->
-        Cmd SSender . SEND <$$> getMsgBody sizeStr
-      Cmd SBroker (MSG msgId ts sizeStr) ->
-        Cmd SBroker . MSG msgId ts <$$> getMsgBody sizeStr
-      cmd -> return $ Right cmd
-
-    getMsgBody :: MsgBody -> m (Either ErrorType MsgBody)
-    getMsgBody sizeStr = case readMaybe (B.unpack sizeStr) :: Maybe Int of
-      Just size -> liftIO $ do
-        body <- B.hGet h size
-        s <- getLn h
-        return $ if B.null s then Right body else Left SIZE
-      Nothing -> return $ Left INTERNAL

src/Simplex/Messaging/Server.hs

@@ -10,11 +10,24 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
--- TODO move randomBytes to another module
-module Simplex.Messaging.Server (runSMPServer, randomBytes) where
+-- |
+-- Module      : Simplex.Messaging.Server
+-- Copyright   : (c) simplex.chat
+-- License     : AGPL-3
+--
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : non-portable
+--
+-- This module defines SMP protocol server with in-memory persistence
+-- and optional append only log of SMP queue records.
+--
+-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
+module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking) where
 
 import Control.Concurrent.STM (stateTVar)
 import Control.Monad
+import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
@@ -23,6 +36,7 @@ import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import qualified Data.Map.Strict as M
 import Data.Time.Clock
+import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Env.STM
@@ -30,25 +44,41 @@ import Simplex.Messaging.Server.MsgStore
 import Simplex.Messaging.Server.MsgStore.STM (MsgQueue)
 import Simplex.Messaging.Server.QueueStore
 import Simplex.Messaging.Server.QueueStore.STM (QueueStore)
+import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Util
-import UnliftIO.Async
 import UnliftIO.Concurrent
 import UnliftIO.Exception
 import UnliftIO.IO
 import UnliftIO.STM
 
+-- | Runs an SMP server using passed configuration.
+--
+-- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
 runSMPServer :: (MonadRandom m, MonadUnliftIO m) => ServerConfig -> m ()
-runSMPServer cfg@ServerConfig {tcpPort} = do
+runSMPServer cfg = do
+  started <- newEmptyTMVarIO
+  runSMPServerBlocking started cfg
+
+-- | Runs an SMP server using passed configuration with signalling.
+--
+-- 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).
+runSMPServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m ()
+runSMPServerBlocking started cfg@ServerConfig {transports} = do
   env <- newEnv cfg
   runReaderT smpServer env
   where
-    smpServer :: (MonadUnliftIO m, MonadReader Env m) => m ()
+    smpServer :: (MonadUnliftIO m', MonadReader Env m') => m' ()
     smpServer = do
       s <- asks server
-      race_ (runTCPServer tcpPort runClient) (serverThread s)
+      raceAny_ (serverThread s : map runServer transports)
+        `finally` withLog closeStoreLog
 
-    serverThread :: MonadUnliftIO m => Server -> m ()
+    runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()
+    runServer (tcpPort, ATransport t) = runTransportServer started tcpPort (runClient t)
+
+    serverThread :: MonadUnliftIO m' => Server -> m' ()
     serverThread Server {subscribedQ, subscribers} = forever . atomically $ do
       (rId, clnt) <- readTBQueue subscribedQ
       cs <- readTVar subscribers
@@ -57,13 +87,19 @@ runSMPServer cfg@ServerConfig {tcpPort} = do
         Nothing -> return ()
       writeTVar subscribers $ M.insert rId clnt cs
 
-runClient :: (MonadUnliftIO m, MonadReader Env m) => Handle -> m ()
-runClient h = do
-  liftIO $ putLn h "Welcome to SMP v0.2.0"
+runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()
+runClient _ h = do
+  keyPair <- asks serverKeyPair
+  liftIO (runExceptT $ serverHandshake h keyPair) >>= \case
+    Right th -> runClientTransport th
+    Left _ -> pure ()
+
+runClientTransport :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> m ()
+runClientTransport th = do
   q <- asks $ tbqSize . config
   c <- atomically $ newClient q
   s <- asks server
-  raceAny_ [send h c, client c s, receive h c]
+  raceAny_ [send th c, client c s, receive th c]
     `finally` cancelSubscribers c
 
 cancelSubscribers :: MonadUnliftIO m => Client -> m ()
@@ -75,7 +111,7 @@ cancelSub = \case
   Sub {subThread = SubThread t} -> killThread t
   _ -> return ()
 
-receive :: (MonadUnliftIO m, MonadReader Env m) => Handle -> Client -> m ()
+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
@@ -83,7 +119,7 @@ receive h Client {rcvQ} = forever $ do
     Right cmd -> verifyTransmission (signature, (corrId, queueId, cmd))
   atomically $ writeTBQueue rcvQ t
 
-send :: MonadUnliftIO m => Handle -> Client -> m ()
+send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
 send h Client {sndQ} = forever $ do
   t <- atomically $ readTBQueue sndQ
   liftIO $ tPut h ("", serializeTransmission t)
@@ -95,27 +131,46 @@ verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => SignedTr
 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) -> return $ verifySignature k
-    Cmd SRecipient _ -> withQueueRec SRecipient $ verifySignature . recipientKey
-    Cmd SSender (SEND _) -> withQueueRec SSender $ verifySend sig . senderKey
+    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
   where
-    withQueueRec :: SParty (p :: Party) -> (QueueRec -> Cmd) -> m Cmd
-    withQueueRec party f = do
+    verifyCmd :: SParty p -> (QueueRec -> Cmd) -> m Cmd
+    verifyCmd party f = do
       st <- asks queueStore
-      qr <- atomically $ getQueue st party queueId
-      return $ either smpErr f qr
+      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 C.verify key sig (serializeTransmission t)
-        then cmd
-        else authErr
-
-    smpErr e = Cmd SBroker $ ERR e
+    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
+        512 -> dummyKey512
+        _ -> dummyKey256
+    sigLen = B.length $ C.unSignature sig
+
+-- 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"
+
+dummyKey512 :: C.PublicKey
+dummyKey512 = "MIICoDANBgkqhkiG9w0BAQEFAAOCAo0AMIICiAKCAgEArkCY9DuverJ4mmzDektv9aZMFyeRV46WZK9NsOBKEc+1ncqMs+LhLti9asKNgUBRbNzmbOe0NYYftrUpwnATaenggkTFxxbJ4JGJuGYbsEdFWkXSvrbWGtM8YUmn5RkAGme12xQ89bSM4VoJAGnrYPHwmcQd+KYCPZvTUsxaxgrJTX65ejHN9BsAn8XtGViOtHTDJO9yUMD2WrJvd7wnNa+0ugEteDLzMU++xS98VC+uA1vfauUqi3yXVchdfrLdVUuM+JE0gUEXCgzjuHkaoHiaGNiGhdPYoAJJdOKQOIHAKdk7Th6OPhirPhc9XYNB4O8JDthKhNtfokvFIFlC4QBRzJhpLIENaEBDt08WmgpOnecZB/CuxkqqOrNa8j5K5jNrtXAI67W46VEC2jeQy/gZwb64Zit2A4D00xXzGbQTPGj4ehcEMhLx5LSCygViEf0w0tN3c3TEyUcgPzvECd2ZVpQLr9Z4a07Ebr+YSuxcHhjg4Rg1VyJyOTTvaCBGm5X2B3+tI4NUttmikIHOYpBnsLmHY2BgfH2KcrIsDyAhInXmTFr/L2+erFarUnlfATd2L8Ti43TNHDedO6k6jI5Gyi62yPwjqPLEIIK8l+pIeNfHJ3pPmjhHBfzFcQLMMMXffHWNK8kWklrQXK+4j4HiPcTBvlO1FEtG9nEIZhUCgYA4a6WtI2k5YNli1C89GY5rGUY7RP71T6RWri/D3Lz9T7GvU+FemAyYmsvCQwqijUOur0uLvwSP8VdxpSUcrjJJSWur2hrPWzWlu0XbNaeizxpFeKbQP+zSrWJ1z8RwfAeUjShxt8q1TuqGqY10wQyp3nyiTGvS+KwZVj5h5qx8NQ=="
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
 client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
@@ -137,33 +192,58 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
           NEW rKey -> createQueue st rKey
           SUB -> subscribeQueue queueId
           ACK -> acknowledgeMsg
-          KEY sKey -> okResp <$> atomically (secureQueue st queueId sKey)
-          OFF -> okResp <$> atomically (suspendQueue st queueId)
+          KEY sKey -> secureQueue_ st sKey
+          OFF -> suspendQueue_ st
           DEL -> delQueueAndMsgs st
       where
         createQueue :: QueueStore -> RecipientPublicKey -> m Transmission
         createQueue st rKey =
-          mkResp corrId B.empty <$> addSubscribe
+          checkKeySize rKey addSubscribe
           where
             addSubscribe =
               addQueueRetry 3 >>= \case
                 Left e -> return $ ERR e
-                Right (rId, sId) -> subscribeQueue rId $> IDS rId sId
+                Right (rId, sId) -> 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 DUPLICATE_ -> addQueueRetry $ n - 1
                 Left e -> return $ Left e
                 Right _ -> return $ Right ids
 
+            logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
+            logCreateById s rId =
+              atomically (getQueue st SRecipient rId) >>= \case
+                Right q -> logCreateQueue s q
+                _ -> pure ()
+
             getIds :: m (RecipientId, SenderId)
             getIds = do
               n <- asks $ queueIdBytes . config
               liftM2 (,) (randomId n) (randomId n)
 
+        secureQueue_ :: QueueStore -> SenderPublicKey -> m Transmission
+        secureQueue_ st sKey = do
+          withLog $ \s -> logSecureQueue s queueId sKey
+          atomically . checkKeySize sKey $ 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
+
+        suspendQueue_ :: QueueStore -> m Transmission
+        suspendQueue_ st = do
+          withLog (`logDeleteQueue` queueId)
+          okResp <$> atomically (suspendQueue st queueId)
+
         subscribeQueue :: RecipientId -> m Transmission
         subscribeQueue rId =
           atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId
@@ -190,7 +270,7 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
           atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s))
             >>= \case
               Just (Just s) -> deliverMessage tryDelPeekMsg queueId s
-              _ -> return $ err PROHIBITED
+              _ -> return $ err NO_MSG
 
         withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a)
         withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId
@@ -250,6 +330,7 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
 
         delQueueAndMsgs :: QueueStore -> m Transmission
         delQueueAndMsgs st = do
+          withLog (`logDeleteQueue` queueId)
           ms <- asks msgStore
           atomically $
             deleteQueue st queueId >>= \case
@@ -268,6 +349,11 @@ client clnt@Client {subscriptions, rcvQ, sndQ} Server {subscribedQ} =
         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 n = do
   gVar <- asks idsDrg

src/Simplex/Messaging/Server/Env/STM.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Server.Env.STM where
 
@@ -10,16 +12,24 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Network.Socket (ServiceName)
 import Numeric.Natural
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.MsgStore.STM
+import Simplex.Messaging.Server.QueueStore (QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
+import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.Transport (ATransport)
+import System.IO (IOMode (..))
 import UnliftIO.STM
 
 data ServerConfig = ServerConfig
-  { tcpPort :: ServiceName,
+  { transports :: [(ServiceName, ATransport)],
     tbqSize :: Natural,
     queueIdBytes :: Int,
-    msgIdBytes :: Int
+    msgIdBytes :: Int,
+    storeLog :: Maybe (StoreLog 'ReadMode),
+    serverPrivateKey :: C.FullPrivateKey
+    -- serverId :: ByteString
   }
 
 data Env = Env
@@ -27,7 +37,9 @@ data Env = Env
     server :: Server,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
-    idsDrg :: TVar ChaChaDRG
+    idsDrg :: TVar ChaChaDRG,
+    serverKeyPair :: C.FullKeyPair,
+    storeLog :: Maybe (StoreLog 'WriteMode)
   }
 
 data Server = Server
@@ -66,10 +78,21 @@ newSubscription = do
   delivered <- newEmptyTMVar
   return Sub {subThread = NoSub, delivered}
 
-newEnv :: (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
+newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env
 newEnv config = do
   server <- atomically $ newServer (tbqSize config)
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
-  return Env {config, server, queueStore, msgStore, idsDrg}
+  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'}
+  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}
+      pure s'
+    addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
+    addSender q = M.insert (senderId q) (recipientId q)

src/Simplex/Messaging/Server/QueueStore.hs

@@ -15,7 +15,7 @@ data QueueRec = QueueRec
     status :: QueueStatus
   }
 
-data QueueStatus = QueueActive | QueueOff
+data QueueStatus = QueueActive | QueueOff deriving (Eq)
 
 class MonadQueueStore s m where
   addQueue :: s -> RecipientPublicKey -> (RecipientId, SenderId) -> m (Either ErrorType ())

src/Simplex/Messaging/Server/QueueStore/STM.hs

@@ -32,7 +32,7 @@ instance MonadQueueStore QueueStore STM where
   addQueue store rKey ids@(rId, sId) = do
     cs@QueueStoreData {queues, senders} <- readTVar store
     if M.member rId queues || M.member sId senders
-      then return $ Left DUPLICATE
+      then return $ Left DUPLICATE_
       else do
         writeTVar store $
           cs

src/Simplex/Messaging/Server/StoreLog.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Server.StoreLog
+  ( StoreLog, -- constructors are not exported
+    openWriteStoreLog,
+    openReadStoreLog,
+    storeLogFilePath,
+    closeStoreLog,
+    logCreateQueue,
+    logSecureQueue,
+    logDeleteQueue,
+    readWriteStoreLog,
+  )
+where
+
+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
+import Data.Either (partitionEithers)
+import Data.Functor (($>))
+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.Protocol
+import Simplex.Messaging.Server.QueueStore (QueueRec (..), QueueStatus (..))
+import Simplex.Messaging.Transport (trimCR)
+import System.Directory (doesFileExist)
+import System.IO
+
+-- | opaque container for file handle with a type-safe IOMode
+-- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead
+data StoreLog (a :: IOMode) where
+  ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode
+  WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode
+
+data StoreLogRecord
+  = CreateQueue QueueRec
+  | SecureQueue QueueId SenderPublicKey
+  | 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}
+
+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
+        ]
+
+openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
+openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode
+
+openReadStoreLog :: FilePath -> IO (StoreLog 'ReadMode)
+openReadStoreLog f = do
+  doesFileExist f >>= (`unless` writeFile f "")
+  ReadStoreLog f <$> openFile f ReadMode
+
+storeLogFilePath :: StoreLog a -> FilePath
+storeLogFilePath = \case
+  WriteStoreLog f _ -> f
+  ReadStoreLog f _ -> f
+
+closeStoreLog :: StoreLog a -> IO ()
+closeStoreLog = \case
+  WriteStoreLog _ h -> hClose h
+  ReadStoreLog _ h -> hClose h
+
+writeStoreLogRecord :: StoreLog 'WriteMode -> StoreLogRecord -> IO ()
+writeStoreLogRecord (WriteStoreLog _ h) r = do
+  B.hPutStrLn h $ serializeStoreLogRecord r
+  hFlush h
+
+logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO ()
+logCreateQueue s = writeStoreLogRecord s . CreateQueue
+
+logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SenderPublicKey -> IO ()
+logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
+
+logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO ()
+logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
+
+readWriteStoreLog :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
+readWriteStoreLog s@(ReadStoreLog f _) = do
+  qs <- readQueues s
+  closeStoreLog s
+  s' <- openWriteStoreLog f
+  writeQueues s' qs
+  pure (qs, s')
+
+writeQueues :: StoreLog 'WriteMode -> Map RecipientId QueueRec -> IO ()
+writeQueues s = mapM_ (writeStoreLogRecord s . CreateQueue) . M.filter active
+  where
+    active QueueRec {status} = status == QueueActive
+
+type LogParsingError = (String, ByteString)
+
+readQueues :: StoreLog 'ReadMode -> IO (Map RecipientId QueueRec)
+readQueues (ReadStoreLog _ h) = LB.hGetContents h >>= returnResult . procStoreLog
+  where
+    procStoreLog :: LB.ByteString -> ([LogParsingError], Map RecipientId QueueRec)
+    procStoreLog = second (foldl' procLogRecord M.empty) . partitionEithers . map parseLogRecord . LB.lines
+    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
+    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
+      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

@@ -1,42 +1,145 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
-module Simplex.Messaging.Transport where
+-- |
+-- Module      : Simplex.Messaging.Transport
+-- Copyright   : (c) simplex.chat
+-- License     : AGPL-3
+--
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : non-portable
+--
+-- This module defines basic TCP server and client and SMP protocol encrypted transport over TCP.
+--
+-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
+module Simplex.Messaging.Transport
+  ( -- * Transport connection class
+    Transport (..),
+    TProxy (..),
+    ATransport (..),
 
-import Control.Monad.IO.Class
+    -- * Transport over TCP
+    runTransportServer,
+    runTransportClient,
+
+    -- * TCP transport
+    TCP (..),
+
+    -- * SMP encrypted transport
+    THandle (..),
+    TransportError (..),
+    serverHandshake,
+    clientHandshake,
+    tPutEncrypted,
+    tGetEncrypted,
+    serializeTransportError,
+    transportErrorP,
+
+    -- * Trim trailing CR
+    trimCR,
+  )
+where
+
+import Control.Applicative ((<|>))
+import Control.Monad.Except
 import Control.Monad.IO.Unlift
-import Control.Monad.Reader
+import Control.Monad.Trans.Except (throwE)
+import Crypto.Cipher.Types (AuthTag)
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import Data.ByteArray (xor)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
+import Data.Word (Word32)
+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 Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Parsers (parse, parseAll, parseRead1)
+import Simplex.Messaging.Util (bshow, liftError)
 import System.IO
 import System.IO.Error
+import Test.QuickCheck (Arbitrary (..))
 import UnliftIO.Concurrent
 import UnliftIO.Exception (Exception, IOException)
 import qualified UnliftIO.Exception as E
-import qualified UnliftIO.IO as IO
 import UnliftIO.STM
 
-runTCPServer :: MonadUnliftIO m => ServiceName -> (Handle -> m ()) -> m ()
-runTCPServer port server = do
+-- * Transport connection class
+
+class Transport c where
+  transport :: ATransport
+  transport = ATransport (TProxy @c)
+
+  transportName :: TProxy c -> String
+
+  -- | Upgrade client socket to connection (used in the server)
+  getServerConnection :: Socket -> IO c
+
+  -- | Upgrade server socket to connection (used in the client)
+  getClientConnection :: Socket -> IO c
+
+  -- | Close connection
+  closeConnection :: c -> IO ()
+
+  -- | Read fixed number of bytes from connection
+  cGet :: c -> Int -> IO ByteString
+
+  -- | Write bytes to connection
+  cPut :: c -> ByteString -> IO ()
+
+  -- | Receive ByteString from connection, allowing LF or CRLF termination.
+  getLn :: c -> IO ByteString
+
+  -- | Send ByteString to connection terminating it with CRLF.
+  putLn :: c -> ByteString -> IO ()
+  putLn c = cPut c . (<> "\r\n")
+
+data TProxy c = TProxy
+
+data ATransport = forall c. Transport c => ATransport (TProxy c)
+
+-- * Transport over TCP
+
+-- | 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
   clients <- newTVarIO S.empty
-  E.bracket (liftIO $ startTCPServer port) (liftIO . closeServer clients) $ \sock -> forever $ do
-    h <- liftIO $ acceptTCPConn sock
-    tid <- forkFinally (server h) (const $ IO.hClose h)
+  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
   where
     closeServer :: TVar (Set ThreadId) -> Socket -> IO ()
-    closeServer clients sock = readTVarIO clients >>= mapM_ killThread >> close sock
+    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
 
-startTCPServer :: ServiceName -> IO Socket
-startTCPServer port = withSocketsDo $ resolve >>= open
+startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
+startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
   where
     resolve =
       let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
@@ -48,19 +151,16 @@ startTCPServer port = withSocketsDo $ resolve >>= open
       bind sock $ addrAddress addr
       listen sock 1024
       return sock
+    setStarted sock = atomically (tryPutTMVar started True) >> pure sock
 
-acceptTCPConn :: Socket -> IO Handle
-acceptTCPConn sock = accept sock >>= getSocketHandle . fst
+-- | 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
+  client c `E.finally` liftIO (closeConnection c)
 
-runTCPClient :: MonadUnliftIO m => HostName -> ServiceName -> (Handle -> m a) -> m a
-runTCPClient host port client = do
-  h <- liftIO $ startTCPClient host port
-  client h `E.finally` IO.hClose h
-
-startTCPClient :: HostName -> ServiceName -> IO Handle
-startTCPClient host port =
-  withSocketsDo $
-    resolve >>= foldM tryOpen (Left err) >>= either E.throwIO return -- replace fold with recursion
+startTCPClient :: forall c. Transport c => HostName -> ServiceName -> IO c
+startTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -70,15 +170,29 @@ startTCPClient host port =
       let hints = defaultHints {addrSocketType = Stream}
        in getAddrInfo (Just hints) (Just host) (Just port)
 
-    tryOpen :: Exception e => Either e Handle -> AddrInfo -> IO (Either e Handle)
-    tryOpen (Left _) addr = E.try $ open addr
-    tryOpen h _ = return h
+    tryOpen :: IOException -> [AddrInfo] -> IO c
+    tryOpen e [] = E.throwIO e
+    tryOpen _ (addr : as) =
+      E.try (open addr) >>= either (`tryOpen` as) pure
 
-    open :: AddrInfo -> IO Handle
+    open :: AddrInfo -> IO c
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       connect sock $ addrAddress addr
-      getSocketHandle sock
+      getClientConnection sock
+
+-- * TCP transport
+
+newtype TCP = TCP {tcpHandle :: Handle}
+
+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
 
 getSocketHandle :: Socket -> IO Handle
 getSocketHandle conn = do
@@ -88,11 +202,287 @@ getSocketHandle conn = do
   hSetBuffering h LineBuffering
   return h
 
-putLn :: Handle -> ByteString -> IO ()
-putLn h = B.hPut h . (<> "\r\n")
+-- | Trim trailing CR from ByteString.
+trimCR :: ByteString -> ByteString
+trimCR "" = ""
+trimCR s = if B.last s == '\r' then B.init s else s
 
-getLn :: Handle -> IO ByteString
-getLn h = trim_cr <$> B.hGetLine h
+-- * SMP encrypted transport
+
+data SMPVersion = SMPVersion Int Int Int Int
+  deriving (Eq, Ord)
+
+major :: SMPVersion -> (Int, Int)
+major (SMPVersion a b _ _) = (a, b)
+
+currentSMPVersion :: SMPVersion
+currentSMPVersion = SMPVersion 0 3 2 0
+
+serializeSMPVersion :: SMPVersion -> ByteString
+serializeSMPVersion (SMPVersion a b c d) = B.intercalate "." [bshow a, bshow b, bshow c, bshow d]
+
+smpVersionP :: Parser SMPVersion
+smpVersionP =
+  let ver = A.decimal <* A.char '.'
+   in SMPVersion <$> ver <*> ver <*> ver <*> A.decimal
+
+-- | The handle for SMP encrypted transport connection over Transport .
+data THandle c = THandle
+  { connection :: c,
+    sndKey :: SessionKey,
+    rcvKey :: SessionKey,
+    blockSize :: Int
+  }
+
+data SessionKey = SessionKey
+  { aesKey :: C.Key,
+    baseIV :: C.IV,
+    counter :: TVar Word32
+  }
+
+data ClientHandshake = ClientHandshake
+  { blockSize :: Int,
+    sndKey :: SessionKey,
+    rcvKey :: SessionKey
+  }
+
+-- | Error of SMP encrypted transport over TCP.
+data TransportError
+  = -- | error parsing transport block
+    TEBadBlock
+  | -- | block encryption error
+    TEEncrypt
+  | -- | block decryption error
+    TEDecrypt
+  | -- | 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
+    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
+  deriving (Eq, Generic, Read, Show, Exception)
+
+instance Arbitrary TransportError where arbitrary = genericArbitraryU
+
+instance Arbitrary HandshakeError where arbitrary = genericArbitraryU
+
+-- | SMP encrypted transport error parser.
+transportErrorP :: Parser TransportError
+transportErrorP =
+  "BLOCK" $> TEBadBlock
+    <|> "AES_ENCRYPT" $> TEEncrypt
+    <|> "AES_DECRYPT" $> TEDecrypt
+    <|> TEHandshake <$> parseRead1
+
+-- | Serialize SMP encrypted transport error.
+serializeTransportError :: TransportError -> ByteString
+serializeTransportError = \case
+  TEEncrypt -> "AES_ENCRYPT"
+  TEDecrypt -> "AES_DECRYPT"
+  TEBadBlock -> "BLOCK"
+  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)
+
+makeNextIV :: SessionKey -> IO C.IV
+makeNextIV SessionKey {baseIV, counter} = atomically $ do
+  c <- readTVar counter
+  writeTVar counter $ c + 1
+  pure $ iv c
   where
-    trim_cr "" = ""
-    trim_cr s = if B.last s == '\r' then B.init s else s
+    (start, rest) = B.splitAt 4 $ C.unIV baseIV
+    iv c = C.IV $ (start `xor` encodeWord32 c) <> rest
+
+-- | Server SMP encrypted 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 -> C.FullKeyPair -> ExceptT TransportError IO (THandle c)
+serverHandshake c (k, pk) = do
+  liftIO sendHeaderAndPublicKey_1
+  encryptedKeys <- receiveEncryptedKeys_4
+  -- TODO server currently ignores blockSize returned by the client
+  -- this is reserved for future support of streams
+  ClientHandshake {blockSize = _, sndKey, rcvKey} <- decryptParseKeys_5 encryptedKeys
+  th <- liftIO $ transportHandle c rcvKey sndKey transportBlockSize -- keys are swapped here
+  sendWelcome_6 th
+  pure th
+  where
+    sendHeaderAndPublicKey_1 :: IO ()
+    sendHeaderAndPublicKey_1 = do
+      let sKey = C.encodePubKey k
+          header = ServerHeader {blockSize = transportBlockSize, 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 $ serializeSMPVersion currentSMPVersion <> " "
+
+-- | Client SMP encrypted 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 C.KeyHash -> ExceptT TransportError IO (THandle c)
+clientHandshake c keyHash = do
+  (k, blkSize) <- getHeaderAndPublicKey_1_2
+  -- TODO currently client always uses the blkSize returned by the server
+  keys@ClientHandshake {sndKey, rcvKey} <- liftIO $ generateKeys_3 blkSize
+  sendEncryptedKeys_4 k keys
+  th <- liftIO $ transportHandle c sndKey rcvKey blkSize
+  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
+      when (blockSize < transportBlockSize || blockSize > maxTransportBlockSize) $
+        throwError $ TEHandshake HEADER
+      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 keys =
+      liftError (const $ TEHandshake ENCRYPT) (C.encryptOAEP k $ serializeClientHandshake keys)
+        >>= 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
+
+data ServerHeader = ServerHeader {blockSize :: Int, keySize :: Int}
+  deriving (Eq, Show)
+
+binaryRsaTransport :: Int
+binaryRsaTransport = 0
+
+transportBlockSize :: Int
+transportBlockSize = 4096
+
+maxTransportBlockSize :: Int
+maxTransportBlockSize = 65536
+
+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
+
+binaryRsaTransportP :: Parser ()
+binaryRsaTransportP = binaryRsa =<< int16
+  where
+    binaryRsa :: Int -> Parser ()
+    binaryRsa n
+      | n == binaryRsaTransport = pure ()
+      | otherwise = fail "unknown transport mode"
+
+parseClientHandshake :: ByteString -> Either TransportError ClientHandshake
+parseClientHandshake = parse clientHandshakeP $ TEHandshake AES_KEYS
+
+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
+      }

src/Simplex/Messaging/Transport/WebSockets.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE InstanceSigs #-}
+
+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 Network.WebSockets
+import Network.WebSockets.Stream (Stream)
+import qualified Network.WebSockets.Stream as S
+import Simplex.Messaging.Transport (TProxy, Transport (..), TransportError (..), trimCR)
+
+data WS = WS {wsStream :: Stream, wsConnection :: Connection}
+
+websocketsOpts :: ConnectionOptions
+websocketsOpts =
+  defaultConnectionOptions
+    { connectionCompressionOptions = NoCompression,
+      connectionFramePayloadSizeLimit = SizeLimit 8192,
+      connectionMessageDataSizeLimit = SizeLimit 65536
+    }
+
+instance Transport WS where
+  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
+
+  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 []
+
+  closeConnection :: WS -> IO ()
+  closeConnection = S.close . wsStream
+
+  cGet :: WS -> Int -> IO ByteString
+  cGet c n = do
+    s <- receiveData (wsConnection c)
+    if B.length s == n
+      then pure s
+      else E.throwIO TEBadBlock
+
+  cPut :: WS -> ByteString -> IO ()
+  cPut = sendBinaryData . wsConnection
+
+  getLn :: WS -> IO ByteString
+  getLn c = do
+    s <- trimCR <$> receiveData (wsConnection c)
+    if B.null s || B.last s /= '\n'
+      then E.throwIO TEBadBlock
+      else pure $ B.init s

src/Simplex/Messaging/Util.hs

@@ -31,19 +31,22 @@ raceAny_ = r []
     r as (m : ms) = withAsync m $ \a -> r (a : as) ms
     r as [] = void $ waitAnyCancel as
 
-infixl 4 <$$>
+infixl 4 <$$>, <$?>
 
 (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
 (<$$>) = fmap . fmap
 
+(<$?>) :: MonadFail m => (a -> Either String b) -> m a -> m b
+f <$?> m = m >>= either fail pure . f
+
 bshow :: Show a => a -> ByteString
 bshow = B.pack . show
 
-liftIOEither :: (MonadUnliftIO m, MonadError e m) => IO (Either e a) -> m a
+liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a
 liftIOEither a = liftIO a >>= liftEither
 
-liftError :: (MonadUnliftIO m, MonadError e' m) => (e -> e') -> ExceptT e IO a -> m a
+liftError :: (MonadIO m, MonadError e' m) => (e -> e') -> ExceptT e IO a -> m a
 liftError f = liftEitherError f . runExceptT
 
-liftEitherError :: (MonadUnliftIO m, MonadError e' m) => (e -> e') -> IO (Either e a) -> m a
+liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a) -> m a
 liftEitherError f a = liftIOEither (first f <$> a)

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-16.17
+resolver: lts-17.12
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -35,10 +35,10 @@ packages:
 # forks / in-progress versions pinned to a git hash. For example:
 #
 extra-deps:
-  - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
+  - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881
   - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718
   - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079
-  - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977
+  - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002
 # - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

tests/AgentTests.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module AgentTests where
 
@@ -13,38 +14,31 @@ import Control.Concurrent
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import SMPAgentClient
-import Simplex.Messaging.Agent.Transmission
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
-import System.IO (Handle)
+import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
 import System.Timeout
 import Test.Hspec
 
-agentTests :: Spec
-agentTests = do
+agentTests :: ATransport -> Spec
+agentTests (ATransport t) = do
   describe "SQLite store" storeTests
-  describe "SMP agent protocol syntax" syntaxTests
+  describe "SMP agent protocol syntax" $ syntaxTests t
   describe "Establishing duplex connection" do
     it "should connect via one server and one agent" $
-      smpAgentTest2_1 testDuplexConnection
+      smpAgentTest2_1_1 $ testDuplexConnection t
     it "should connect via one server and 2 agents" $
-      smpAgentTest2 testDuplexConnection
+      smpAgentTest2_2_1 $ testDuplexConnection t
+    it "should connect via 2 servers and 2 agents" $
+      smpAgentTest2_2_2 $ testDuplexConnection t
   describe "Connection subscriptions" do
-    -- TODO replace delays with a permanent fix, this often fails in github build
-    xit "should connect via one server and one agent" $
-      smpAgentTest3_1 testSubscription
+    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
-
--- | simple test for one command with the expected response
-(>#>) :: ARawTransmission -> ARawTransmission -> Expectation
-command >#> response = smpAgentTest command `shouldReturn` response
-
--- | simple test for one command with a predicate for the expected response
-(>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation
-command >#>= p = smpAgentTest command >>= (`shouldSatisfy` p . \(cId, cAlias, cmd) -> (cId, cAlias, B.words cmd))
+      smpAgentServerTest $ testSubscrNotification t
 
 -- | send transmission `t` to handle `h` and get response
-(#:) :: Handle -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
+(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
 h #: t = tPutRaw h t >> tGet SAgent h
 
 -- | action and expected response
@@ -63,15 +57,15 @@ correctTransmission (corrId, cAlias, cmdOrErr) = case cmdOrErr of
   Left e -> error $ show e
 
 -- | receive message to handle `h` and validate that it is the expected one
-(<#) :: Handle -> ATransmission 'Agent -> Expectation
+(<#) :: Transport c => c -> ATransmission 'Agent -> Expectation
 h <# (corrId, cAlias, cmd) = tGet SAgent h `shouldReturn` (corrId, cAlias, Right cmd)
 
 -- | receive message to handle `h` and validate it using predicate `p`
-(<#=) :: Handle -> (ATransmission 'Agent -> Bool) -> Expectation
+(<#=) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
 h <#= p = tGet SAgent h >>= (`shouldSatisfy` p . correctTransmission)
 
 -- | test that nothing is delivered to handle `h` during 10ms
-(#:#) :: Handle -> String -> Expectation
+(#:#) :: Transport c => c -> String -> Expectation
 h #:# err = tryGet `shouldReturn` ()
   where
     tryGet =
@@ -80,72 +74,64 @@ h #:# err = tryGet `shouldReturn` ()
         _ -> return ()
 
 pattern Msg :: MsgBody -> ACommand 'Agent
-pattern Msg m_body <- MSG {m_body}
+pattern Msg msgBody <- MSG {msgBody, msgIntegrity = MsgOk}
 
-testDuplexConnection :: Handle -> Handle -> IO ()
-testDuplexConnection alice bob = do
-  ("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW localhost:5000")
+testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
+testDuplexConnection _ alice bob = do
+  ("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW")
   let qInfo' = serializeSmpQueueInfo qInfo
-  bob #: ("11", "alice", "JOIN " <> qInfo') #> ("11", "alice", CON)
+  bob #: ("11", "alice", "JOIN " <> qInfo') #> ("", "alice", CON)
   alice <# ("", "bob", CON)
-  alice #: ("2", "bob", "SEND :hello") =#> \case ("2", "bob", SENT _) -> True; _ -> False
-  alice #: ("3", "bob", "SEND :how are you?") =#> \case ("3", "bob", SENT _) -> True; _ -> False
+  alice #: ("2", "bob", "SEND :hello") =#> \case ("2", "bob", SENT 1) -> True; _ -> False
+  alice #: ("3", "bob", "SEND :how are you?") =#> \case ("3", "bob", SENT 2) -> True; _ -> False
   bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
   bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
-  bob #: ("14", "alice", "SEND 9\nhello too") =#> \case ("14", "alice", SENT _) -> True; _ -> False
+  bob #: ("14", "alice", "SEND 9\nhello too") =#> \case ("14", "alice", SENT 3) -> True; _ -> False
   alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
-  bob #: ("15", "alice", "SEND 9\nmessage 1") =#> \case ("15", "alice", SENT _) -> True; _ -> False
+  bob #: ("15", "alice", "SEND 9\nmessage 1") =#> \case ("15", "alice", SENT 4) -> True; _ -> False
   alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
   alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
   bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", ERR (SMP AUTH))
   alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
   alice #:# "nothing else should be delivered to alice"
 
-testSubscription :: Handle -> Handle -> Handle -> IO ()
-testSubscription alice1 alice2 bob = do
-  ("1", "bob", Right (INV qInfo)) <- alice1 #: ("1", "bob", "NEW localhost:5000")
+testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
+testSubscription _ alice1 alice2 bob = do
+  ("1", "bob", Right (INV qInfo)) <- alice1 #: ("1", "bob", "NEW")
   let qInfo' = serializeSmpQueueInfo qInfo
-  bob #: ("11", "alice", "JOIN " <> qInfo') #> ("11", "alice", CON)
+  bob #: ("11", "alice", "JOIN " <> qInfo') #> ("", "alice", CON)
   bob #: ("12", "alice", "SEND 5\nhello") =#> \case ("12", "alice", SENT _) -> True; _ -> False
   bob #: ("13", "alice", "SEND 11\nhello again") =#> \case ("13", "alice", SENT _) -> True; _ -> False
   alice1 <# ("", "bob", CON)
   alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
-  -- alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
-  t <- tGet SAgent alice1
-  print t
-  t `shouldSatisfy` (\case ("", "bob", Msg "hello again") -> True; _ -> False) . correctTransmission
+  alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
   alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
   alice1 <# ("", "bob", END)
   bob #: ("14", "alice", "SEND 2\nhi") =#> \case ("14", "alice", SENT _) -> True; _ -> False
   alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
   alice1 #:# "nothing else should be delivered to alice1"
 
-testSubscrNotification :: (ThreadId, ThreadId) -> Handle -> IO ()
-testSubscrNotification (server, _) client = do
-  client #: ("1", "conn1", "NEW localhost:5000") =#> \case ("1", "conn1", INV _) -> True; _ -> False
+testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
+testSubscrNotification _ (server, _) client = do
+  client #: ("1", "conn1", "NEW") =#> \case ("1", "conn1", INV _) -> True; _ -> False
   client #:# "nothing should be delivered to client before the server is killed"
   killThread server
   client <# ("", "conn1", END)
 
 samplePublicKey :: ByteString
-samplePublicKey = "256,ppr3DCweAD3RTVFhU2j0u+DnYdqJl1qCdKLHIKsPl1xBzfmnzK0o9GEDlaIClbK39KzPJMljcpnYb2KlSoZ51AhwF5PH2CS+FStc3QzajiqfdOQPet23Hd9YC6pqyTQ7idntqgPrE7yKJF44lUhKlq8QS9KQcbK7W6t7F9uQFw44ceWd2eVf81UV04kQdKWJvC5Sz6jtSZNEfs9mVI8H0wi1amUvS6+7EDJbxikhcCRnFShFO9dUKRYXj6L2JVqXqO5cZgY9BScyneWIg6mhhsTcdDbITM6COlL+pF1f3TjDN+slyV+IzE+ap/9NkpsrCcI8KwwDpqEDmUUV/JQfmQ==,gj2UAiWzSj7iun0iXvI5iz5WEjaqngmB3SzQ5+iarixbaG15LFDtYs3pijG3eGfB1wIFgoP4D2z97vIWn8olT4uCTUClf29zGDDve07h/B3QG/4i0IDnio7MX3AbE8O6PKouqy/GLTfT4WxFUn423g80rpsVYd5oj+SCL2eaxIc="
+samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR"
 
-syntaxTests :: Spec
-syntaxTests = do
-  it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR SYNTAX 11")
+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: ERROR no connection alias in the response (it does not generate it yet if not provided)
       -- TODO: add tests with defined connection alias
-      xit "only server" $ ("211", "", "NEW localhost") >#>= \case ("211", "", "INV" : _) -> True; _ -> False
-      it "with port" $ ("212", "", "NEW localhost:5000") >#>= \case ("212", "", "INV" : _) -> True; _ -> False
-      xit "with keyHash" $ ("213", "", "NEW localhost#1234") >#>= \case ("213", "", "INV" : _) -> True; _ -> False
-      it "with port and keyHash" $ ("214", "", "NEW localhost:5000#1234") >#>= \case ("214", "", "INV" : _) -> True; _ -> False
+      xit "without parameters" $ ("211", "", "NEW") >#>= \case ("211", "", "INV" : _) -> True; _ -> False
     describe "invalid" do
       -- TODO: add tests with defined connection alias
-      it "no parameters" $ ("221", "", "NEW") >#> ("221", "", "ERR SYNTAX 11")
-      it "many parameters" $ ("222", "", "NEW localhost:5000 hi") >#> ("222", "", "ERR SYNTAX 11")
-      it "invalid server keyHash" $ ("223", "", "NEW localhost:5000#1") >#> ("223", "", "ERR SYNTAX 11")
+      it "with parameters" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
 
   describe "JOIN" do
     describe "valid" do
@@ -155,4 +141,12 @@ syntaxTests = do
         ("311", "", "JOIN smp::localhost:5000::1234::" <> samplePublicKey) >#> ("311", "", "ERR SMP AUTH")
     describe "invalid" do
       -- TODO: JOIN is not merged yet - to be added
-      it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR SYNTAX 11")
+      it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
+  where
+    -- simple test for one command with the expected response
+    (>#>) :: ARawTransmission -> ARawTransmission -> Expectation
+    command >#> response = smpAgentTest t command `shouldReturn` response
+
+    -- 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))

tests/AgentTests/SQLiteTests.hs

@@ -1,43 +1,58 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module AgentTests.SQLiteTests (storeTests) where
 
+import Control.Concurrent.Async (concurrently_)
+import Control.Monad (replicateM_)
 import Control.Monad.Except (ExceptT, runExceptT)
 import qualified Crypto.PubKey.RSA as R
+import Data.ByteString.Char8 (ByteString)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time
 import Data.Word (Word32)
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.QQ (sql)
+import SMPClient (testKeyHash)
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store
 import Simplex.Messaging.Agent.Store.SQLite
-import Simplex.Messaging.Agent.Transmission
 import qualified Simplex.Messaging.Crypto as C
 import System.Random (Random (randomIO))
 import Test.Hspec
 import UnliftIO.Directory (removeFile)
 
 testDB :: String
-testDB = "smp-agent.test.db"
+testDB = "tests/tmp/smp-agent.test.db"
 
 withStore :: SpecWith SQLiteStore -> Spec
 withStore = before createStore . after removeStore
-  where
-    createStore :: IO SQLiteStore
-    createStore = do
-      -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
-      -- IO operations on multiple similarly named files; error seems to be environment specific
-      r <- randomIO :: IO Word32
-      createSQLiteStore $ testDB <> show r
 
-    removeStore :: SQLiteStore -> IO ()
-    removeStore store = do
-      DB.close $ dbConn store
-      removeFile $ dbFilePath store
+withStore2 :: SpecWith (SQLiteStore, SQLiteStore) -> Spec
+withStore2 = before connect2 . after (removeStore . fst)
+  where
+    connect2 :: IO (SQLiteStore, SQLiteStore)
+    connect2 = do
+      s1 <- createStore
+      s2 <- connectSQLiteStore $ dbFilePath s1
+      pure (s1, s2)
+
+createStore :: IO SQLiteStore
+createStore = do
+  -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
+  -- IO operations on multiple similarly named files; error seems to be environment specific
+  r <- randomIO :: IO Word32
+  createSQLiteStore $ testDB <> show r
+
+removeStore :: SQLiteStore -> IO ()
+removeStore store = do
+  DB.close $ dbConn store
+  removeFile $ dbFilePath store
 
 returnsResult :: (Eq a, Eq e, Show a, Show e) => ExceptT e IO a -> a -> Expectation
 action `returnsResult` r = runExceptT action `shouldReturn` Right r
@@ -47,42 +62,66 @@ action `throwsError` e = runExceptT action `shouldReturn` Left e
 
 -- TODO add null port tests
 storeTests :: Spec
-storeTests = withStore do
-  describe "compiled as threadsafe" testCompiledThreadsafe
-  describe "foreign keys enabled" testForeignKeysEnabled
-  describe "store methods" do
-    describe "createRcvConn" testCreateRcvConn
-    describe "createSndConn" testCreateSndConn
-    describe "getAllConnAliases" testGetAllConnAliases
-    describe "getRcvQueue" testGetRcvQueue
-    describe "deleteConn" do
-      describe "RcvConnection" testDeleteRcvConn
-      describe "SndConnection" testDeleteSndConn
-      describe "DuplexConnection" testDeleteDuplexConn
-    describe "upgradeRcvConnToDuplex" testUpgradeRcvConnToDuplex
-    describe "upgradeSndConnToDuplex" testUpgradeSndConnToDuplex
-    describe "set queue status" do
-      describe "setRcvQueueStatus" testSetRcvQueueStatus
-      describe "setSndQueueStatus" testSetSndQueueStatus
-      describe "DuplexConnection" testSetQueueStatusDuplex
-      xdescribe "RcvQueue doesn't exist" testSetRcvQueueStatusNoQueue
-      xdescribe "SndQueue doesn't exist" testSetSndQueueStatusNoQueue
-    describe "createRcvMsg" do
-      describe "RcvQueue exists" testCreateRcvMsg
-      describe "RcvQueue doesn't exist" testCreateRcvMsgNoQueue
-    describe "createSndMsg" do
-      describe "SndQueue exists" testCreateSndMsg
-      describe "SndQueue doesn't exist" testCreateSndMsgNoQueue
+storeTests = do
+  withStore2 do
+    describe "stress test" testConcurrentWrites
+  withStore do
+    describe "store setup" do
+      testCompiledThreadsafe
+      testForeignKeysEnabled
+    describe "store methods" do
+      describe "Queue and Connection management" do
+        describe "createRcvConn" do
+          testCreateRcvConn
+          testCreateRcvConnDuplicate
+        describe "createSndConn" do
+          testCreateSndConn
+          testCreateSndConnDuplicate
+        describe "getAllConnAliases" testGetAllConnAliases
+        describe "getRcvConn" testGetRcvConn
+        describe "deleteConn" do
+          testDeleteRcvConn
+          testDeleteSndConn
+          testDeleteDuplexConn
+        describe "upgradeRcvConnToDuplex" do
+          testUpgradeRcvConnToDuplex
+        describe "upgradeSndConnToDuplex" do
+          testUpgradeSndConnToDuplex
+        describe "set Queue status" do
+          describe "setRcvQueueStatus" do
+            testSetRcvQueueStatus
+            testSetRcvQueueStatusNoQueue
+          describe "setSndQueueStatus" do
+            testSetSndQueueStatus
+            testSetSndQueueStatusNoQueue
+          testSetQueueStatusDuplex
+      describe "Msg management" do
+        describe "create Msg" do
+          testCreateRcvMsg
+          testCreateSndMsg
+          testCreateRcvAndSndMsgs
+
+testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore)
+testConcurrentWrites =
+  it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do
+    _ <- runExceptT $ createRcvConn s1 rcvQueue1
+    concurrently_ (runTest s1) (runTest s2)
+  where
+    runTest :: SQLiteStore -> IO (Either StoreError ())
+    runTest store = runExceptT . replicateM_ 100 $ do
+      (internalId, internalRcvId, _, _) <- updateRcvIds store rcvQueue1
+      let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy"
+      createRcvMsg store rcvQueue1 rcvMsgData
 
 testCompiledThreadsafe :: SpecWith SQLiteStore
-testCompiledThreadsafe = do
-  it "should throw error if compiled sqlite library is not threadsafe" $ \store -> do
+testCompiledThreadsafe =
+  it "compiled sqlite library should be threadsafe" $ \store -> do
     compileOptions <- DB.query_ (dbConn store) "pragma COMPILE_OPTIONS;" :: IO [[T.Text]]
     compileOptions `shouldNotContain` [["THREADSAFE=0"]]
 
 testForeignKeysEnabled :: SpecWith SQLiteStore
-testForeignKeysEnabled = do
-  it "should throw error if foreign keys are enabled" $ \store -> do
+testForeignKeysEnabled =
+  it "foreign keys should be enabled" $ \store -> do
     let inconsistentQuery =
           [sql|
             INSERT INTO connections
@@ -96,13 +135,13 @@ testForeignKeysEnabled = do
 rcvQueue1 :: RcvQueue
 rcvQueue1 =
   RcvQueue
-    { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
+    { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
       rcvId = "1234",
       connAlias = "conn1",
-      rcvPrivateKey = C.PrivateKey 1 2 3,
+      rcvPrivateKey = C.safePrivateKey (1, 2, 3),
       sndId = Just "2345",
       sndKey = Nothing,
-      decryptKey = C.PrivateKey 1 2 3,
+      decryptKey = C.safePrivateKey (1, 2, 3),
       verifyKey = Nothing,
       status = New
     }
@@ -110,17 +149,17 @@ rcvQueue1 =
 sndQueue1 :: SndQueue
 sndQueue1 =
   SndQueue
-    { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
+    { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
       sndId = "3456",
       connAlias = "conn1",
-      sndPrivateKey = C.PrivateKey 1 2 3,
+      sndPrivateKey = C.safePrivateKey (1, 2, 3),
       encryptKey = C.PublicKey $ R.PublicKey 1 2 3,
-      signKey = C.PrivateKey 1 2 3,
+      signKey = C.safePrivateKey (1, 2, 3),
       status = New
     }
 
 testCreateRcvConn :: SpecWith SQLiteStore
-testCreateRcvConn = do
+testCreateRcvConn =
   it "should create RcvConnection and add SndQueue" $ \store -> do
     createRcvConn store rcvQueue1
       `returnsResult` ()
@@ -131,8 +170,15 @@ testCreateRcvConn = do
     getConn store "conn1"
       `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1)
 
+testCreateRcvConnDuplicate :: SpecWith SQLiteStore
+testCreateRcvConnDuplicate =
+  it "should throw error on attempt to create duplicate RcvConnection" $ \store -> do
+    _ <- runExceptT $ createRcvConn store rcvQueue1
+    createRcvConn store rcvQueue1
+      `throwsError` SEConnDuplicate
+
 testCreateSndConn :: SpecWith SQLiteStore
-testCreateSndConn = do
+testCreateSndConn =
   it "should create SndConnection and add RcvQueue" $ \store -> do
     createSndConn store sndQueue1
       `returnsResult` ()
@@ -143,118 +189,113 @@ testCreateSndConn = do
     getConn store "conn1"
       `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1)
 
+testCreateSndConnDuplicate :: SpecWith SQLiteStore
+testCreateSndConnDuplicate =
+  it "should throw error on attempt to create duplicate SndConnection" $ \store -> do
+    _ <- runExceptT $ createSndConn store sndQueue1
+    createSndConn store sndQueue1
+      `throwsError` SEConnDuplicate
+
 testGetAllConnAliases :: SpecWith SQLiteStore
-testGetAllConnAliases = do
+testGetAllConnAliases =
   it "should get all conn aliases" $ \store -> do
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
-    createSndConn store sndQueue1 {connAlias = "conn2"}
-      `returnsResult` ()
+    _ <- runExceptT $ createRcvConn store rcvQueue1
+    _ <- runExceptT $ createSndConn store sndQueue1 {connAlias = "conn2"}
     getAllConnAliases store
       `returnsResult` ["conn1" :: ConnAlias, "conn2" :: ConnAlias]
 
-testGetRcvQueue :: SpecWith SQLiteStore
-testGetRcvQueue = do
-  it "should get RcvQueue" $ \store -> do
-    let smpServer = SMPServer "smp.simplex.im" (Just "5223") (Just "1234")
+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 recipientId = "1234"
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
-    getRcvQueue store smpServer recipientId
-      `returnsResult` rcvQueue1
+    _ <- runExceptT $ createRcvConn store rcvQueue1
+    getRcvConn store smpServer recipientId
+      `returnsResult` SomeConn SCRcv (RcvConnection (connAlias (rcvQueue1 :: RcvQueue)) rcvQueue1)
 
 testDeleteRcvConn :: SpecWith SQLiteStore
-testDeleteRcvConn = do
+testDeleteRcvConn =
   it "should create RcvConnection and delete it" $ \store -> do
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createRcvConn store rcvQueue1
     getConn store "conn1"
       `returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1)
     deleteConn store "conn1"
       `returnsResult` ()
     -- TODO check queues are deleted as well
     getConn store "conn1"
-      `throwsError` SEBadConn
+      `throwsError` SEConnNotFound
 
 testDeleteSndConn :: SpecWith SQLiteStore
-testDeleteSndConn = do
+testDeleteSndConn =
   it "should create SndConnection and delete it" $ \store -> do
-    createSndConn store sndQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createSndConn store sndQueue1
     getConn store "conn1"
       `returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1)
     deleteConn store "conn1"
       `returnsResult` ()
     -- TODO check queues are deleted as well
     getConn store "conn1"
-      `throwsError` SEBadConn
+      `throwsError` SEConnNotFound
 
 testDeleteDuplexConn :: SpecWith SQLiteStore
-testDeleteDuplexConn = do
+testDeleteDuplexConn =
   it "should create DuplexConnection and delete it" $ \store -> do
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
-    upgradeRcvConnToDuplex store "conn1" sndQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createRcvConn store rcvQueue1
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
     getConn store "conn1"
       `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1)
     deleteConn store "conn1"
       `returnsResult` ()
     -- TODO check queues are deleted as well
     getConn store "conn1"
-      `throwsError` SEBadConn
+      `throwsError` SEConnNotFound
 
 testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore
-testUpgradeRcvConnToDuplex = do
+testUpgradeRcvConnToDuplex =
   it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" $ \store -> do
-    createSndConn store sndQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createSndConn store sndQueue1
     let anotherSndQueue =
           SndQueue
-            { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
+            { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
               sndId = "2345",
               connAlias = "conn1",
-              sndPrivateKey = C.PrivateKey 1 2 3,
+              sndPrivateKey = C.safePrivateKey (1, 2, 3),
               encryptKey = C.PublicKey $ R.PublicKey 1 2 3,
-              signKey = C.PrivateKey 1 2 3,
+              signKey = C.safePrivateKey (1, 2, 3),
               status = New
             }
     upgradeRcvConnToDuplex store "conn1" anotherSndQueue
       `throwsError` SEBadConnType CSnd
-    upgradeSndConnToDuplex store "conn1" rcvQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ upgradeSndConnToDuplex store "conn1" rcvQueue1
     upgradeRcvConnToDuplex store "conn1" anotherSndQueue
       `throwsError` SEBadConnType CDuplex
 
 testUpgradeSndConnToDuplex :: SpecWith SQLiteStore
-testUpgradeSndConnToDuplex = do
+testUpgradeSndConnToDuplex =
   it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" $ \store -> do
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createRcvConn store rcvQueue1
     let anotherRcvQueue =
           RcvQueue
-            { server = SMPServer "smp.simplex.im" (Just "5223") (Just "1234"),
+            { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
               rcvId = "3456",
               connAlias = "conn1",
-              rcvPrivateKey = C.PrivateKey 1 2 3,
+              rcvPrivateKey = C.safePrivateKey (1, 2, 3),
               sndId = Just "4567",
               sndKey = Nothing,
-              decryptKey = C.PrivateKey 1 2 3,
+              decryptKey = C.safePrivateKey (1, 2, 3),
               verifyKey = Nothing,
               status = New
             }
     upgradeSndConnToDuplex store "conn1" anotherRcvQueue
       `throwsError` SEBadConnType CRcv
-    upgradeRcvConnToDuplex store "conn1" sndQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
     upgradeSndConnToDuplex store "conn1" anotherRcvQueue
       `throwsError` SEBadConnType CDuplex
 
 testSetRcvQueueStatus :: SpecWith SQLiteStore
-testSetRcvQueueStatus = do
+testSetRcvQueueStatus =
   it "should update status of RcvQueue" $ \store -> do
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createRcvConn store rcvQueue1
     getConn store "conn1"
       `returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1)
     setRcvQueueStatus store rcvQueue1 Confirmed
@@ -263,10 +304,9 @@ testSetRcvQueueStatus = do
       `returnsResult` SomeConn SCRcv (RcvConnection "conn1" rcvQueue1 {status = Confirmed})
 
 testSetSndQueueStatus :: SpecWith SQLiteStore
-testSetSndQueueStatus = do
+testSetSndQueueStatus =
   it "should update status of SndQueue" $ \store -> do
-    createSndConn store sndQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createSndConn store sndQueue1
     getConn store "conn1"
       `returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1)
     setSndQueueStatus store sndQueue1 Confirmed
@@ -275,12 +315,10 @@ testSetSndQueueStatus = do
       `returnsResult` SomeConn SCSnd (SndConnection "conn1" sndQueue1 {status = Confirmed})
 
 testSetQueueStatusDuplex :: SpecWith SQLiteStore
-testSetQueueStatusDuplex = do
+testSetQueueStatusDuplex =
   it "should update statuses of RcvQueue and SndQueue in DuplexConnection" $ \store -> do
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
-    upgradeRcvConnToDuplex store "conn1" sndQueue1
-      `returnsResult` ()
+    _ <- runExceptT $ createRcvConn store rcvQueue1
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
     getConn store "conn1"
       `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 sndQueue1)
     setRcvQueueStatus store rcvQueue1 Secured
@@ -290,61 +328,88 @@ testSetQueueStatusDuplex = do
     setSndQueueStatus store sndQueue1 Confirmed
       `returnsResult` ()
     getConn store "conn1"
-      `returnsResult` SomeConn
-        SCDuplex
-        ( DuplexConnection "conn1" rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed}
-        )
+      `returnsResult` SomeConn SCDuplex (DuplexConnection "conn1" rcvQueue1 {status = Secured} sndQueue1 {status = Confirmed})
 
 testSetRcvQueueStatusNoQueue :: SpecWith SQLiteStore
-testSetRcvQueueStatusNoQueue = do
-  it "should throw error on attempt to update status of nonexistent RcvQueue" $ \store -> do
+testSetRcvQueueStatusNoQueue =
+  xit "should throw error on attempt to update status of non-existent RcvQueue" $ \store -> do
     setRcvQueueStatus store rcvQueue1 Confirmed
-      `throwsError` SEInternal
+      `throwsError` SEConnNotFound
 
 testSetSndQueueStatusNoQueue :: SpecWith SQLiteStore
-testSetSndQueueStatusNoQueue = do
-  it "should throw error on attempt to update status of nonexistent SndQueue" $ \store -> do
+testSetSndQueueStatusNoQueue =
+  xit "should throw error on attempt to update status of non-existent SndQueue" $ \store -> do
     setSndQueueStatus store sndQueue1 Confirmed
-      `throwsError` SEInternal
+      `throwsError` SEConnNotFound
+
+hw :: ByteString
+hw = encodeUtf8 "Hello world!"
+
+ts :: UTCTime
+ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0)
+
+mkRcvMsgData :: InternalId -> InternalRcvId -> ExternalSndId -> BrokerId -> MsgHash -> RcvMsgData
+mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
+  RcvMsgData
+    { internalId,
+      internalRcvId,
+      internalTs = ts,
+      senderMeta = (externalSndId, ts),
+      brokerMeta = (brokerId, ts),
+      msgBody = hw,
+      internalHash,
+      externalPrevSndHash = "hash_from_sender",
+      msgIntegrity = MsgOk
+    }
+
+testCreateRcvMsg' :: SQLiteStore -> PrevExternalSndId -> PrevRcvMsgHash -> RcvQueue -> RcvMsgData -> Expectation
+testCreateRcvMsg' store expectedPrevSndId expectedPrevHash rcvQueue rcvMsgData@RcvMsgData {..} = do
+  updateRcvIds store rcvQueue
+    `returnsResult` (internalId, internalRcvId, expectedPrevSndId, expectedPrevHash)
+  createRcvMsg store rcvQueue rcvMsgData
+    `returnsResult` ()
 
 testCreateRcvMsg :: SpecWith SQLiteStore
-testCreateRcvMsg = do
-  it "should create a RcvMsg and return InternalId" $ \store -> do
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
+testCreateRcvMsg =
+  it "should reserve internal ids and create a RcvMsg" $ \store -> do
+    _ <- runExceptT $ createRcvConn store rcvQueue1
     -- TODO getMsg to check message
-    let ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0)
-    createRcvMsg store "conn1" (encodeUtf8 "Hello world!") ts (1, ts) ("1", ts)
-      `returnsResult` InternalId 1
+    testCreateRcvMsg' store 0 "" rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy"
+    testCreateRcvMsg' store 1 "hash_dummy" rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"
 
-testCreateRcvMsgNoQueue :: SpecWith SQLiteStore
-testCreateRcvMsgNoQueue = do
-  it "should throw error on attempt to create a RcvMsg w/t a RcvQueue" $ \store -> do
-    let ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0)
-    createRcvMsg store "conn1" (encodeUtf8 "Hello world!") ts (1, ts) ("1", ts)
-      `throwsError` SEBadConn
-    createSndConn store sndQueue1
-      `returnsResult` ()
-    createRcvMsg store "conn1" (encodeUtf8 "Hello world!") ts (1, ts) ("1", ts)
-      `throwsError` SEBadConnType CSnd
+mkSndMsgData :: InternalId -> InternalSndId -> MsgHash -> SndMsgData
+mkSndMsgData internalId internalSndId internalHash =
+  SndMsgData
+    { internalId,
+      internalSndId,
+      internalTs = ts,
+      msgBody = hw,
+      internalHash
+    }
+
+testCreateSndMsg' :: SQLiteStore -> PrevSndMsgHash -> SndQueue -> SndMsgData -> Expectation
+testCreateSndMsg' store expectedPrevHash sndQueue sndMsgData@SndMsgData {..} = do
+  updateSndIds store sndQueue
+    `returnsResult` (internalId, internalSndId, expectedPrevHash)
+  createSndMsg store sndQueue sndMsgData
+    `returnsResult` ()
 
 testCreateSndMsg :: SpecWith SQLiteStore
-testCreateSndMsg = do
-  it "should create a SndMsg and return InternalId" $ \store -> do
-    createSndConn store sndQueue1
-      `returnsResult` ()
+testCreateSndMsg =
+  it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \store -> do
+    _ <- runExceptT $ createSndConn store sndQueue1
     -- TODO getMsg to check message
-    let ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0)
-    createSndMsg store "conn1" (encodeUtf8 "Hello world!") ts
-      `returnsResult` InternalId 1
+    testCreateSndMsg' store "" sndQueue1 $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy"
+    testCreateSndMsg' store "hash_dummy" sndQueue1 $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy"
 
-testCreateSndMsgNoQueue :: SpecWith SQLiteStore
-testCreateSndMsgNoQueue = do
-  it "should throw error on attempt to create a SndMsg w/t a SndQueue" $ \store -> do
-    let ts = UTCTime (fromGregorian 2021 02 24) (secondsToDiffTime 0)
-    createSndMsg store "conn1" (encodeUtf8 "Hello world!") ts
-      `throwsError` SEBadConn
-    createRcvConn store rcvQueue1
-      `returnsResult` ()
-    createSndMsg store "conn1" (encodeUtf8 "Hello world!") ts
-      `throwsError` SEBadConnType CRcv
+testCreateRcvAndSndMsgs :: SpecWith SQLiteStore
+testCreateRcvAndSndMsgs =
+  it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \store -> do
+    _ <- runExceptT $ createRcvConn store rcvQueue1
+    _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1
+    testCreateRcvMsg' store 0 "" rcvQueue1 $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1"
+    testCreateRcvMsg' store 1 "rcv_hash_1" rcvQueue1 $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
+    testCreateSndMsg' store "" sndQueue1 $ mkSndMsgData (InternalId 3) (InternalSndId 1) "snd_hash_1"
+    testCreateRcvMsg' store 2 "rcv_hash_2" rcvQueue1 $ mkRcvMsgData (InternalId 4) (InternalRcvId 3) 3 "3" "rcv_hash_3"
+    testCreateSndMsg' store "snd_hash_1" sndQueue1 $ mkSndMsgData (InternalId 5) (InternalSndId 2) "snd_hash_2"
+    testCreateSndMsg' store "snd_hash_2" sndQueue1 $ mkSndMsgData (InternalId 6) (InternalSndId 3) "snd_hash_3"

tests/ProtocolErrorTests.hs

@@ -0,0 +1,18 @@
+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

@@ -1,106 +1,140 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module SMPAgentClient where
 
-import Control.Monad
 import Control.Monad.IO.Unlift
 import Crypto.Random
+import qualified Data.ByteString.Char8 as B
+import qualified Data.List.NonEmpty as L
 import Network.Socket (HostName, ServiceName)
-import SMPClient (testPort, withSmpServer, withSmpServerThreadOn)
-import Simplex.Messaging.Agent
+import SMPClient
+  ( serverBracket,
+    testKeyHash,
+    testPort,
+    testPort2,
+    withSmpServer,
+    withSmpServerOn,
+    withSmpServerThreadOn,
+  )
+import Simplex.Messaging.Agent (runSMPAgentBlocking)
 import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Agent.Transmission
+import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig)
 import Simplex.Messaging.Transport
 import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
-import qualified UnliftIO.Exception as E
-import UnliftIO.IO
 
 agentTestHost :: HostName
 agentTestHost = "localhost"
 
 agentTestPort :: ServiceName
-agentTestPort = "5001"
+agentTestPort = "5010"
 
 agentTestPort2 :: ServiceName
 agentTestPort2 = "5011"
 
 agentTestPort3 :: ServiceName
-agentTestPort3 = "5021"
+agentTestPort3 = "5012"
 
 testDB :: String
-testDB = "smp-agent.test.protocol.db"
+testDB = "tests/tmp/smp-agent.test.protocol.db"
 
 testDB2 :: String
-testDB2 = "smp-agent2.test.protocol.db"
+testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
 
 testDB3 :: String
-testDB3 = "smp-agent3.test.protocol.db"
+testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
 
-smpAgentTest :: ARawTransmission -> IO ARawTransmission
-smpAgentTest cmd = runSmpAgentTest $ \h -> tPutRaw h cmd >> tGetRaw h
+smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
+smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> tGetRaw h
 
-runSmpAgentTest :: (MonadUnliftIO m, MonadRandom m) => (Handle -> m a) -> m a
-runSmpAgentTest test = withSmpServer . withSmpAgent $ testSMPAgentClient test
+runSmpAgentTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (c -> m a) -> m a
+runSmpAgentTest test = withSmpServer t . withSmpAgent t $ testSMPAgentClient test
+  where
+    t = transport @c
 
-runSmpAgentServerTest :: (MonadUnliftIO m, MonadRandom m) => ((ThreadId, ThreadId) -> Handle -> m a) -> m a
+runSmpAgentServerTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => ((ThreadId, ThreadId) -> c -> m a) -> m a
 runSmpAgentServerTest test =
-  withSmpServerThreadOn testPort $
-    \server -> withSmpAgentThreadOn (agentTestPort, testDB) $
+  withSmpServerThreadOn t testPort $
+    \server -> withSmpAgentThreadOn t (agentTestPort, testPort, testDB) $
       \agent -> testSMPAgentClient $ test (server, agent)
+  where
+    t = transport @c
 
-smpAgentServerTest :: ((ThreadId, ThreadId) -> Handle -> IO ()) -> Expectation
+smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
 smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
 
-runSmpAgentTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => [(ServiceName, String)] -> ([Handle] -> m a) -> m a
-runSmpAgentTestN agents test = withSmpServer $ run agents []
+runSmpAgentTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, String)] -> ([c] -> m a) -> m a
+runSmpAgentTestN agents test = withSmpServer t $ run agents []
   where
-    run :: [(ServiceName, String)] -> [Handle] -> m a
+    run :: [(ServiceName, ServiceName, String)] -> [c] -> m a
     run [] hs = test hs
-    run (a@(p, _) : as) hs = withSmpAgentOn a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
+    run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
+    t = transport @c
 
-runSmpAgentTestN_1 :: forall m a. (MonadUnliftIO m, MonadRandom m) => Int -> ([Handle] -> m a) -> m a
-runSmpAgentTestN_1 nClients test = withSmpServer . withSmpAgent $ run nClients []
+runSmpAgentTestN_1 :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([c] -> m a) -> m a
+runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClients []
   where
-    run :: Int -> [Handle] -> m a
+    run :: Int -> [c] -> m a
     run 0 hs = test hs
     run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs)
+    t = transport @c
 
-smpAgentTestN :: [(ServiceName, String)] -> ([Handle] -> IO ()) -> Expectation
+smpAgentTestN :: Transport c => [(ServiceName, ServiceName, String)] -> ([c] -> IO ()) -> Expectation
 smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` ()
 
-smpAgentTestN_1 :: Int -> ([Handle] -> IO ()) -> Expectation
+smpAgentTestN_1 :: Transport c => Int -> ([c] -> IO ()) -> Expectation
 smpAgentTestN_1 n test' = runSmpAgentTestN_1 n test' `shouldReturn` ()
 
-smpAgentTest2 :: (Handle -> Handle -> IO ()) -> Expectation
-smpAgentTest2 test' =
-  smpAgentTestN [(agentTestPort, testDB), (agentTestPort2, testDB2)] _test
+smpAgentTest2_2_2 :: forall c. Transport c => (c -> c -> IO ()) -> Expectation
+smpAgentTest2_2_2 test' =
+  withSmpServerOn (transport @c) testPort2 $
+    smpAgentTestN
+      [ (agentTestPort, testPort, testDB),
+        (agentTestPort2, testPort2, testDB2)
+      ]
+      _test
   where
     _test [h1, h2] = test' h1 h2
     _test _ = error "expected 2 handles"
 
-smpAgentTest2_1 :: (Handle -> Handle -> IO ()) -> Expectation
-smpAgentTest2_1 test' = smpAgentTestN_1 2 _test
+smpAgentTest2_2_1 :: Transport c => (c -> c -> IO ()) -> Expectation
+smpAgentTest2_2_1 test' =
+  smpAgentTestN
+    [ (agentTestPort, testPort, testDB),
+      (agentTestPort2, testPort, testDB2)
+    ]
+    _test
   where
     _test [h1, h2] = test' h1 h2
     _test _ = error "expected 2 handles"
 
-smpAgentTest3 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation
+smpAgentTest2_1_1 :: Transport c => (c -> c -> IO ()) -> Expectation
+smpAgentTest2_1_1 test' = smpAgentTestN_1 2 _test
+  where
+    _test [h1, h2] = test' h1 h2
+    _test _ = error "expected 2 handles"
+
+smpAgentTest3 :: Transport c => (c -> c -> c -> IO ()) -> Expectation
 smpAgentTest3 test' =
   smpAgentTestN
-    [(agentTestPort, testDB), (agentTestPort2, testDB2), (agentTestPort3, testDB3)]
+    [ (agentTestPort, testPort, testDB),
+      (agentTestPort2, testPort, testDB2),
+      (agentTestPort3, testPort, testDB3)
+    ]
     _test
   where
     _test [h1, h2, h3] = test' h1 h2 h3
     _test _ = error "expected 3 handles"
 
-smpAgentTest3_1 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation
-smpAgentTest3_1 test' = smpAgentTestN_1 3 _test
+smpAgentTest3_1_1 :: Transport c => (c -> c -> c -> IO ()) -> Expectation
+smpAgentTest3_1_1 test' = smpAgentTestN_1 3 _test
   where
     _test [h1, h2, h3] = test' h1 h2 h3
     _test _ = error "expected 3 handles"
@@ -109,6 +143,7 @@ cfg :: AgentConfig
 cfg =
   AgentConfig
     { tcpPort = agentTestPort,
+      smpServers = L.fromList ["localhost:5000#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="],
       rsaKeySize = 2048 `div` 8,
       connIdBytes = 12,
       tbqSize = 1,
@@ -116,31 +151,31 @@ cfg =
       smpCfg =
         smpDefaultConfig
           { qSize = 1,
-            defaultPort = testPort,
+            defaultTransport = (testPort, transport @TCP),
             tcpTimeout = 500_000
           }
     }
 
-withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, String) -> (ThreadId -> m a) -> m a
-withSmpAgentThreadOn (port', db') =
-  E.bracket
-    (forkIOWithUnmask ($ runSMPAgent cfg {tcpPort = port', dbFile = db'}))
-    (liftIO . killThread >=> const (removeFile db'))
+withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a
+withSmpAgentThreadOn t (port', smpPort', db') =
+  let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" (Just smpPort') testKeyHash]}
+   in serverBracket
+        (\started -> runSMPAgentBlocking t started cfg')
+        (removeFile db')
 
-withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, String) -> m a -> m a
-withSmpAgentOn (port', db') = withSmpAgentThreadOn (port', db') . const
+withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m a -> m a
+withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const
 
-withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => m a -> m a
-withSmpAgent = withSmpAgentOn (agentTestPort, testDB)
+withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
+withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
 
-testSMPAgentClientOn :: MonadUnliftIO m => ServiceName -> (Handle -> m a) -> m a
+testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m a) -> m a
 testSMPAgentClientOn port' client = do
-  threadDelay 500_000 -- TODO hack: thread delay for SMP agent to start
-  runTCPClient agentTestHost port' $ \h -> do
+  runTransportClient agentTestHost port' $ \h -> do
     line <- liftIO $ getLn h
-    if line == "Welcome to SMP v0.2.0 agent"
+    if line == "Welcome to SMP v0.3.2 agent"
       then client h
-      else error "not connected"
+      else error $ "wrong welcome message: " <> B.unpack line
 
-testSMPAgentClient :: MonadUnliftIO m => (Handle -> m a) -> m a
+testSMPAgentClient :: (Transport c, MonadUnliftIO m) => (c -> m a) -> m a
 testSMPAgentClient = testSMPAgentClientOn agentTestPort

tests/SMPClient.hs

@@ -1,21 +1,31 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module SMPClient where
 
+import Control.Monad (void)
+import Control.Monad.Except (runExceptT)
 import Control.Monad.IO.Unlift
 import Crypto.Random
+import Data.ByteString.Base64 (encode)
+import qualified Data.ByteString.Char8 as B
 import Network.Socket
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server
+import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM
+import Simplex.Messaging.Server.StoreLog (openReadStoreLog)
 import Simplex.Messaging.Transport
 import Test.Hspec
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
-import UnliftIO.IO
+import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
+import UnliftIO.Timeout (timeout)
 
 testHost :: HostName
 testHost = "localhost"
@@ -23,63 +33,135 @@ testHost = "localhost"
 testPort :: ServiceName
 testPort = "5000"
 
-testSMPClient :: MonadUnliftIO m => (Handle -> m a) -> m a
-testSMPClient client = do
-  threadDelay 250_000 -- TODO hack: thread delay for SMP server to start
-  runTCPClient testHost testPort $ \h -> do
-    line <- liftIO $ getLn h
-    if line == "Welcome to SMP v0.2.0"
-      then client h
-      else error "not connected"
+testPort2 :: ServiceName
+testPort2 = "5001"
+
+testKeyHashStr :: B.ByteString
+testKeyHashStr = "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="
+
+testKeyHash :: Maybe C.KeyHash
+testKeyHash = Just "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="
+
+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 testKeyHash) >>= \case
+      Right th -> client th
+      Left e -> error $ show e
 
 cfg :: ServerConfig
 cfg =
   ServerConfig
-    { tcpPort = testPort,
+    { transports = undefined,
       tbqSize = 1,
       queueIdBytes = 12,
-      msgIdBytes = 6
+      msgIdBytes = 6,
+      storeLog = Nothing,
+      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="
     }
 
-withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerThreadOn port =
+withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a
+withSmpServerStoreLogOn t port client = do
+  s <- liftIO $ openReadStoreLog testStoreLogFile
+  serverBracket
+    (\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 =
+  serverBracket
+    (\started -> runSMPServerBlocking started cfg {transports = [(port, t)]})
+    (pure ())
+
+serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
+serverBracket process afterProcess f = do
+  started <- newEmptyTMVarIO
   E.bracket
-    (forkIOWithUnmask ($ runSMPServer cfg {tcpPort = port}))
-    (liftIO . killThread)
-
-withSmpServerOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> m a -> m a
-withSmpServerOn port = withSmpServerThreadOn port . const
-
-withSmpServer :: (MonadUnliftIO m, MonadRandom m) => m a -> m a
-withSmpServer = withSmpServerOn testPort
-
-runSmpTest :: (MonadUnliftIO m, MonadRandom m) => (Handle -> m a) -> m a
-runSmpTest test = withSmpServer $ testSMPClient test
-
-runSmpTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => Int -> ([Handle] -> m a) -> m a
-runSmpTestN nClients test = withSmpServer $ run nClients []
+    (forkIOWithUnmask ($ process started))
+    (\t -> killThread t >> afterProcess >> waitFor started "stop")
+    (\t -> waitFor started "start" >> f t)
   where
-    run :: Int -> [Handle] -> m a
+    waitFor started s =
+      5_000_000 `timeout` atomically (takeTMVar started) >>= \case
+        Nothing -> error $ "server did not " <> s
+        _ -> pure ()
+
+withSmpServerOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> m a -> m a
+withSmpServerOn t port = withSmpServerThreadOn t port . const
+
+withSmpServer :: (MonadUnliftIO m, MonadRandom m) => ATransport -> m a -> m a
+withSmpServer t = withSmpServerOn t testPort
+
+runSmpTest :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => (THandle c -> m a) -> m a
+runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
+
+runSmpTestN :: forall c m a. (Transport c, MonadUnliftIO m, MonadRandom m) => Int -> ([THandle c] -> m a) -> m a
+runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients []
+  where
+    run :: Int -> [THandle c] -> m a
     run 0 hs = test hs
     run n hs = testSMPClient $ \h -> run (n - 1) (h : hs)
 
-smpServerTest :: RawTransmission -> IO RawTransmission
-smpServerTest cmd = runSmpTest $ \h -> tPutRaw h cmd >> tGetRaw h
+smpServerTest :: forall c. Transport c => TProxy c -> RawTransmission -> IO RawTransmission
+smpServerTest _ cmd = runSmpTest $ \(h :: THandle c) -> tPutRaw h cmd >> tGetRaw h
 
-smpTest :: (Handle -> IO ()) -> Expectation
-smpTest test' = runSmpTest test' `shouldReturn` ()
+smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
+smpTest _ test' = runSmpTest test' `shouldReturn` ()
 
-smpTestN :: Int -> ([Handle] -> IO ()) -> Expectation
+smpTestN :: Transport c => Int -> ([THandle c] -> IO ()) -> Expectation
 smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
 
-smpTest2 :: (Handle -> Handle -> IO ()) -> Expectation
-smpTest2 test' = smpTestN 2 _test
+smpTest2 :: Transport c => TProxy c -> (THandle c -> THandle c -> IO ()) -> Expectation
+smpTest2 _ test' = smpTestN 2 _test
   where
     _test [h1, h2] = test' h1 h2
     _test _ = error "expected 2 handles"
 
-smpTest3 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation
-smpTest3 test' = smpTestN 3 _test
+smpTest3 :: Transport c => TProxy c -> (THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
+smpTest3 _ test' = smpTestN 3 _test
   where
     _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)

tests/ServerTests.hs

@@ -4,64 +4,70 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module ServerTests where
 
+import Control.Concurrent (ThreadId, killThread)
+import Control.Concurrent.STM
+import Control.Exception (SomeException, try)
+import Control.Monad.Except (forM_, runExceptT)
 import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
-import System.IO (Handle)
+import Simplex.Messaging.Transport
+import System.Directory (removeFile)
+import System.TimeIt (timeItT)
 import System.Timeout
 import Test.HUnit
 import Test.Hspec
 
 rsaKeySize :: Int
-rsaKeySize = 1024 `div` 8
+rsaKeySize = 2048 `div` 8
 
-serverTests :: Spec
-serverTests = do
-  describe "SMP syntax" syntaxTests
+serverTests :: ATransport -> Spec
+serverTests t = do
+  describe "SMP syntax" $ syntaxTests t
   describe "SMP queues" do
-    describe "NEW and KEY commands, SEND messages" testCreateSecure
-    describe "NEW, OFF and DEL commands, SEND messages" testCreateDelete
+    describe "NEW and KEY commands, SEND messages" $ testCreateSecure t
+    describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t
   describe "SMP messages" do
-    describe "duplex communication over 2 SMP connections" testDuplex
-    describe "switch subscription to another SMP queue" testSwitchSub
+    describe "duplex communication over 2 SMP connections" $ testDuplex t
+    describe "switch subscription to another SMP queue" $ testSwitchSub t
+  describe "Store log" $ testWithStoreLog t
+  describe "Timing of AUTH error" $ testTiming t
 
 pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmissionOrError
 pattern Resp corrId queueId command <- ("", (corrId, queueId, Right (Cmd SBroker command)))
 
-sendRecv :: Handle -> (ByteString, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError
+sendRecv :: 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
 
-signSendRecv :: Handle -> C.PrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError
+signSendRecv :: Transport c => THandle c -> C.SafePrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError
 signSendRecv h pk (corrId, qId, cmd) = do
-  let t = B.intercalate "\r\n" [corrId, encode qId, cmd]
-  Right sig <- C.sign pk t
-  tPut h (sig, t)
+  let t = B.intercalate " " [corrId, encode qId, cmd]
+  Right sig <- runExceptT $ C.sign pk t
+  _ <- tPut h (sig, t)
   tGet fromServer h
 
 cmdSEND :: ByteString -> ByteString
 cmdSEND msg = serializeCommand (Cmd SSender . SEND $ msg)
 
-(>#>) :: RawTransmission -> RawTransmission -> Expectation
-command >#> response = smpServerTest command `shouldReturn` response
-
 (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
 (actual, expected) #== message = assertEqual message expected actual
 
-testCreateSecure :: Spec
-testCreateSecure =
+testCreateSecure :: ATransport -> Spec
+testCreateSecure (ATransport t) =
   it "should create (NEW) and secure (KEY) queue" $
-    smpTest \h -> do
+    smpTest t $ \h -> do
       (rPub, rKey) <- C.generateKeyPair rsaKeySize
       Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub)
       (rId1, "") #== "creates queue"
 
-      Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5\r\nhello")
+      Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ")
       (ok1, OK) #== "accepts unsigned SEND"
       (sId1, sId) #== "same queue ID in response 1"
 
@@ -72,15 +78,15 @@ testCreateSecure =
       (ok4, OK) #== "replies OK when message acknowledged if no more messages"
 
       Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, "ACK")
-      (err6, ERR PROHIBITED) #== "replies ERR when message acknowledged without messages"
+      (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\r\nhello")
+      Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ")
       (err1, ERR AUTH) #== "rejects signed SEND"
       (sId2, sId) #== "same queue ID in response 2"
 
       let keyCmd = "KEY " <> C.serializePubKey sPub
-      Resp "bcda" _ err2 <- sendRecv h ("12345678", "bcda", rId, keyCmd)
+      Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, keyCmd)
       (err2, ERR AUTH) #== "rejects KEY with wrong signature"
 
       Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, keyCmd)
@@ -93,7 +99,7 @@ testCreateSecure =
       Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, keyCmd)
       (err4, ERR AUTH) #== "rejects KEY if already secured"
 
-      Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11\r\nhello again")
+      Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11 hello again ")
       (ok3, OK) #== "accepts signed SEND"
 
       Resp "" _ (MSG _ _ msg) <- tGet fromServer h
@@ -102,13 +108,13 @@ testCreateSecure =
       Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, "ACK")
       (ok5, OK) #== "replies OK when message acknowledged 2"
 
-      Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, "SEND 5\r\nhello")
+      Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, "SEND 5 hello ")
       (err5, ERR AUTH) #== "rejects unsigned SEND"
 
-testCreateDelete :: Spec
-testCreateDelete =
+testCreateDelete :: ATransport -> Spec
+testCreateDelete (ATransport t) =
   it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
-    smpTest2 \rh sh -> do
+    smpTest2 t $ \rh sh -> do
       (rPub, rKey) <- C.generateKeyPair rsaKeySize
       Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub)
       (rId1, "") #== "creates queue"
@@ -117,16 +123,16 @@ testCreateDelete =
       Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub)
       (ok1, OK) #== "secures queue"
 
-      Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5\r\nhello")
+      Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ")
       (ok2, OK) #== "accepts signed SEND"
 
-      Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND 7\r\nhello 2")
+      Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND 7 hello 2 ")
       (ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed"
 
       Resp "" _ (MSG _ _ msg1) <- tGet fromServer rh
       (msg1, "hello") #== "delivers message"
 
-      Resp "abcd" _ err1 <- sendRecv rh ("12345678", "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")
@@ -136,10 +142,10 @@ testCreateDelete =
       (ok3, OK) #== "suspends queue"
       (rId2, rId) #== "same queue ID in response 2"
 
-      Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND 5\r\nhello")
+      Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND 5 hello ")
       (err3, ERR AUTH) #== "rejects signed SEND"
 
-      Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, "SEND 5\r\nhello")
+      Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, "SEND 5 hello ")
       (err4, ERR AUTH) #== "reject unsigned SEND too"
 
       Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, "OFF")
@@ -148,7 +154,7 @@ testCreateDelete =
       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 "dabc" _ err5 <- sendRecv rh ("12345678", "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")
@@ -158,10 +164,10 @@ testCreateDelete =
       (ok6, OK) #== "deletes queue"
       (rId3, rId) #== "same queue ID in response 3"
 
-      Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND 5\r\nhello")
+      Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ")
       (err7, ERR AUTH) #== "rejects signed SEND when deleted"
 
-      Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, "SEND 5\r\nhello")
+      Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, "SEND 5 hello ")
       (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted"
 
       Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, "ACK")
@@ -173,10 +179,10 @@ testCreateDelete =
       Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, "SUB")
       (err10, ERR AUTH) #== "rejects SUB when deleted"
 
-testDuplex :: Spec
-testDuplex =
+testDuplex :: ATransport -> Spec
+testDuplex (ATransport t) =
   it "should create 2 simplex connections and exchange messages" $
-    smpTest2 \alice bob -> do
+    smpTest2 t $ \alice bob -> do
       (arPub, arKey) <- C.generateKeyPair rsaKeySize
       Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializePubKey arPub)
       -- aSnd ID is passed to Bob out-of-band
@@ -211,7 +217,7 @@ testDuplex =
       (aliceKey, C.serializePubKey asPub) #== "key received from Alice"
       Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey)
 
-      Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8\r\nhi alice")
+      Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8 hi alice ")
 
       Resp "" _ (MSG _ _ msg4) <- tGet fromServer alice
       Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "ACK")
@@ -223,13 +229,13 @@ testDuplex =
       Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "ACK")
       (msg5, "how are you bob") #== "message received from alice"
 
-testSwitchSub :: Spec
-testSwitchSub =
+testSwitchSub :: ATransport -> Spec
+testSwitchSub (ATransport t) =
   it "should create simplex connections and switch subscription to another TCP connection" $
-    smpTest3 \rh1 rh2 sh -> do
+    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\r\ntest1")
+      Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND 5 test1 ")
       (ok1, OK) #== "sent test message 1"
       Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK")
       (ok2, OK) #== "sent test message 2"
@@ -246,13 +252,13 @@ testSwitchSub =
       Resp "" _ end <- tGet fromServer rh1
       (end, END) #== "unsubscribed the 1st TCP connection"
 
-      Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5\r\ntest3")
+      Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5 test3 ")
 
       Resp "" _ (MSG _ _ msg3) <- tGet fromServer rh2
       (msg3, "test3") #== "delivered to the 2nd TCP connection"
 
       Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, "ACK")
-      (err, ERR PROHIBITED) #== "rejects ACK from the 1st TCP connection"
+      (err, ERR NO_MSG) #== "rejects ACK from the 1st TCP connection"
 
       Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, "ACK")
       (ok3, OK) #== "accepts ACK from the 2nd TCP connection"
@@ -261,40 +267,149 @@ testSwitchSub =
         Nothing -> return ()
         Just _ -> error "nothing else is delivered to the 1st TCP connection"
 
-syntaxTests :: Spec
-syntaxTests = do
-  it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR SYNTAX 2")
+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
+    senderId1 <- newTVarIO ""
+    senderId2 <- 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
+
+      (sId2, rId2, rKey2) <- 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 "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, "DEL")
+      pure ()
+
+    logSize `shouldReturn` 5
+
+    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 ")
+      pure ()
+
+    withSmpServerStoreLogOn at testPort . runTest t $ \h -> do
+      -- this queue is restored
+      sId1 <- readTVarIO senderId1
+      Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")
+      -- this queue is removed - not restored
+      sId2 <- readTVarIO senderId2
+      Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 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
+
+    logSize :: IO Int
+    logSize =
+      try (length . B.lines <$> B.readFile testStoreLogFile) >>= \case
+        Right l -> pure l
+        Left (_ :: SomeException) -> logSize
+
+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, 512, 15),
+          (256, 128, 100),
+          (256, 256, 25)
+          -- (256, 512, 15),
+          -- (512, 128, 100),
+          -- (512, 256, 25),
+          -- (512, 512, 15)
+        ]
+  where
+    timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
+    similarTime t1 t2 = abs (t1 - t2) / t1 < 0.2 `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)
+
+      (sPub, sKey) <- C.generateKeyPair senderKeySize
+      let keyCmd = "KEY " <> C.serializePubKey sPub
+      Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd)
+
+      (_, 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
+
+samplePubKey :: ByteString
+samplePubKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR"
+
+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"
+
+syntaxTests :: ATransport -> Spec
+syntaxTests (ATransport t) = do
+  it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX")
   describe "NEW" do
-    it "no parameters" $ ("1234", "bcda", "", "NEW") >#> ("", "bcda", "", "ERR SYNTAX 2")
-    it "many parameters" $ ("1234", "cdab", "", "NEW 1 2") >#> ("", "cdab", "", "ERR SYNTAX 2")
-    it "no signature" $ ("", "dabc", "", "NEW 3,1234,1234") >#> ("", "dabc", "", "ERR SYNTAX 3")
-    it "queue ID" $ ("1234", "abcd", "12345678", "NEW 3,1234,1234") >#> ("", "abcd", "12345678", "ERR SYNTAX 4")
+    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" $ ("1234", "bcda", "12345678", "KEY 3,4567,4567") >#> ("", "bcda", "12345678", "ERR AUTH")
-    it "no parameters" $ ("1234", "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR SYNTAX 2")
-    it "many parameters" $ ("1234", "dabc", "12345678", "KEY 1 2") >#> ("", "dabc", "12345678", "ERR SYNTAX 2")
-    it "no signature" $ ("", "abcd", "12345678", "KEY 3,4567,4567") >#> ("", "abcd", "12345678", "ERR SYNTAX 3")
-    it "no queue ID" $ ("1234", "bcda", "", "KEY 3,4567,4567") >#> ("", "bcda", "", "ERR SYNTAX 3")
+    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" $ ("1234", "cdab", "12345678", "SEND 5\r\nhello") >#> ("", "cdab", "12345678", "ERR AUTH")
-    it "valid syntax 2" $ ("1234", "dabc", "12345678", "SEND 11\r\nhello there") >#> ("", "dabc", "12345678", "ERR AUTH")
-    it "no parameters" $ ("1234", "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR SYNTAX 2")
-    it "no queue ID" $ ("1234", "bcda", "", "SEND 5\r\nhello") >#> ("", "bcda", "", "ERR SYNTAX 5")
-    it "bad message body 1" $ ("1234", "cdab", "12345678", "SEND 11 hello") >#> ("", "cdab", "12345678", "ERR SYNTAX 2")
-    it "bad message body 2" $ ("1234", "dabc", "12345678", "SEND hello") >#> ("", "dabc", "12345678", "ERR SYNTAX 2")
-    it "bigger body" $ ("1234", "abcd", "12345678", "SEND 4\r\nhello") >#> ("", "abcd", "12345678", "ERR SIZE")
+    it "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" $ ("1234", "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR PROHIBITED")
+    it "OK" $ (sampleSig, "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR CMD PROHIBITED")
   where
     noParamsSyntaxTest :: ByteString -> Spec
     noParamsSyntaxTest cmd = describe (B.unpack cmd) do
-      it "valid syntax" $ ("1234", "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH")
-      it "parameters" $ ("1234", "bcda", "12345678", cmd <> " 1") >#> ("", "bcda", "12345678", "ERR SYNTAX 2")
-      it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR SYNTAX 3")
-      it "no queue ID" $ ("1234", "dabc", "", cmd) >#> ("", "dabc", "", "ERR SYNTAX 3")
+      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
+    command >#> response = smpServerTest t command `shouldReturn` response

tests/Test.hs

@@ -1,10 +1,19 @@
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeApplications #-}
 
 import AgentTests
+import ProtocolErrorTests
 import ServerTests
+import Simplex.Messaging.Transport (TCP, Transport (..))
+import Simplex.Messaging.Transport.WebSockets (WS)
+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import Test.Hspec
 
 main :: IO ()
-main = hspec do
-  describe "SMP server" serverTests
-  describe "SMP client agent" agentTests
+main = do
+  createDirectoryIfMissing False "tests/tmp"
+  hspec $ do
+    describe "Protocol errors" protocolErrorTests
+    describe "SMP server via TCP" $ serverTests (transport @TCP)
+    describe "SMP server via WebSockets" $ serverTests (transport @WS)
+    describe "SMP client agent" $ agentTests (transport @TCP)
+  removeDirectoryRecursive "tests/tmp"