From 07be469f491add1c32c470e9f46cd368248906b6 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Tue, 10 Dec 2024 18:53:01 +0400 Subject: [PATCH 01/51] postgres: schema (#1416) --- simplexmq.cabal | 12 + .../Postgres/Migrations/M20241210_initial.hs | 557 ++++++++++++++++++ 2 files changed, 569 insertions(+) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 519eaf366..0db8a8f54 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -67,6 +67,11 @@ flag client_library manual: True default: False +flag client_postgres + description: Build with PostgreSQL instead of SQLite. + manual: True + default: False + library exposed-modules: Simplex.FileTransfer.Agent @@ -91,6 +96,7 @@ library Simplex.Messaging.Agent.RetryInterval Simplex.Messaging.Agent.Stats Simplex.Messaging.Agent.Store + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial Simplex.Messaging.Agent.Store.SQLite Simplex.Messaging.Agent.Store.SQLite.Common Simplex.Messaging.Agent.Store.SQLite.DB @@ -280,6 +286,9 @@ library build-depends: case-insensitive ==1.2.* , hashable ==1.4.* + if flag(client_postgres) + build-depends: + postgresql-simple ==0.6.* if impl(ghc >= 9.6.2) build-depends: bytestring ==0.11.* @@ -469,3 +478,6 @@ test-suite simplexmq-test , warp-tls , yaml default-language: Haskell2010 + if flag(client_postgres) + build-depends: + postgresql-simple ==0.6.* diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs new file mode 100644 index 000000000..9008c86ce --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs @@ -0,0 +1,557 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial where + +import Database.PostgreSQL.Simple (Query) +import Database.PostgreSQL.Simple.SqlQQ (sql) + +m20241210_initial :: Query +m20241210_initial = + [sql| +REVOKE CREATE ON SCHEMA public FROM PUBLIC; + +-- TODO remove +DROP SCHEMA IF EXISTS agent_schema CASCADE; +CREATE SCHEMA agent_schema; + +SET search_path TO agent_schema; + +CREATE TABLE migrations( + name TEXT NOT NULL, + ts TEXT NOT NULL, + down TEXT, + PRIMARY KEY(name) +); +CREATE TABLE users( + user_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + deleted INTEGER NOT NULL DEFAULT 0 +); +INSERT INTO users (user_id) OVERRIDING SYSTEM VALUE VALUES (1); +CREATE TABLE servers( + host TEXT NOT NULL, + port TEXT NOT NULL, + key_hash BYTEA NOT NULL, + PRIMARY KEY(host, port) +); +CREATE TABLE connections( + conn_id BYTEA NOT NULL PRIMARY KEY, + conn_mode TEXT NOT NULL, + last_internal_msg_id INTEGER NOT NULL DEFAULT 0, + last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0, + last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0, + last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0, + last_rcv_msg_hash BYTEA NOT NULL DEFAULT E'\\x', + last_snd_msg_hash BYTEA NOT NULL DEFAULT E'\\x', + smp_agent_version INTEGER NOT NULL DEFAULT 1, + duplex_handshake INTEGER NULL DEFAULT 0, + enable_ntfs INTEGER, + deleted INTEGER NOT NULL DEFAULT 0, + user_id INTEGER NOT NULL DEFAULT 1 + REFERENCES users ON DELETE CASCADE, + ratchet_sync_state TEXT NOT NULL DEFAULT 'ok', + deleted_at_wait_delivery TIMESTAMP, + pq_support INTEGER NOT NULL DEFAULT 0 +); +CREATE TABLE rcv_queues( + host TEXT NOT NULL, + port TEXT NOT NULL, + rcv_id BYTEA NOT NULL, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + rcv_private_key BYTEA NOT NULL, + rcv_dh_secret BYTEA NOT NULL, + e2e_priv_key BYTEA NOT NULL, + e2e_dh_secret BYTEA, + snd_id BYTEA NOT NULL, + snd_key BYTEA, + status TEXT NOT NULL, + smp_server_version INTEGER NOT NULL DEFAULT 1, + smp_client_version INTEGER, + ntf_public_key BYTEA, + ntf_private_key BYTEA, + ntf_id BYTEA, + rcv_ntf_dh_secret BYTEA, + rcv_queue_id INTEGER NOT NULL, + rcv_primary INTEGER NOT NULL, + replace_rcv_queue_id INTEGER NULL, + delete_errors INTEGER NOT NULL DEFAULT 0, + server_key_hash BYTEA, + switch_status TEXT, + deleted INTEGER NOT NULL DEFAULT 0, + snd_secure INTEGER NOT NULL DEFAULT 0, + last_broker_ts TIMESTAMP, + PRIMARY KEY(host, port, rcv_id), + FOREIGN KEY(host, port) REFERENCES servers + ON DELETE RESTRICT ON UPDATE CASCADE, + UNIQUE(host, port, snd_id) +); +CREATE TABLE snd_queues( + host TEXT NOT NULL, + port TEXT NOT NULL, + snd_id BYTEA NOT NULL, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + snd_private_key BYTEA NOT NULL, + e2e_dh_secret BYTEA NOT NULL, + status TEXT NOT NULL, + smp_server_version INTEGER NOT NULL DEFAULT 1, + smp_client_version INTEGER NOT NULL DEFAULT 1, + snd_public_key BYTEA, + e2e_pub_key BYTEA, + snd_queue_id INTEGER NOT NULL, + snd_primary INTEGER NOT NULL, + replace_snd_queue_id INTEGER NULL, + server_key_hash BYTEA, + switch_status TEXT, + snd_secure INTEGER NOT NULL DEFAULT 0, + PRIMARY KEY(host, port, snd_id), + FOREIGN KEY(host, port) REFERENCES servers + ON DELETE RESTRICT ON UPDATE CASCADE +); +CREATE TABLE messages( + conn_id BYTEA NOT NULL REFERENCES connections(conn_id) + ON DELETE CASCADE, + internal_id INTEGER NOT NULL, + internal_ts TIMESTAMP NOT NULL, + internal_rcv_id INTEGER, + internal_snd_id INTEGER, + msg_type BYTEA NOT NULL, + msg_body BYTEA NOT NULL DEFAULT E'\\x', + msg_flags TEXT NULL, + pq_encryption INTEGER NOT NULL DEFAULT 0, + PRIMARY KEY(conn_id, internal_id) +); +CREATE TABLE rcv_messages( + conn_id BYTEA NOT NULL, + internal_rcv_id INTEGER NOT NULL, + internal_id INTEGER NOT NULL, + external_snd_id INTEGER NOT NULL, + broker_id BYTEA NOT NULL, + broker_ts TIMESTAMP NOT NULL, + internal_hash BYTEA NOT NULL, + external_prev_snd_hash BYTEA NOT NULL, + integrity BYTEA NOT NULL, + user_ack INTEGER NULL DEFAULT 0, + rcv_queue_id INTEGER NOT NULL, + PRIMARY KEY(conn_id, internal_rcv_id), + FOREIGN KEY(conn_id, internal_id) REFERENCES messages + ON DELETE CASCADE +); +ALTER TABLE messages +ADD CONSTRAINT fk_messages_rcv_messages + FOREIGN KEY (conn_id, internal_rcv_id) REFERENCES rcv_messages + ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED; +CREATE TABLE snd_messages( + conn_id BYTEA NOT NULL, + internal_snd_id INTEGER NOT NULL, + internal_id INTEGER NOT NULL, + internal_hash BYTEA NOT NULL, + previous_msg_hash BYTEA NOT NULL DEFAULT E'\\x', + retry_int_slow INTEGER, + retry_int_fast INTEGER, + rcpt_internal_id INTEGER, + rcpt_status TEXT, + PRIMARY KEY(conn_id, internal_snd_id), + FOREIGN KEY(conn_id, internal_id) REFERENCES messages + ON DELETE CASCADE +); +ALTER TABLE messages +ADD CONSTRAINT fk_messages_snd_messages + FOREIGN KEY (conn_id, internal_snd_id) REFERENCES snd_messages + ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED; +CREATE TABLE conn_confirmations( + confirmation_id BYTEA NOT NULL PRIMARY KEY, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + e2e_snd_pub_key BYTEA NOT NULL, + sender_key BYTEA, + ratchet_state BYTEA NOT NULL, + sender_conn_info BYTEA NOT NULL, + accepted INTEGER NOT NULL, + own_conn_info BYTEA, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + smp_reply_queues BYTEA NULL, + smp_client_version INTEGER +); +CREATE TABLE conn_invitations( + invitation_id BYTEA NOT NULL PRIMARY KEY, + contact_conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + cr_invitation BYTEA NOT NULL, + recipient_conn_info BYTEA NOT NULL, + accepted INTEGER NOT NULL DEFAULT 0, + own_conn_info BYTEA, + created_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE ratchets( + conn_id BYTEA NOT NULL PRIMARY KEY REFERENCES connections + ON DELETE CASCADE, + x3dh_priv_key_1 BYTEA, + x3dh_priv_key_2 BYTEA, + ratchet_state BYTEA, + e2e_version INTEGER NOT NULL DEFAULT 1, + x3dh_pub_key_1 BYTEA, + x3dh_pub_key_2 BYTEA, + pq_priv_kem BYTEA +); +CREATE TABLE skipped_messages( + skipped_message_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + conn_id BYTEA NOT NULL REFERENCES ratchets + ON DELETE CASCADE, + header_key BYTEA NOT NULL, + msg_n INTEGER NOT NULL, + msg_key BYTEA NOT NULL +); +CREATE TABLE ntf_servers( + ntf_host TEXT NOT NULL, + ntf_port TEXT NOT NULL, + ntf_key_hash BYTEA NOT NULL, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()), + PRIMARY KEY(ntf_host, ntf_port) +); +CREATE TABLE ntf_tokens( + provider TEXT NOT NULL, + device_token TEXT NOT NULL, + ntf_host TEXT NOT NULL, + ntf_port TEXT NOT NULL, + tkn_id BYTEA, + tkn_pub_key BYTEA NOT NULL, +tkn_priv_key BYTEA NOT NULL, +tkn_pub_dh_key BYTEA NOT NULL, +tkn_priv_dh_key BYTEA NOT NULL, +tkn_dh_secret BYTEA, + tkn_status TEXT NOT NULL, + tkn_action BYTEA, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()), + ntf_mode TEXT NULL, + PRIMARY KEY(provider, device_token, ntf_host, ntf_port), + FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers + ON DELETE RESTRICT ON UPDATE CASCADE +); +CREATE TABLE ntf_subscriptions( + conn_id BYTEA NOT NULL, + smp_host TEXT NULL, + smp_port TEXT NULL, + smp_ntf_id BYTEA, + ntf_host TEXT NOT NULL, + ntf_port TEXT NOT NULL, + ntf_sub_id BYTEA, + ntf_sub_status TEXT NOT NULL, + ntf_sub_action TEXT, + ntf_sub_smp_action TEXT, + ntf_sub_action_ts TIMESTAMP, + updated_by_supervisor INTEGER NOT NULL DEFAULT 0, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()), + smp_server_key_hash BYTEA, + ntf_failed INTEGER DEFAULT 0, + smp_failed INTEGER DEFAULT 0, + PRIMARY KEY(conn_id), + FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port) + ON DELETE SET NULL ON UPDATE CASCADE, + FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers + ON DELETE RESTRICT ON UPDATE CASCADE +); +CREATE TABLE commands( + command_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + host TEXT, + port TEXT, + corr_id BYTEA NOT NULL, + command_tag BYTEA NOT NULL, + command BYTEA NOT NULL, + agent_version INTEGER NOT NULL DEFAULT 1, + server_key_hash BYTEA, + created_at TIMESTAMP NOT NULL DEFAULT '1970-01-01 00:00:00', + failed INTEGER DEFAULT 0, + FOREIGN KEY(host, port) REFERENCES servers + ON DELETE RESTRICT ON UPDATE CASCADE +); +CREATE TABLE snd_message_deliveries( + snd_message_delivery_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + snd_queue_id INTEGER NOT NULL, + internal_id INTEGER NOT NULL, + failed INTEGER DEFAULT 0, + FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED +); +CREATE TABLE xftp_servers( + xftp_server_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + xftp_host TEXT NOT NULL, + xftp_port TEXT NOT NULL, + xftp_key_hash BYTEA NOT NULL, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()), + UNIQUE(xftp_host, xftp_port, xftp_key_hash) +); +CREATE TABLE rcv_files( + rcv_file_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + rcv_file_entity_id BYTEA NOT NULL, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + size INTEGER NOT NULL, + digest BYTEA NOT NULL, + key BYTEA NOT NULL, + nonce BYTEA NOT NULL, + chunk_size INTEGER NOT NULL, + prefix_path TEXT NOT NULL, + tmp_path TEXT, + save_path TEXT NOT NULL, + status TEXT NOT NULL, + deleted INTEGER NOT NULL DEFAULT 0, + error TEXT, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()), + save_file_key BYTEA, + save_file_nonce BYTEA, + failed INTEGER DEFAULT 0, + redirect_id INTEGER REFERENCES rcv_files ON DELETE SET NULL, + redirect_entity_id BYTEA, + redirect_size INTEGER, + redirect_digest BYTEA, + approved_relays INTEGER NOT NULL DEFAULT 0, + UNIQUE(rcv_file_entity_id) +); +CREATE TABLE rcv_file_chunks( + rcv_file_chunk_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE, + chunk_no INTEGER NOT NULL, + chunk_size INTEGER NOT NULL, + digest BYTEA NOT NULL, + tmp_path TEXT, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE rcv_file_chunk_replicas( + rcv_file_chunk_replica_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE, + replica_number INTEGER NOT NULL, + xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + replica_id BYTEA NOT NULL, + replica_key BYTEA NOT NULL, + received INTEGER NOT NULL DEFAULT 0, + delay INTEGER, + retries INTEGER NOT NULL DEFAULT 0, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE snd_files( + snd_file_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_entity_id BYTEA NOT NULL, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + num_recipients INTEGER NOT NULL, + digest BYTEA, + key BYTEA NOT NUll, + nonce BYTEA NOT NUll, + path TEXT NOT NULL, + prefix_path TEXT, + status TEXT NOT NULL, + deleted INTEGER NOT NULL DEFAULT 0, + error TEXT, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()), + src_file_key BYTEA, + src_file_nonce BYTEA, + failed INTEGER DEFAULT 0, + redirect_size INTEGER, + redirect_digest BYTEA +); +CREATE TABLE snd_file_chunks( + snd_file_chunk_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE, + chunk_no INTEGER NOT NULL, + chunk_offset INTEGER NOT NULL, + chunk_size INTEGER NOT NULL, + digest BYTEA NOT NULL, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE snd_file_chunk_replicas( + snd_file_chunk_replica_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_chunk_id INTEGER NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE, + replica_number INTEGER NOT NULL, + xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + replica_id BYTEA NOT NULL, + replica_key BYTEA NOT NULL, + replica_status TEXT NOT NULL, + delay INTEGER, + retries INTEGER NOT NULL DEFAULT 0, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE snd_file_chunk_replica_recipients( + snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_chunk_replica_id INTEGER NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE, + rcv_replica_id BYTEA NOT NULL, + rcv_replica_key BYTEA NOT NULL, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE deleted_snd_chunk_replicas( + deleted_snd_chunk_replica_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + replica_id BYTEA NOT NULL, + replica_key BYTEA NOT NULL, + chunk_digest BYTEA NOT NULL, + delay INTEGER, + retries INTEGER NOT NULL DEFAULT 0, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()), + failed INTEGER DEFAULT 0 +); +CREATE TABLE encrypted_rcv_message_hashes( + encrypted_rcv_message_hash_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + hash BYTEA NOT NULL, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE processed_ratchet_key_hashes( + processed_ratchet_key_hash_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + hash BYTEA NOT NULL, + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE servers_stats( + servers_stats_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + servers_stats TEXT, + started_at TIMESTAMP NOT NULL DEFAULT (now()), + created_at TIMESTAMP NOT NULL DEFAULT (now()), + updated_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE TABLE ntf_tokens_to_delete( + ntf_token_to_delete_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + ntf_host TEXT NOT NULL, + ntf_port TEXT NOT NULL, + ntf_key_hash BYTEA NOT NULL, + tkn_id BYTEA NOT NULL, + tkn_priv_key BYTEA NOT NULL, +del_failed INTEGER DEFAULT 0, +created_at TIMESTAMP NOT NULL DEFAULT (now()) +); +CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); +CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id); +CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id); +CREATE INDEX idx_snd_message_deliveries ON snd_message_deliveries( + conn_id, + snd_queue_id +); +CREATE INDEX idx_connections_user ON connections(user_id); +CREATE INDEX idx_commands_conn_id ON commands(conn_id); +CREATE INDEX idx_commands_host_port ON commands(host, port); +CREATE INDEX idx_conn_confirmations_conn_id ON conn_confirmations(conn_id); +CREATE INDEX idx_conn_invitations_contact_conn_id ON conn_invitations( + contact_conn_id +); +CREATE INDEX idx_messages_conn_id_internal_snd_id ON messages( + conn_id, + internal_snd_id +); +CREATE INDEX idx_messages_conn_id_internal_rcv_id ON messages( + conn_id, + internal_rcv_id +); +CREATE INDEX idx_messages_conn_id ON messages(conn_id); +CREATE INDEX idx_ntf_subscriptions_ntf_host_ntf_port ON ntf_subscriptions( + ntf_host, + ntf_port +); +CREATE INDEX idx_ntf_subscriptions_smp_host_smp_port ON ntf_subscriptions( + smp_host, + smp_port +); +CREATE INDEX idx_ntf_tokens_ntf_host_ntf_port ON ntf_tokens( + ntf_host, + ntf_port +); +CREATE INDEX idx_ratchets_conn_id ON ratchets(conn_id); +CREATE INDEX idx_rcv_messages_conn_id_internal_id ON rcv_messages( + conn_id, + internal_id +); +CREATE INDEX idx_skipped_messages_conn_id ON skipped_messages(conn_id); +CREATE INDEX idx_snd_message_deliveries_conn_id_internal_id ON snd_message_deliveries( + conn_id, + internal_id +); +CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages( + conn_id, + internal_id +); +CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port); +CREATE INDEX idx_rcv_files_user_id ON rcv_files(user_id); +CREATE INDEX idx_rcv_file_chunks_rcv_file_id ON rcv_file_chunks(rcv_file_id); +CREATE INDEX idx_rcv_file_chunk_replicas_rcv_file_chunk_id ON rcv_file_chunk_replicas( + rcv_file_chunk_id +); +CREATE INDEX idx_rcv_file_chunk_replicas_xftp_server_id ON rcv_file_chunk_replicas( + xftp_server_id +); +CREATE INDEX idx_snd_files_user_id ON snd_files(user_id); +CREATE INDEX idx_snd_file_chunks_snd_file_id ON snd_file_chunks(snd_file_id); +CREATE INDEX idx_snd_file_chunk_replicas_snd_file_chunk_id ON snd_file_chunk_replicas( + snd_file_chunk_id +); +CREATE INDEX idx_snd_file_chunk_replicas_xftp_server_id ON snd_file_chunk_replicas( + xftp_server_id +); +CREATE INDEX idx_snd_file_chunk_replica_recipients_snd_file_chunk_replica_id ON snd_file_chunk_replica_recipients( + snd_file_chunk_replica_id +); +CREATE INDEX idx_deleted_snd_chunk_replicas_user_id ON deleted_snd_chunk_replicas( + user_id +); +CREATE INDEX idx_deleted_snd_chunk_replicas_xftp_server_id ON deleted_snd_chunk_replicas( + xftp_server_id +); +CREATE INDEX idx_rcv_file_chunk_replicas_pending ON rcv_file_chunk_replicas( + received, + replica_number +); +CREATE INDEX idx_snd_file_chunk_replicas_pending ON snd_file_chunk_replicas( + replica_status, + replica_number +); +CREATE INDEX idx_deleted_snd_chunk_replicas_pending ON deleted_snd_chunk_replicas( + created_at +); +CREATE INDEX idx_encrypted_rcv_message_hashes_hash ON encrypted_rcv_message_hashes( + conn_id, + hash +); +CREATE INDEX idx_processed_ratchet_key_hashes_hash ON processed_ratchet_key_hashes( + conn_id, + hash +); +CREATE INDEX idx_snd_messages_rcpt_internal_id ON snd_messages( + conn_id, + rcpt_internal_id +); +CREATE INDEX idx_processed_ratchet_key_hashes_created_at ON processed_ratchet_key_hashes( + created_at +); +CREATE INDEX idx_encrypted_rcv_message_hashes_created_at ON encrypted_rcv_message_hashes( + created_at +); +CREATE INDEX idx_messages_internal_ts ON messages(internal_ts); +CREATE INDEX idx_commands_server_commands ON commands( + host, + port, + created_at, + command_id +); +CREATE INDEX idx_rcv_files_status_created_at ON rcv_files(status, created_at); +CREATE INDEX idx_snd_files_status_created_at ON snd_files(status, created_at); +CREATE INDEX idx_snd_files_snd_file_entity_id ON snd_files(snd_file_entity_id); +CREATE INDEX idx_messages_snd_expired ON messages( + conn_id, + internal_snd_id, + internal_ts +); +CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries( + conn_id, + snd_queue_id, + failed, + internal_id +); +CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id); +|] From 64149599dea96062c218cee111c42920e3e2b88c Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Thu, 12 Dec 2024 17:42:58 +0400 Subject: [PATCH 02/51] postgres: db interfaces wip (sqlite passes) (#1419) --- simplexmq.cabal | 99 +- src/Simplex/FileTransfer/Agent.hs | 4 +- src/Simplex/Messaging/Agent.hs | 16 +- src/Simplex/Messaging/Agent/Client.hs | 12 +- src/Simplex/Messaging/Agent/Env/SQLite.hs | 25 +- .../Messaging/Agent/NtfSubSupervisor.hs | 4 +- src/Simplex/Messaging/Agent/Store.hs | 28 +- .../Messaging/Agent/Store/AgentStore.hs | 2972 ++++++++++++++++ src/Simplex/Messaging/Agent/Store/Common.hs | 14 + src/Simplex/Messaging/Agent/Store/DB.hs | 15 + .../Messaging/Agent/Store/Migrations.hs | 95 + src/Simplex/Messaging/Agent/Store/Postgres.hs | 42 + .../Messaging/Agent/Store/Postgres/Common.hs | 47 + .../Messaging/Agent/Store/Postgres/DB.hs | 26 + .../Agent/Store/Postgres/Migrations.hs | 42 + .../Postgres/Migrations/M20241210_initial.hs | 18 +- src/Simplex/Messaging/Agent/Store/SQLite.hs | 3070 +---------------- .../Messaging/Agent/Store/SQLite/Common.hs | 18 +- .../Messaging/Agent/Store/SQLite/DB.hs | 11 +- .../Agent/Store/SQLite/Migrations.hs | 85 +- src/Simplex/Messaging/Agent/Store/Shared.hs | 93 + tests/AgentTests/FunctionalAPITests.hs | 6 +- tests/AgentTests/MigrationTests.hs | 19 +- tests/AgentTests/NotificationTests.hs | 6 +- tests/AgentTests/SQLiteTests.hs | 120 +- tests/AgentTests/SchemaDump.hs | 23 +- 26 files changed, 3623 insertions(+), 3287 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/AgentStore.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Common.hs create mode 100644 src/Simplex/Messaging/Agent/Store/DB.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Migrations.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Common.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/DB.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Shared.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 0db8a8f54..81f5ee808 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -96,47 +96,11 @@ library Simplex.Messaging.Agent.RetryInterval Simplex.Messaging.Agent.Stats Simplex.Messaging.Agent.Store - Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial - Simplex.Messaging.Agent.Store.SQLite - Simplex.Messaging.Agent.Store.SQLite.Common - Simplex.Messaging.Agent.Store.SQLite.DB - Simplex.Messaging.Agent.Store.SQLite.Migrations - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts + Simplex.Messaging.Agent.Store.AgentStore + Simplex.Messaging.Agent.Store.Common + Simplex.Messaging.Agent.Store.DB + Simplex.Messaging.Agent.Store.Migrations + Simplex.Messaging.Agent.Store.Shared Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent @@ -183,6 +147,55 @@ library Simplex.RemoteControl.Discovery.Multicast Simplex.RemoteControl.Invitation Simplex.RemoteControl.Types + if flag(client_postgres) + exposed-modules: + Simplex.Messaging.Agent.Store.Postgres + Simplex.Messaging.Agent.Store.Postgres.Common + Simplex.Messaging.Agent.Store.Postgres.DB + Simplex.Messaging.Agent.Store.Postgres.Migrations + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial + else + exposed-modules: + Simplex.Messaging.Agent.Store.SQLite + Simplex.Messaging.Agent.Store.SQLite.Common + Simplex.Messaging.Agent.Store.SQLite.DB + Simplex.Messaging.Agent.Store.SQLite.Migrations + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts if !flag(client_library) exposed-modules: Simplex.FileTransfer.Server @@ -289,6 +302,8 @@ library if flag(client_postgres) build-depends: postgresql-simple ==0.6.* + , raw-strings-qq ==1.1.* + cpp-options: -DdbPostgres if impl(ghc >= 9.6.2) build-depends: bytestring ==0.11.* @@ -481,3 +496,5 @@ test-suite simplexmq-test if flag(client_postgres) build-depends: postgresql-simple ==0.6.* + , raw-strings-qq ==1.1.* + cpp-options: -DdbPostgres diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 2b6c1c5af..6661e2376 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -66,8 +66,8 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Stats -import Simplex.Messaging.Agent.Store.SQLite -import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import Simplex.Messaging.Agent.Store.AgentStore +import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index f267baf28..e82ff7999 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -167,9 +167,11 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store -import Simplex.Messaging.Agent.Store.SQLite -import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB -import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import Simplex.Messaging.Agent.Store.AgentStore +import Simplex.Messaging.Agent.Store.Common (DBStore) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import qualified Simplex.Messaging.Agent.Store.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration) import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) @@ -200,11 +202,11 @@ import UnliftIO.STM type AE a = ExceptT AgentErrorType IO a -- | Creates an SMP agent client instance -getSMPAgentClient :: AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> IO AgentClient +getSMPAgentClient :: AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient getSMPAgentClient = getSMPAgentClient_ 1 {-# INLINE getSMPAgentClient #-} -getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Bool -> IO AgentClient +getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> DBStore -> Bool -> IO AgentClient getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp} store backgroundMode = newSMPAgentEnv cfg store >>= runReaderT runAgent where @@ -277,7 +279,7 @@ disposeAgentClient c@AgentClient {acThread, agentEnv = Env {store}} = do t_ <- atomically (swapTVar acThread Nothing) $>>= (liftIO . deRefWeak) disconnectAgentClient c mapM_ killThread t_ - liftIO $ closeSQLiteStore store + liftIO $ closeStore store resumeAgentClient :: AgentClient -> IO () resumeAgentClient c = atomically $ writeTVar (active c) True @@ -2154,7 +2156,7 @@ execAgentStoreSQL :: AgentClient -> Text -> AE [Text] execAgentStoreSQL c sql = withAgentEnv c $ withStore' c (`execSQL` sql) getAgentMigrations :: AgentClient -> AE [UpMigration] -getAgentMigrations c = withAgentEnv c $ map upMigration <$> withStore' c (Migrations.getCurrent . DB.conn) +getAgentMigrations c = withAgentEnv c $ map upMigration <$> withStore' c Migrations.getCurrent debugAgentLocks :: AgentClient -> IO AgentLocks debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index ef55870fe..8068f171f 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -221,8 +221,8 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store -import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction) -import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.TRcvQueues (TRcvQueues (getRcvQueues)) import qualified Simplex.Messaging.Agent.TRcvQueues as RQ import Simplex.Messaging.Client @@ -555,7 +555,7 @@ slowNetworkConfig cfg@NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPe slow :: Integral a => a -> a slow t = (t * 3) `div` 2 -agentClientStore :: AgentClient -> SQLiteStore +agentClientStore :: AgentClient -> DBStore agentClientStore AgentClient {agentEnv = Env {store}} = store {-# INLINE agentClientStore #-} @@ -1649,7 +1649,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_ sendAck :: AgentClient -> RcvQueue -> MsgId -> AM () sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp -> - ackSMPMessage smp rcvPrivateKey rcvId msgId + ackSMPMessage smp rcvPrivateKey rcvId msgId hasGetLock :: AgentClient -> RcvQueue -> IO Bool hasGetLock c RcvQueue {server, rcvId} = @@ -2044,7 +2044,7 @@ pickServer = \case getNextServer :: (ProtocolTypeI p, UserProtocol p) => AgentClient -> - UserId -> + UserId -> (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) -> [ProtocolServer p] -> AM (ProtoServerWithAuth p) @@ -2097,7 +2097,7 @@ withNextSrv :: UserId -> (UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) -> TVar (Set TransportHost) -> - [ProtocolServer p] -> + [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a withNextSrv c userId srvsSel triedHosts usedSrvs action = do diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index a78fb428e..b6a3830c7 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -52,7 +53,6 @@ import Control.Monad.Reader import Crypto.Random import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as JQ -import Data.ByteArray (ScrubbedBytes) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L @@ -68,8 +68,9 @@ import Numeric.Natural import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval -import Simplex.Messaging.Agent.Store.SQLite -import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import Simplex.Messaging.Agent.Store (createStore) +import Simplex.Messaging.Agent.Store.Common (DBStore) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange) @@ -86,6 +87,10 @@ import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryA import System.Mem.Weak (Weak) import System.Random (StdGen, newStdGen) import UnliftIO.STM +#if defined(dbPostgres) +#else +import Data.ByteArray (ScrubbedBytes) +#endif type AM' a = ReaderT Env IO a @@ -254,7 +259,7 @@ defaultAgentConfig = data Env = Env { config :: AgentConfig, - store :: SQLiteStore, + store :: DBStore, random :: TVar ChaChaDRG, randomServer :: TVar StdGen, ntfSupervisor :: NtfSupervisor, @@ -262,7 +267,7 @@ data Env = Env multicastSubscribers :: TMVar Int } -newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env +newSMPAgentEnv :: AgentConfig -> DBStore -> IO Env newSMPAgentEnv config store = do random <- C.newRandom randomServer <- newTVarIO =<< liftIO newStdGen @@ -271,8 +276,14 @@ newSMPAgentEnv config store = do multicastSubscribers <- newTMVarIO 0 pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers} -createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore) -createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey keepKey Migrations.app +#if defined(dbPostgres) +-- TODO [postgres] pass db name / ConnectInfo? +createAgentStore :: MigrationConfirmation -> IO (Either MigrationError DBStore) +createAgentStore = createStore +#else +createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createAgentStore = createStore +#endif data NtfSupervisor = NtfSupervisor { ntfTkn :: TVar (Maybe NtfToken), diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index f000de8be..3da1b74b6 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -43,8 +43,8 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store -import Simplex.Messaging.Agent.Store.SQLite -import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import Simplex.Messaging.Agent.Store.AgentStore +import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Types diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 0e2a7bbe9..1f21c7e71 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -25,10 +26,15 @@ import Data.List (find) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Maybe (isJust) +import Data.Text (Text) import Data.Time (UTCTime) import Data.Type.Equality import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State) +import Simplex.Messaging.Agent.Store.Common +import qualified Simplex.Messaging.Agent.Store.DB as DB +import qualified Simplex.Messaging.Agent.Store.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, RatchetX448) import Simplex.Messaging.Encoding.String @@ -42,12 +48,32 @@ import Simplex.Messaging.Protocol RcvDhSecret, RcvNtfDhSecret, RcvPrivateAuthKey, + SenderCanSecure, SndPrivateAuthKey, SndPublicAuthKey, - SenderCanSecure, VersionSMPC, ) import qualified Simplex.Messaging.Protocol as SMP +#if defined(dbPostgres) +import qualified Simplex.Messaging.Agent.Store.Postgres as StoreFunctions +#else +import qualified Simplex.Messaging.Agent.Store.SQLite as StoreFunctions +import Data.ByteArray (ScrubbedBytes) +#endif + +#if defined(dbPostgres) +createStore :: MigrationConfirmation -> IO (Either MigrationError DBStore) +createStore = StoreFunctions.createDBStore Migrations.app +#else +createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createStore dbFilePath dbKey keepKey = StoreFunctions.createDBStore dbFilePath dbKey keepKey Migrations.app +#endif + +closeStore :: DBStore -> IO () +closeStore = StoreFunctions.closeDBStore + +execSQL :: DB.Connection -> Text -> IO [Text] +execSQL = StoreFunctions.execSQL -- * Queue types diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs new file mode 100644 index 000000000..a2ecab6ea --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -0,0 +1,2972 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Simplex.Messaging.Agent.Store.AgentStore + ( -- * Users + createUserRecord, + deleteUserRecord, + setUserDeleted, + deleteUserWithoutConns, + deleteUsersWithoutConns, + checkUser, + + -- * Queues and connections + createNewConn, + updateNewConnRcv, + updateNewConnSnd, + createSndConn, + getConn, + getDeletedConn, + getConns, + getDeletedConns, + getConnData, + setConnDeleted, + setConnUserId, + setConnAgentVersion, + setConnPQSupport, + getDeletedConnIds, + getDeletedWaitingDeliveryConnIds, + setConnRatchetSync, + addProcessedRatchetKeyHash, + checkRatchetKeyHashExists, + deleteRatchetKeyHashesExpired, + getRcvConn, + getRcvQueueById, + getSndQueueById, + deleteConn, + upgradeRcvConnToDuplex, + upgradeSndConnToDuplex, + addConnRcvQueue, + addConnSndQueue, + setRcvQueueStatus, + setRcvSwitchStatus, + setRcvQueueDeleted, + setRcvQueueConfirmedE2E, + setSndQueueStatus, + setSndSwitchStatus, + setRcvQueuePrimary, + setSndQueuePrimary, + deleteConnRcvQueue, + incRcvDeleteErrors, + deleteConnSndQueue, + getPrimaryRcvQueue, + getRcvQueue, + getDeletedRcvQueue, + setRcvQueueNtfCreds, + -- Confirmations + createConfirmation, + acceptConfirmation, + getAcceptedConfirmation, + removeConfirmations, + -- Invitations - sent via Contact connections + createInvitation, + getInvitation, + acceptInvitation, + unacceptInvitation, + deleteInvitation, + -- Messages + updateRcvIds, + createRcvMsg, + updateRcvMsgHash, + updateSndIds, + createSndMsg, + updateSndMsgHash, + createSndMsgDelivery, + getSndMsgViaRcpt, + updateSndMsgRcpt, + getPendingQueueMsg, + getConnectionsForDelivery, + updatePendingMsgRIState, + deletePendingMsgs, + getExpiredSndMessages, + setMsgUserAck, + getRcvMsg, + getLastMsg, + checkRcvMsgHashExists, + getRcvMsgBrokerTs, + deleteMsg, + deleteDeliveredSndMsg, + deleteSndMsgDelivery, + deleteRcvMsgHashesExpired, + deleteSndMsgsExpired, + -- Double ratchet persistence + createRatchetX3dhKeys, + getRatchetX3dhKeys, + setRatchetX3dhKeys, + createRatchet, + deleteRatchet, + getRatchet, + getSkippedMsgKeys, + updateRatchet, + -- Async commands + createCommand, + getPendingCommandServers, + getPendingServerCommand, + updateCommandServer, + deleteCommand, + -- Notification device token persistence + createNtfToken, + getSavedNtfToken, + updateNtfTokenRegistration, + updateDeviceToken, + updateNtfMode, + updateNtfToken, + removeNtfToken, + addNtfTokenToDelete, + deleteExpiredNtfTokensToDelete, + NtfTokenToDelete, + getNextNtfTokenToDelete, + markNtfTokenToDeleteFailed_, -- exported for tests + getPendingDelTknServers, + deleteNtfTokenToDelete, + -- Notification subscription persistence + NtfSupervisorSub, + getNtfSubscription, + createNtfSubscription, + supervisorUpdateNtfSub, + supervisorUpdateNtfAction, + updateNtfSubscription, + setNullNtfSubscriptionAction, + deleteNtfSubscription, + deleteNtfSubscription', + getNextNtfSubNTFActions, + markNtfSubActionNtfFailed_, -- exported for tests + getNextNtfSubSMPActions, + markNtfSubActionSMPFailed_, -- exported for tests + getActiveNtfToken, + getNtfRcvQueue, + setConnectionNtfs, + + -- * File transfer + + -- Rcv files + createRcvFile, + createRcvFileRedirect, + getRcvFile, + getRcvFileByEntityId, + getRcvFileRedirects, + updateRcvChunkReplicaDelay, + updateRcvFileChunkReceived, + updateRcvFileStatus, + updateRcvFileError, + updateRcvFileComplete, + updateRcvFileRedirect, + updateRcvFileNoTmpPath, + updateRcvFileDeleted, + deleteRcvFile', + getNextRcvChunkToDownload, + getNextRcvFileToDecrypt, + getPendingRcvFilesServers, + getCleanupRcvFilesTmpPaths, + getCleanupRcvFilesDeleted, + getRcvFilesExpired, + -- Snd files + createSndFile, + getSndFile, + getSndFileByEntityId, + getNextSndFileToPrepare, + updateSndFileError, + updateSndFileStatus, + updateSndFileEncrypted, + updateSndFileComplete, + updateSndFileNoPrefixPath, + updateSndFileDeleted, + deleteSndFile', + getSndFileDeleted, + createSndFileReplica, + createSndFileReplica_, -- exported for tests + getNextSndChunkToUpload, + updateSndChunkReplicaDelay, + addSndChunkReplicaRecipients, + updateSndChunkReplicaStatus, + getPendingSndFilesServers, + getCleanupSndFilesPrefixPaths, + getCleanupSndFilesDeleted, + getSndFilesExpired, + createDeletedSndChunkReplica, + getNextDeletedSndChunkReplica, + updateDeletedSndChunkReplicaDelay, + deleteDeletedSndChunkReplica, + getPendingDelFilesServers, + deleteDeletedSndChunkReplicasExpired, + -- Stats + updateServersStats, + getServersStats, + resetServersStats, + + -- * utilities + withConnection, + withTransaction, + withTransactionPriority, + firstRow, + firstRow', + maybeFirstRow, + ) +where + +import Control.Logger.Simple +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Crypto.Random (ChaChaDRG) +import Data.Bifunctor (first, second) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64.URL as U +import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.List (foldl', sortBy) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) +import Data.Ord (Down (..)) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) +import Data.Word (Word32) +import Database.SQLite.Simple (FromRow (..), NamedParam (..), Only (..), Query (..), SQLError, ToRow (..), field, (:.) (..)) +import qualified Database.SQLite.Simple as SQL +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.QQ (sql) +import Database.SQLite.Simple.ToField (ToField (..)) +import Network.Socket (ServiceName) +import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) +import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) +import Simplex.FileTransfer.Types +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) +import Simplex.Messaging.Agent.Stats +import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Agent.Store.Common +import qualified Simplex.Messaging.Agent.Store.DB as DB +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) +import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys) +import qualified Simplex.Messaging.Crypto.Ratchet as CR +import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..)) +import Simplex.Messaging.Notifications.Types +import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_) +import Simplex.Messaging.Protocol +import qualified Simplex.Messaging.Protocol as SMP +import Simplex.Messaging.Transport.Client (TransportHost) +import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, tshow, ($>>=), (<$$>)) +import Simplex.Messaging.Version.Internal +import qualified UnliftIO.Exception as E +import UnliftIO.STM + +checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a) +checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err) + +handleSQLError :: StoreError -> SQLError -> StoreError +handleSQLError err e + | SQL.sqlError e == SQL.ErrorConstraint = err + | otherwise = SEInternal $ bshow e + +createUserRecord :: DB.Connection -> IO UserId +createUserRecord db = do + DB.execute_ db "INSERT INTO users DEFAULT VALUES" + insertedRowId db + +checkUser :: DB.Connection -> UserId -> IO (Either StoreError ()) +checkUser db userId = + firstRow (\(_ :: Only Int64) -> ()) SEUserNotFound $ + DB.query db "SELECT user_id FROM users WHERE user_id = ? AND deleted = ?" (userId, False) + +deleteUserRecord :: DB.Connection -> UserId -> IO (Either StoreError ()) +deleteUserRecord db userId = runExceptT $ do + ExceptT $ checkUser db userId + liftIO $ DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) + +setUserDeleted :: DB.Connection -> UserId -> IO (Either StoreError [ConnId]) +setUserDeleted db userId = runExceptT $ do + ExceptT $ checkUser db userId + liftIO $ do + DB.execute db "UPDATE users SET deleted = ? WHERE user_id = ?" (True, userId) + map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE user_id = ?" (Only userId) + +deleteUserWithoutConns :: DB.Connection -> UserId -> IO Bool +deleteUserWithoutConns db userId = do + userId_ :: Maybe Int64 <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT user_id FROM users u + WHERE u.user_id = ? + AND u.deleted = ? + AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) + |] + (userId, True) + case userId_ of + Just _ -> DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) $> True + _ -> pure False + +deleteUsersWithoutConns :: DB.Connection -> IO [Int64] +deleteUsersWithoutConns db = do + userIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT user_id FROM users u + WHERE u.deleted = ? + AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) + |] + (Only True) + forM_ userIds $ DB.execute db "DELETE FROM users WHERE user_id = ?" . Only + pure userIds + +createConn_ :: + TVar ChaChaDRG -> + ConnData -> + (ConnId -> IO a) -> + IO (Either StoreError (ConnId, a)) +createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of + ConnData {connId = ""} -> createWithRandomId' gVar create + ConnData {connId} -> Right . (connId,) <$> create connId + +createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId) +createNewConn db gVar cData cMode = do + fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode) + +updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue) +updateNewConnRcv db connId rq = + getConn db connId $>>= \case + (SomeConn _ NewConnection {}) -> updateConn + (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries + (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + where + updateConn :: IO (Either StoreError RcvQueue) + updateConn = Right <$> addConnRcvQueue_ db connId rq + +updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue) +updateNewConnSnd db connId sq = + getConn db connId $>>= \case + (SomeConn _ NewConnection {}) -> updateConn + (SomeConn _ SndConnection {}) -> updateConn -- to allow retries + (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + where + updateConn :: IO (Either StoreError SndQueue) + updateConn = Right <$> addConnSndQueue_ db connId sq + +createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewSndQueue -> IO (Either StoreError (ConnId, SndQueue)) +createSndConn db gVar cData q@SndQueue {server} = + -- check confirmed snd queue doesn't already exist, to prevent it being deleted by REPLACE in insertSndQueue_ + ifM (liftIO $ checkConfirmedSndQueueExists_ db q) (pure $ Left SESndQueueExists) $ + createConn_ gVar cData $ \connId -> do + serverKeyHash_ <- createServer_ db server + createConnRecord db connId cData SCMInvitation + insertSndQueue_ db connId q serverKeyHash_ + +createConnRecord :: DB.Connection -> ConnId -> ConnData -> SConnectionMode c -> IO () +createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport} cMode = + DB.execute + db + [sql| + INSERT INTO connections + (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake) VALUES (?,?,?,?,?,?,?) + |] + (userId, connId, cMode, connAgentVersion, enableNtfs, pqSupport, True) + +checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool +checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do + fromMaybe False + <$> maybeFirstRow + fromOnly + ( DB.query + db + "SELECT 1 FROM snd_queues WHERE host = ? AND port = ? AND snd_id = ? AND status != ? LIMIT 1" + (host server, port server, sndId, New) + ) + +getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn)) +getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do + rq@RcvQueue {connId} <- + ExceptT . firstRow toRcvQueue SEConnNotFound $ + DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (host, port, rcvId) + (rq,) <$> ExceptT (getConn db connId) + +-- | Deletes connection, optionally checking for pending snd message deliveries; returns connection id if it was deleted +deleteConn :: DB.Connection -> Maybe NominalDiffTime -> ConnId -> IO (Maybe ConnId) +deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of + Nothing -> delete + Just timeout -> + ifM + checkNoPendingDeliveries_ + delete + ( ifM + (checkWaitDeliveryTimeout_ timeout) + delete + (pure Nothing) + ) + where + delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId + checkNoPendingDeliveries_ = do + r :: (Maybe Int64) <- + maybeFirstRow fromOnly $ + DB.query db "SELECT 1 FROM snd_message_deliveries WHERE conn_id = ? AND failed = 0 LIMIT 1" (Only connId) + pure $ isNothing r + checkWaitDeliveryTimeout_ timeout = do + cutoffTs <- addUTCTime (-timeout) <$> getCurrentTime + r :: (Maybe Int64) <- + maybeFirstRow fromOnly $ + DB.query db "SELECT 1 FROM connections WHERE conn_id = ? AND deleted_at_wait_delivery < ? LIMIT 1" (connId, cutoffTs) + pure $ isJust r + +upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue) +upgradeRcvConnToDuplex db connId sq = + getConn db connId $>>= \case + (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq + (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + +upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue) +upgradeSndConnToDuplex db connId rq = + getConn db connId >>= \case + Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq + Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + _ -> pure $ Left SEConnNotFound + +addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue) +addConnRcvQueue db connId rq = + getConn db connId >>= \case + Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq + Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + _ -> pure $ Left SEConnNotFound + +addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue +addConnRcvQueue_ db connId rq@RcvQueue {server} = do + serverKeyHash_ <- createServer_ db server + insertRcvQueue_ db connId rq serverKeyHash_ + +addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue) +addConnSndQueue db connId sq = + getConn db connId >>= \case + Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq + Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + _ -> pure $ Left SEConnNotFound + +addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue +addConnSndQueue_ db connId sq@SndQueue {server} = do + serverKeyHash_ <- createServer_ db server + insertSndQueue_ db connId sq serverKeyHash_ + +setRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO () +setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} status = + -- ? return error if queue does not exist? + DB.executeNamed + db + [sql| + UPDATE rcv_queues + SET status = :status + WHERE host = :host AND port = :port AND rcv_id = :rcv_id; + |] + [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId] + +setRcvSwitchStatus :: DB.Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue +setRcvSwitchStatus db rq@RcvQueue {rcvId, server = ProtocolServer {host, port}} rcvSwchStatus = do + DB.execute + db + [sql| + UPDATE rcv_queues + SET switch_status = ? + WHERE host = ? AND port = ? AND rcv_id = ? + |] + (rcvSwchStatus, host, port, rcvId) + pure rq {rcvSwchStatus} + +setRcvQueueDeleted :: DB.Connection -> RcvQueue -> IO () +setRcvQueueDeleted db RcvQueue {rcvId, server = ProtocolServer {host, port}} = do + DB.execute + db + [sql| + UPDATE rcv_queues + SET deleted = 1 + WHERE host = ? AND port = ? AND rcv_id = ? + |] + (host, port, rcvId) + +setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> VersionSMPC -> IO () +setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion = + DB.executeNamed + db + [sql| + UPDATE rcv_queues + SET e2e_dh_secret = :e2e_dh_secret, + status = :status, + smp_client_version = :smp_client_version + WHERE host = :host AND port = :port AND rcv_id = :rcv_id + |] + [ ":status" := Confirmed, + ":e2e_dh_secret" := e2eDhSecret, + ":smp_client_version" := smpClientVersion, + ":host" := host, + ":port" := port, + ":rcv_id" := rcvId + ] + +setSndQueueStatus :: DB.Connection -> SndQueue -> QueueStatus -> IO () +setSndQueueStatus db SndQueue {sndId, server = ProtocolServer {host, port}} status = + -- ? return error if queue does not exist? + DB.executeNamed + db + [sql| + UPDATE snd_queues + SET status = :status + WHERE host = :host AND port = :port AND snd_id = :snd_id; + |] + [":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId] + +setSndSwitchStatus :: DB.Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue +setSndSwitchStatus db sq@SndQueue {sndId, server = ProtocolServer {host, port}} sndSwchStatus = do + DB.execute + db + [sql| + UPDATE snd_queues + SET switch_status = ? + WHERE host = ? AND port = ? AND snd_id = ? + |] + (sndSwchStatus, host, port, sndId) + pure sq {sndSwchStatus} + +setRcvQueuePrimary :: DB.Connection -> ConnId -> RcvQueue -> IO () +setRcvQueuePrimary db connId RcvQueue {dbQueueId} = do + DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (False, connId) + DB.execute + db + "UPDATE rcv_queues SET rcv_primary = ?, replace_rcv_queue_id = ? WHERE conn_id = ? AND rcv_queue_id = ?" + (True, Nothing :: Maybe Int64, connId, dbQueueId) + +setSndQueuePrimary :: DB.Connection -> ConnId -> SndQueue -> IO () +setSndQueuePrimary db connId SndQueue {dbQueueId} = do + DB.execute db "UPDATE snd_queues SET snd_primary = ? WHERE conn_id = ?" (False, connId) + DB.execute + db + "UPDATE snd_queues SET snd_primary = ?, replace_snd_queue_id = ? WHERE conn_id = ? AND snd_queue_id = ?" + (True, Nothing :: Maybe Int64, connId, dbQueueId) + +incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO () +incRcvDeleteErrors db RcvQueue {connId, dbQueueId} = + DB.execute db "UPDATE rcv_queues SET delete_errors = delete_errors + 1 WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) + +deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO () +deleteConnRcvQueue db RcvQueue {connId, dbQueueId} = + DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) + +deleteConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO () +deleteConnSndQueue db connId SndQueue {dbQueueId} = do + DB.execute db "DELETE FROM snd_queues WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId) + DB.execute db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId) + +getPrimaryRcvQueue :: DB.Connection -> ConnId -> IO (Either StoreError RcvQueue) +getPrimaryRcvQueue db connId = + maybe (Left SEConnNotFound) (Right . L.head) <$> getRcvQueuesByConnId_ db connId + +getRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue) +getRcvQueue db connId (SMPServer host port _) rcvId = + firstRow toRcvQueue SEConnNotFound $ + DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (connId, host, port, rcvId) + +getDeletedRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue) +getDeletedRcvQueue db connId (SMPServer host port _) rcvId = + firstRow toRcvQueue SEConnNotFound $ + DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 1") (connId, host, port, rcvId) + +setRcvQueueNtfCreds :: DB.Connection -> ConnId -> Maybe ClientNtfCreds -> IO () +setRcvQueueNtfCreds db connId clientNtfCreds = + DB.execute + db + [sql| + UPDATE rcv_queues + SET ntf_public_key = ?, ntf_private_key = ?, ntf_id = ?, rcv_ntf_dh_secret = ? + WHERE conn_id = ? + |] + (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_, connId) + where + (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) = case clientNtfCreds of + Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) + Nothing -> (Nothing, Nothing, Nothing, Nothing) + +type SMPConfirmationRow = (Maybe SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) + +smpConfirmation :: SMPConfirmationRow -> SMPConfirmation +smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) = + SMPConfirmation + { senderKey, + e2ePubKey, + connInfo, + smpReplyQueues = fromMaybe [] smpReplyQueues_, + smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ + } + +createConfirmation :: DB.Connection -> TVar ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId) +createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues, smpClientVersion}, ratchetState} = + createWithRandomId gVar $ \confirmationId -> + DB.execute + db + [sql| + INSERT INTO conn_confirmations + (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, smp_client_version, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, ?, 0); + |] + (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues, smpClientVersion) + +acceptConfirmation :: DB.Connection -> ConfirmationId -> ConnInfo -> IO (Either StoreError AcceptedConfirmation) +acceptConfirmation db confirmationId ownConnInfo = do + DB.executeNamed + db + [sql| + UPDATE conn_confirmations + SET accepted = 1, + own_conn_info = :own_conn_info + WHERE confirmation_id = :confirmation_id; + |] + [ ":own_conn_info" := ownConnInfo, + ":confirmation_id" := confirmationId + ] + firstRow confirmation SEConfirmationNotFound $ + DB.query + db + [sql| + SELECT conn_id, ratchet_state, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version + FROM conn_confirmations + WHERE confirmation_id = ?; + |] + (Only confirmationId) + where + confirmation ((connId, ratchetState) :. confRow) = + AcceptedConfirmation + { confirmationId, + connId, + senderConf = smpConfirmation confRow, + ratchetState, + ownConnInfo + } + +getAcceptedConfirmation :: DB.Connection -> ConnId -> IO (Either StoreError AcceptedConfirmation) +getAcceptedConfirmation db connId = + firstRow confirmation SEConfirmationNotFound $ + DB.query + db + [sql| + SELECT confirmation_id, ratchet_state, own_conn_info, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version + FROM conn_confirmations + WHERE conn_id = ? AND accepted = 1; + |] + (Only connId) + where + confirmation ((confirmationId, ratchetState, ownConnInfo) :. confRow) = + AcceptedConfirmation + { confirmationId, + connId, + senderConf = smpConfirmation confRow, + ratchetState, + ownConnInfo + } + +removeConfirmations :: DB.Connection -> ConnId -> IO () +removeConfirmations db connId = + DB.executeNamed + db + [sql| + DELETE FROM conn_confirmations + WHERE conn_id = :conn_id; + |] + [":conn_id" := connId] + +createInvitation :: DB.Connection -> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId) +createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo} = + createWithRandomId gVar $ \invitationId -> + DB.execute + db + [sql| + INSERT INTO conn_invitations + (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0); + |] + (invitationId, contactConnId, connReq, recipientConnInfo) + +getInvitation :: DB.Connection -> String -> InvitationId -> IO (Either StoreError Invitation) +getInvitation db cxt invitationId = + firstRow invitation (SEInvitationNotFound cxt invitationId) $ + DB.query + db + [sql| + SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted + FROM conn_invitations + WHERE invitation_id = ? + AND accepted = 0 + |] + (Only invitationId) + where + invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted) = + Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted} + +acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO () +acceptInvitation db invitationId ownConnInfo = + DB.executeNamed + db + [sql| + UPDATE conn_invitations + SET accepted = 1, + own_conn_info = :own_conn_info + WHERE invitation_id = :invitation_id + |] + [ ":own_conn_info" := ownConnInfo, + ":invitation_id" := invitationId + ] + +unacceptInvitation :: DB.Connection -> InvitationId -> IO () +unacceptInvitation db invitationId = + DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only invitationId) + +deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ()) +deleteInvitation db contactConnId invId = + getConn db contactConnId $>>= \case + SomeConn SCContact _ -> + Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, invId) + _ -> pure $ Left SEConnNotFound + +updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) +updateRcvIds db connId = do + (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId + let internalId = InternalId $ unId lastInternalId + 1 + internalRcvId = InternalRcvId $ unRcvId lastInternalRcvId + 1 + updateLastIdsRcv_ db connId internalId internalRcvId + pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash) + +createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () +createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId, broker = (_, brokerTs)}, internalRcvId, internalHash} = do + insertRcvMsgBase_ db connId rcvMsgData + insertRcvMsgDetails_ db connId rq rcvMsgData + updateRcvMsgHash db connId sndMsgId internalRcvId internalHash + DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId) + +updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) +updateSndIds db connId = runExceptT $ do + (lastInternalId, lastInternalSndId, prevSndHash) <- ExceptT $ retrieveLastIdsAndHashSnd_ db connId + let internalId = InternalId $ unId lastInternalId + 1 + internalSndId = InternalSndId $ unSndId lastInternalSndId + 1 + liftIO $ updateLastIdsSnd_ db connId internalId internalSndId + pure (internalId, internalSndId, prevSndHash) + +createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO () +createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do + insertSndMsgBase_ db connId sndMsgData + insertSndMsgDetails_ db connId sndMsgData + updateSndMsgHash db connId internalSndId internalHash + +createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO () +createSndMsgDelivery db connId SndQueue {dbQueueId} msgId = + DB.execute db "INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id) VALUES (?, ?, ?)" (connId, dbQueueId, msgId) + +getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg) +getSndMsgViaRcpt db connId sndMsgId = + firstRow toSndMsg SEMsgNotFound $ + DB.query + db + [sql| + SELECT s.internal_id, m.msg_type, s.internal_hash, s.rcpt_internal_id, s.rcpt_status + FROM snd_messages s + JOIN messages m ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id + WHERE s.conn_id = ? AND s.internal_snd_id = ? + |] + (connId, sndMsgId) + where + toSndMsg :: (InternalId, AgentMessageType, MsgHash, Maybe AgentMsgId, Maybe MsgReceiptStatus) -> SndMsg + toSndMsg (internalId, msgType, internalHash, rcptInternalId_, rcptStatus_) = + let msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_ + in SndMsg {internalId, internalSndId = sndMsgId, msgType, internalHash, msgReceipt} + +updateSndMsgRcpt :: DB.Connection -> ConnId -> InternalSndId -> MsgReceipt -> IO () +updateSndMsgRcpt db connId sndMsgId MsgReceipt {agentMsgId, msgRcptStatus} = + DB.execute + db + "UPDATE snd_messages SET rcpt_internal_id = ?, rcpt_status = ? WHERE conn_id = ? AND internal_snd_id = ?" + (agentMsgId, msgRcptStatus, connId, sndMsgId) + +getConnectionsForDelivery :: DB.Connection -> IO [ConnId] +getConnectionsForDelivery db = + map fromOnly <$> DB.query_ db "SELECT DISTINCT conn_id FROM snd_message_deliveries WHERE failed = 0" + +getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData))) +getPendingQueueMsg db connId SndQueue {dbQueueId} = + getWorkItem "message" getMsgId getMsgData markMsgFailed + where + getMsgId :: IO (Maybe InternalId) + getMsgId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT internal_id + FROM snd_message_deliveries d + WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0 + ORDER BY internal_id ASC + LIMIT 1 + |] + (connId, dbQueueId) + getMsgData :: InternalId -> IO (Either StoreError (Maybe RcvQueue, PendingMsgData)) + getMsgData msgId = runExceptT $ do + msg <- ExceptT $ firstRow pendingMsgData err getMsgData_ + rq_ <- liftIO $ L.head <$$> getRcvQueuesByConnId_ db connId + pure (rq_, msg) + where + getMsgData_ = + DB.query + db + [sql| + SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast + FROM messages m + JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id + WHERE m.conn_id = ? AND m.internal_id = ? + |] + (connId, msgId) + err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []" + pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData + pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_) = + let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_ + msgRetryState = RI2State <$> riSlow_ <*> riFast_ + in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs} + markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId) + +getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a)) +getWorkItem itemName getId getItem markFailed = + runExceptT $ handleWrkErr itemName "getId" getId >>= mapM (tryGetItem itemName getItem markFailed) + +getWorkItems :: Show i => ByteString -> IO [i] -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError [Either StoreError a]) +getWorkItems itemName getIds getItem markFailed = + runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed) + +tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a +tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e + where + mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId + +catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a +catchStoreError = catchAllErrors (SEInternal . bshow) + +-- Errors caught by this function will suspend worker as if there is no more work, +handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a +handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action + where + mkError :: E.SomeException -> StoreError + mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e + +updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO () +updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} = + DB.execute db "UPDATE snd_messages SET retry_int_slow = ?, retry_int_fast = ? WHERE conn_id = ? AND internal_id = ?" (slowInterval, fastInterval, connId, msgId) + +deletePendingMsgs :: DB.Connection -> ConnId -> SndQueue -> IO () +deletePendingMsgs db connId SndQueue {dbQueueId} = + DB.execute db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId) + +getExpiredSndMessages :: DB.Connection -> ConnId -> SndQueue -> UTCTime -> IO [InternalId] +getExpiredSndMessages db connId SndQueue {dbQueueId} expireTs = do + -- type is Maybe InternalId because MAX always returns one row, possibly with NULL value + maxId :: [Maybe InternalId] <- + map fromOnly + <$> DB.query + db + [sql| + SELECT MAX(internal_id) + FROM messages + WHERE conn_id = ? AND internal_snd_id IS NOT NULL AND internal_ts < ? + |] + (connId, expireTs) + case maxId of + Just msgId : _ -> + map fromOnly + <$> DB.query + db + [sql| + SELECT internal_id + FROM snd_message_deliveries + WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0 AND internal_id <= ? + ORDER BY internal_id ASC + |] + (connId, dbQueueId, msgId) + _ -> pure [] + +setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (RcvQueue, SMP.MsgId)) +setMsgUserAck db connId agentMsgId = runExceptT $ do + (dbRcvId, srvMsgId) <- + ExceptT . firstRow id SEMsgNotFound $ + DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId) + rq <- ExceptT $ getRcvQueueById db connId dbRcvId + liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId) + pure (rq, srvMsgId) + +getRcvMsg :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg) +getRcvMsg db connId agentMsgId = + firstRow toRcvMsg SEMsgNotFound $ + DB.query + db + [sql| + SELECT + r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash, + m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack + FROM rcv_messages r + JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id + LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id + WHERE r.conn_id = ? AND r.internal_id = ? + |] + (connId, agentMsgId) + +getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg) +getLastMsg db connId msgId = + maybeFirstRow toRcvMsg $ + DB.query + db + [sql| + SELECT + r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash, + m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack + FROM rcv_messages r + JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id + JOIN connections c ON r.conn_id = c.conn_id AND c.last_internal_msg_id = r.internal_id + LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id + WHERE r.conn_id = ? AND r.broker_id = ? + |] + (connId, msgId) + +toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg +toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, userAck)) = + let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity, pqEncryption} + msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_ + in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck} + +checkRcvMsgHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool +checkRcvMsgHashExists db connId hash = do + fromMaybe False + <$> maybeFirstRow + fromOnly + ( DB.query + db + "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1" + (connId, hash) + ) + +getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs) +getRcvMsgBrokerTs db connId msgId = + firstRow fromOnly SEMsgNotFound $ + DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId) + +deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO () +deleteMsg db connId msgId = + DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId) + +deleteMsgContent :: DB.Connection -> ConnId -> InternalId -> IO () +deleteMsgContent db connId msgId = + DB.execute db "UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?;" (connId, msgId) + +deleteDeliveredSndMsg :: DB.Connection -> ConnId -> InternalId -> IO () +deleteDeliveredSndMsg db connId msgId = do + cnt <- countPendingSndDeliveries_ db connId msgId + when (cnt == 0) $ deleteMsg db connId msgId + +deleteSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> Bool -> IO () +deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do + DB.execute + db + "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? AND internal_id = ?" + (connId, dbQueueId, msgId) + cnt <- countPendingSndDeliveries_ db connId msgId + when (cnt == 0) $ do + del <- + maybeFirstRow id (DB.query db "SELECT rcpt_internal_id, rcpt_status FROM snd_messages WHERE conn_id = ? AND internal_id = ?" (connId, msgId)) >>= \case + Just (Just (_ :: Int64), Just MROk) -> pure deleteMsg + _ -> pure $ if keepForReceipt then deleteMsgContent else deleteMsg + del db connId msgId + +countPendingSndDeliveries_ :: DB.Connection -> ConnId -> InternalId -> IO Int +countPendingSndDeliveries_ db connId msgId = do + (Only cnt : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ? AND failed = 0" (connId, msgId) + pure cnt + +deleteRcvMsgHashesExpired :: DB.Connection -> NominalDiffTime -> IO () +deleteRcvMsgHashesExpired db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + DB.execute db "DELETE FROM encrypted_rcv_message_hashes WHERE created_at < ?" (Only cutoffTs) + +deleteSndMsgsExpired :: DB.Connection -> NominalDiffTime -> IO () +deleteSndMsgsExpired db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + DB.execute + db + "DELETE FROM messages WHERE internal_ts < ? AND internal_snd_id IS NOT NULL" + (Only cutoffTs) + +createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO () +createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = + DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem) VALUES (?, ?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2, pqPrivKem) + +getRatchetX3dhKeys :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams)) +getRatchetX3dhKeys db connId = + firstRow' keys SEX3dhKeysNotFound $ + DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem FROM ratchets WHERE conn_id = ?" (Only connId) + where + keys = \case + (Just k1, Just k2, pKem) -> Right (k1, k2, pKem) + _ -> Left SEX3dhKeysNotFound + +-- used to remember new keys when starting ratchet re-synchronization +-- TODO remove the columns for public keys in v5.7. +-- Currently, the keys are not used but still stored to support app downgrade to the previous version. +setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO () +setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = + DB.execute + db + [sql| + UPDATE ratchets + SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? + WHERE conn_id = ? + |] + (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId) + +-- TODO remove the columns for public keys in v5.7. +createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO () +createRatchet db connId rc = + DB.executeNamed + db + [sql| + INSERT INTO ratchets (conn_id, ratchet_state) + VALUES (:conn_id, :ratchet_state) + ON CONFLICT (conn_id) DO UPDATE SET + ratchet_state = :ratchet_state, + x3dh_priv_key_1 = NULL, + x3dh_priv_key_2 = NULL, + x3dh_pub_key_1 = NULL, + x3dh_pub_key_2 = NULL, + pq_priv_kem = NULL + |] + [":conn_id" := connId, ":ratchet_state" := rc] + +deleteRatchet :: DB.Connection -> ConnId -> IO () +deleteRatchet db connId = + DB.execute db "DELETE FROM ratchets WHERE conn_id = ?" (Only connId) + +getRatchet :: DB.Connection -> ConnId -> IO (Either StoreError RatchetX448) +getRatchet db connId = + firstRow' ratchet SERatchetNotFound $ DB.query db "SELECT ratchet_state FROM ratchets WHERE conn_id = ?" (Only connId) + where + ratchet = maybe (Left SERatchetNotFound) Right . fromOnly + +getSkippedMsgKeys :: DB.Connection -> ConnId -> IO SkippedMsgKeys +getSkippedMsgKeys db connId = + skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId) + where + skipped = foldl' addSkippedKey M.empty + addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks + where + addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk) + +updateRatchet :: DB.Connection -> ConnId -> RatchetX448 -> SkippedMsgDiff -> IO () +updateRatchet db connId rc skipped = do + DB.execute db "UPDATE ratchets SET ratchet_state = ? WHERE conn_id = ?" (rc, connId) + case skipped of + SMDNoChange -> pure () + SMDRemove hk msgN -> + DB.execute db "DELETE FROM skipped_messages WHERE conn_id = ? AND header_key = ? AND msg_n = ?" (connId, hk, msgN) + SMDAdd smks -> + forM_ (M.assocs smks) $ \(hk, mks) -> + forM_ (M.assocs mks) $ \(msgN, mk) -> + DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk) + +createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO (Either StoreError ()) +createCommand db corrId connId srv_ cmd = runExceptT $ do + (host_, port_, serverKeyHash_) <- serverFields + createdAt <- liftIO getCurrentTime + liftIO . E.handle handleErr $ + DB.execute + db + "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash, created_at) VALUES (?,?,?,?,?,?,?,?)" + (host_, port_, corrId, connId, cmdTag, cmd, serverKeyHash_, createdAt) + where + cmdTag = agentCommandTag cmd + handleErr e + | SQL.sqlError e == SQL.ErrorConstraint = logError $ "tried to create command " <> tshow cmdTag <> " for deleted connection" + | otherwise = E.throwIO e + serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash) + serverFields = case srv_ of + Just srv@(SMPServer host port _) -> + (Just host,Just port,) <$> ExceptT (getServerKeyHash_ db srv) + Nothing -> pure (Nothing, Nothing, Nothing) + +insertedRowId :: DB.Connection -> IO Int64 +insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" + +getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer] +getPendingCommandServers db connId = do + -- TODO review whether this can break if, e.g., the server has another key hash. + map smpServer + <$> DB.query + db + [sql| + SELECT DISTINCT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash) + FROM commands c + LEFT JOIN servers s ON s.host = c.host AND s.port = c.port + WHERE conn_id = ? + |] + (Only connId) + where + smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash + +getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand)) +getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed + where + getCmdId :: IO (Maybe Int64) + getCmdId = + maybeFirstRow fromOnly $ case srv_ of + Nothing -> + DB.query + db + [sql| + SELECT command_id FROM commands + WHERE conn_id = ? AND host IS NULL AND port IS NULL AND failed = 0 + ORDER BY created_at ASC, command_id ASC + LIMIT 1 + |] + (Only connId) + Just (SMPServer host port _) -> + DB.query + db + [sql| + SELECT command_id FROM commands + WHERE conn_id = ? AND host = ? AND port = ? AND failed = 0 + ORDER BY created_at ASC, command_id ASC + LIMIT 1 + |] + (connId, host, port) + getCommand :: Int64 -> IO (Either StoreError PendingCommand) + getCommand cmdId = + firstRow pendingCommand err $ + DB.query + db + [sql| + SELECT c.corr_id, cs.user_id, c.command + FROM commands c + JOIN connections cs USING (conn_id) + WHERE c.command_id = ? + |] + (Only cmdId) + where + err = SEInternal $ "command " <> bshow cmdId <> " returned []" + pendingCommand (corrId, userId, command) = PendingCommand {cmdId, corrId, userId, connId, command} + markCommandFailed cmdId = DB.execute db "UPDATE commands SET failed = 1 WHERE command_id = ?" (Only cmdId) + +updateCommandServer :: DB.Connection -> AsyncCmdId -> SMPServer -> IO (Either StoreError ()) +updateCommandServer db cmdId srv@(SMPServer host port _) = runExceptT $ do + serverKeyHash_ <- ExceptT $ getServerKeyHash_ db srv + liftIO $ + DB.execute + db + [sql| + UPDATE commands + SET host = ?, port = ?, server_key_hash = ? + WHERE command_id = ? + |] + (host, port, serverKeyHash_, cmdId) + +deleteCommand :: DB.Connection -> AsyncCmdId -> IO () +deleteCommand db cmdId = + DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId) + +createNtfToken :: DB.Connection -> NtfToken -> IO () +createNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do + upsertNtfServer_ db srv + DB.execute + db + [sql| + INSERT INTO ntf_tokens + (provider, device_token, ntf_host, ntf_port, tkn_id, tkn_pub_key, tkn_priv_key, tkn_pub_dh_key, tkn_priv_dh_key, tkn_dh_secret, tkn_status, tkn_action, ntf_mode) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) + |] + ((provider, token, host, port, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode)) + +getSavedNtfToken :: DB.Connection -> IO (Maybe NtfToken) +getSavedNtfToken db = do + maybeFirstRow ntfToken $ + DB.query_ + db + [sql| + SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash, + t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, + t.tkn_status, t.tkn_action, t.ntf_mode + FROM ntf_tokens t + JOIN ntf_servers s USING (ntf_host, ntf_port) + |] + where + ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) = + let ntfServer = NtfServer host port keyHash + ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey) + ntfMode = fromMaybe NMPeriodic ntfMode_ + in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} + +updateNtfTokenRegistration :: DB.Connection -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> IO () +updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE ntf_tokens + SET tkn_id = ?, tkn_dh_secret = ?, tkn_status = ?, tkn_action = ?, updated_at = ? + WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? + |] + (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port) + +updateDeviceToken :: DB.Connection -> NtfToken -> DeviceToken -> IO () +updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} (DeviceToken toProvider toToken) = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE ntf_tokens + SET provider = ?, device_token = ?, tkn_status = ?, tkn_action = ?, updated_at = ? + WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? + |] + (toProvider, toToken, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port) + +updateNtfMode :: DB.Connection -> NtfToken -> NotificationsMode -> IO () +updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} ntfMode = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE ntf_tokens + SET ntf_mode = ?, updated_at = ? + WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? + |] + (ntfMode, updatedAt, provider, token, host, port) + +updateNtfToken :: DB.Connection -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO () +updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE ntf_tokens + SET tkn_status = ?, tkn_action = ?, updated_at = ? + WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? + |] + (tknStatus, tknAction, updatedAt, provider, token, host, port) + +removeNtfToken :: DB.Connection -> NtfToken -> IO () +removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} = + DB.execute + db + [sql| + DELETE FROM ntf_tokens + WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? + |] + (provider, token, host, port) + +addNtfTokenToDelete :: DB.Connection -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> IO () +addNtfTokenToDelete db ProtocolServer {host, port, keyHash} ntfPrivKey tknId = + DB.execute db "INSERT INTO ntf_tokens_to_delete (ntf_host, ntf_port, ntf_key_hash, tkn_id, tkn_priv_key) VALUES (?,?,?,?,?)" (host, port, keyHash, tknId, ntfPrivKey) + +deleteExpiredNtfTokensToDelete :: DB.Connection -> NominalDiffTime -> IO () +deleteExpiredNtfTokensToDelete db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE created_at < ?" (Only cutoffTs) + +type NtfTokenToDelete = (Int64, C.APrivateAuthKey, NtfTokenId) + +getNextNtfTokenToDelete :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe NtfTokenToDelete)) +getNextNtfTokenToDelete db (NtfServer ntfHost ntfPort _) = + getWorkItem "ntf tkn del" getNtfTknDbId getNtfTknToDelete (markNtfTokenToDeleteFailed_ db) + where + getNtfTknDbId :: IO (Maybe Int64) + getNtfTknDbId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT ntf_token_to_delete_id + FROM ntf_tokens_to_delete + WHERE ntf_host = ? AND ntf_port = ? + AND del_failed = 0 + ORDER BY created_at ASC + LIMIT 1 + |] + (ntfHost, ntfPort) + getNtfTknToDelete :: Int64 -> IO (Either StoreError NtfTokenToDelete) + getNtfTknToDelete tknDbId = + firstRow ntfTokenToDelete err $ + DB.query + db + [sql| + SELECT tkn_priv_key, tkn_id + FROM ntf_tokens_to_delete + WHERE ntf_token_to_delete_id = ? + |] + (Only tknDbId) + where + err = SEInternal $ "ntf token to delete " <> bshow tknDbId <> " returned []" + ntfTokenToDelete (tknPrivKey, tknId) = (tknDbId, tknPrivKey, tknId) + +markNtfTokenToDeleteFailed_ :: DB.Connection -> Int64 -> IO () +markNtfTokenToDeleteFailed_ db tknDbId = + DB.execute db "UPDATE ntf_tokens_to_delete SET del_failed = 1 where ntf_token_to_delete_id = ?" (Only tknDbId) + +getPendingDelTknServers :: DB.Connection -> IO [NtfServer] +getPendingDelTknServers db = + map toNtfServer + <$> DB.query_ + db + [sql| + SELECT DISTINCT ntf_host, ntf_port, ntf_key_hash + FROM ntf_tokens_to_delete + |] + where + toNtfServer (host, port, keyHash) = NtfServer host port keyHash + +deleteNtfTokenToDelete :: DB.Connection -> Int64 -> IO () +deleteNtfTokenToDelete db tknDbId = + DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE ntf_token_to_delete_id = ?" (Only tknDbId) + +type NtfSupervisorSub = (NtfSubscription, Maybe (NtfSubAction, NtfActionTs)) + +getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe NtfSupervisorSub) +getNtfSubscription db connId = + maybeFirstRow ntfSubscription $ + DB.query + db + [sql| + SELECT c.user_id, s.host, s.port, COALESCE(nsb.smp_server_key_hash, s.key_hash), ns.ntf_host, ns.ntf_port, ns.ntf_key_hash, + nsb.smp_ntf_id, nsb.ntf_sub_id, nsb.ntf_sub_status, nsb.ntf_sub_action, nsb.ntf_sub_smp_action, nsb.ntf_sub_action_ts + FROM ntf_subscriptions nsb + JOIN connections c USING (conn_id) + JOIN servers s ON s.host = nsb.smp_host AND s.port = nsb.smp_port + JOIN ntf_servers ns USING (ntf_host, ntf_port) + WHERE nsb.conn_id = ? + |] + (Only connId) + where + ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) = + let smpServer = SMPServer smpHost smpPort smpKeyHash + ntfServer = NtfServer ntfHost ntfPort ntfKeyHash + action = case (ntfAction_, smpAction_, actionTs_) of + (Just ntfAction, Nothing, Just actionTs) -> Just (NSANtf ntfAction, actionTs) + (Nothing, Just smpAction, Just actionTs) -> Just (NSASMP smpAction, actionTs) + _ -> Nothing + in (NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}, action) + +createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO (Either StoreError ()) +createNtfSubscription db ntfSubscription action = runExceptT $ do + let NtfSubscription {connId, smpServer = smpServer@(SMPServer host port _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} = ntfSubscription + smpServerKeyHash_ <- ExceptT $ getServerKeyHash_ db smpServer + actionTs <- liftIO getCurrentTime + liftIO $ + DB.execute + db + [sql| + INSERT INTO ntf_subscriptions + (conn_id, smp_host, smp_port, smp_ntf_id, ntf_host, ntf_port, ntf_sub_id, + ntf_sub_status, ntf_sub_action, ntf_sub_smp_action, ntf_sub_action_ts, smp_server_key_hash) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (connId, host, port, ntfQueueId, ntfHost, ntfPort, ntfSubId) + :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, smpServerKeyHash_) + ) + where + (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action + +supervisorUpdateNtfSub :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO () +supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHost smpPort _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do + ts <- getCurrentTime + DB.execute + db + [sql| + UPDATE ntf_subscriptions + SET smp_host = ?, smp_port = ?, smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, + ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? + WHERE conn_id = ? + |] + ( (smpHost, smpPort, ntfQueueId, ntfHost, ntfPort, ntfSubId) + :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId) + ) + where + (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action + +supervisorUpdateNtfAction :: DB.Connection -> ConnId -> NtfSubAction -> IO () +supervisorUpdateNtfAction db connId action = do + ts <- getCurrentTime + DB.execute + db + [sql| + UPDATE ntf_subscriptions + SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? + WHERE conn_id = ? + |] + (ntfSubAction, ntfSubSMPAction, ts, True, ts, connId) + where + (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action + +updateNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> NtfActionTs -> IO () +updateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action actionTs = do + r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) + forM_ r $ \updatedBySupervisor -> do + updatedAt <- getCurrentTime + if updatedBySupervisor + then + DB.execute + db + [sql| + UPDATE ntf_subscriptions + SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, updated_by_supervisor = ?, updated_at = ? + WHERE conn_id = ? + |] + (ntfQueueId, ntfSubId, ntfSubStatus, False, updatedAt, connId) + else + DB.execute + db + [sql| + UPDATE ntf_subscriptions + SET smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? + WHERE conn_id = ? + |] + ((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, False, updatedAt, connId)) + where + (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action + +setNullNtfSubscriptionAction :: DB.Connection -> ConnId -> IO () +setNullNtfSubscriptionAction db connId = do + r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) + forM_ r $ \updatedBySupervisor -> + unless updatedBySupervisor $ do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE ntf_subscriptions + SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? + WHERE conn_id = ? + |] + (Nothing :: Maybe NtfSubNTFAction, Nothing :: Maybe NtfSubSMPAction, Nothing :: Maybe UTCTime, False, updatedAt, connId) + +deleteNtfSubscription :: DB.Connection -> ConnId -> IO () +deleteNtfSubscription db connId = do + r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) + forM_ r $ \updatedBySupervisor -> do + updatedAt <- getCurrentTime + if updatedBySupervisor + then + DB.execute + db + [sql| + UPDATE ntf_subscriptions + SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, updated_by_supervisor = ?, updated_at = ? + WHERE conn_id = ? + |] + (Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, False, updatedAt, connId) + else deleteNtfSubscription' db connId + +deleteNtfSubscription' :: DB.Connection -> ConnId -> IO () +deleteNtfSubscription' db connId = do + DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) + +getNextNtfSubNTFActions :: DB.Connection -> NtfServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs)]) +getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _) ntfBatchSize = + getWorkItems "ntf NTF" getNtfConnIds getNtfSubAction (markNtfSubActionNtfFailed_ db) + where + getNtfConnIds :: IO [ConnId] + getNtfConnIds = + map fromOnly + <$> DB.query + db + [sql| + SELECT conn_id + FROM ntf_subscriptions + WHERE ntf_host = ? AND ntf_port = ? AND ntf_sub_action IS NOT NULL + AND (ntf_failed = 0 OR updated_by_supervisor = 1) + ORDER BY ntf_sub_action_ts ASC + LIMIT ? + |] + (ntfHost, ntfPort, ntfBatchSize) + getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs)) + getNtfSubAction connId = do + markUpdatedByWorker db connId + firstRow ntfSubAction err $ + DB.query + db + [sql| + SELECT c.user_id, s.host, s.port, COALESCE(ns.smp_server_key_hash, s.key_hash), + ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_action + FROM ntf_subscriptions ns + JOIN connections c USING (conn_id) + JOIN servers s ON s.host = ns.smp_host AND s.port = ns.smp_port + WHERE ns.conn_id = ? + |] + (Only connId) + where + err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []" + ntfSubAction (userId, smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) = + let smpServer = SMPServer smpHost smpPort smpKeyHash + ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus} + in (action, ntfSubscription, actionTs) + +markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO () +markNtfSubActionNtfFailed_ db connId = + DB.execute db "UPDATE ntf_subscriptions SET ntf_failed = 1 where conn_id = ?" (Only connId) + +getNextNtfSubSMPActions :: DB.Connection -> SMPServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubSMPAction, NtfSubscription)]) +getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize = + getWorkItems "ntf SMP" getNtfConnIds getNtfSubAction (markNtfSubActionSMPFailed_ db) + where + getNtfConnIds :: IO [ConnId] + getNtfConnIds = + map fromOnly + <$> DB.query + db + [sql| + SELECT conn_id + FROM ntf_subscriptions ns + WHERE smp_host = ? AND smp_port = ? AND ntf_sub_smp_action IS NOT NULL AND ntf_sub_action_ts IS NOT NULL + AND (smp_failed = 0 OR updated_by_supervisor = 1) + ORDER BY ntf_sub_action_ts ASC + LIMIT ? + |] + (smpHost, smpPort, ntfBatchSize) + getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubSMPAction, NtfSubscription)) + getNtfSubAction connId = do + markUpdatedByWorker db connId + firstRow ntfSubAction err $ + DB.query + db + [sql| + SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash, + ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_smp_action + FROM ntf_subscriptions ns + JOIN connections c USING (conn_id) + JOIN ntf_servers s USING (ntf_host, ntf_port) + WHERE ns.conn_id = ? + |] + (Only connId) + where + err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []" + ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, action) = + let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash + ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus} + in (action, ntfSubscription) + +markNtfSubActionSMPFailed_ :: DB.Connection -> ConnId -> IO () +markNtfSubActionSMPFailed_ db connId = + DB.execute db "UPDATE ntf_subscriptions SET smp_failed = 1 where conn_id = ?" (Only connId) + +markUpdatedByWorker :: DB.Connection -> ConnId -> IO () +markUpdatedByWorker db connId = + DB.execute db "UPDATE ntf_subscriptions SET updated_by_supervisor = 0 WHERE conn_id = ?" (Only connId) + +getActiveNtfToken :: DB.Connection -> IO (Maybe NtfToken) +getActiveNtfToken db = + maybeFirstRow ntfToken $ + DB.query + db + [sql| + SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash, + t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, + t.tkn_status, t.tkn_action, t.ntf_mode + FROM ntf_tokens t + JOIN ntf_servers s USING (ntf_host, ntf_port) + WHERE t.tkn_status = ? + |] + (Only NTActive) + where + ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) = + let ntfServer = NtfServer host port keyHash + ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey) + ntfMode = fromMaybe NMPeriodic ntfMode_ + in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} + +getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret, Maybe UTCTime)) +getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} = + firstRow' res SEConnNotFound $ + DB.query + db + [sql| + SELECT conn_id, rcv_ntf_dh_secret, last_broker_ts + FROM rcv_queues + WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0 + |] + (host, port, notifierId) + where + res (connId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, rcvNtfDhSecret, lastBrokerTs_) + res _ = Left SEConnNotFound + +setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO () +setConnectionNtfs db connId enableNtfs = + DB.execute db "UPDATE connections SET enable_ntfs = ? WHERE conn_id = ?" (enableNtfs, connId) + +-- * Auxiliary helpers + +instance ToField QueueStatus where toField = toField . serializeQueueStatus + +instance FromField QueueStatus where fromField = fromTextField_ queueStatusT + +instance ToField (DBQueueId 'QSStored) where toField (DBQueueId qId) = toField qId + +instance FromField (DBQueueId 'QSStored) where fromField x = DBQueueId <$> fromField x + +instance ToField InternalRcvId where toField (InternalRcvId x) = toField x + +instance FromField InternalRcvId where fromField x = InternalRcvId <$> fromField x + +instance ToField InternalSndId where toField (InternalSndId x) = toField x + +instance FromField InternalSndId where fromField x = InternalSndId <$> fromField x + +instance ToField InternalId where toField (InternalId x) = toField x + +instance FromField InternalId where fromField x = InternalId <$> fromField x + +instance ToField AgentMessageType where toField = toField . smpEncode + +instance FromField AgentMessageType where fromField = blobFieldParser smpP + +instance ToField MsgIntegrity where toField = toField . strEncode + +instance FromField MsgIntegrity where fromField = blobFieldParser strP + +instance ToField SMPQueueUri where toField = toField . strEncode + +instance FromField SMPQueueUri where fromField = blobFieldParser strP + +instance ToField AConnectionRequestUri where toField = toField . strEncode + +instance FromField AConnectionRequestUri where fromField = blobFieldParser strP + +instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . strEncode + +instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldParser strP + +instance ToField ConnectionMode where toField = toField . decodeLatin1 . strEncode + +instance FromField ConnectionMode where fromField = fromTextField_ connModeT + +instance ToField (SConnectionMode c) where toField = toField . connMode + +instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT + +instance ToField MsgFlags where toField = toField . decodeLatin1 . smpEncode + +instance FromField MsgFlags where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 + +instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList + +instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP + +instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode + +instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +instance ToField AgentCommand where toField = toField . strEncode + +instance FromField AgentCommand where fromField = blobFieldParser strP + +instance ToField AgentCommandTag where toField = toField . strEncode + +instance FromField AgentCommandTag where fromField = blobFieldParser strP + +instance ToField MsgReceiptStatus where toField = toField . decodeLatin1 . strEncode + +instance FromField MsgReceiptStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +instance ToField (Version v) where toField (Version v) = toField v + +instance FromField (Version v) where fromField f = Version <$> fromField f + +deriving newtype instance ToField EntityId + +deriving newtype instance FromField EntityId + +deriving newtype instance ToField ChunkReplicaId + +deriving newtype instance FromField ChunkReplicaId + +listToEither :: e -> [a] -> Either e a +listToEither _ (x : _) = Right x +listToEither e _ = Left e + +firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b) +firstRow f e a = second f . listToEither e <$> a + +maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b) +maybeFirstRow f q = fmap f . listToMaybe <$> q + +firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b) +firstRow' f e a = (f <=< listToEither e) <$> a + +{- ORMOLU_DISABLE -} +-- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k) => + FromRow (a,b,c,d,e,f,g,h,i,j,k) where + fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field + <*> field <*> field <*> field <*> field <*> field + <*> field + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j, + FromField k, FromField l) => + FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where + fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field + <*> field <*> field <*> field <*> field <*> field + <*> field <*> field + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, + ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) => + ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where + toRow (a,b,c,d,e,f,g,h,i,j,k,l) = + [ toField a, toField b, toField c, toField d, toField e, toField f, + toField g, toField h, toField i, toField j, toField k, toField l + ] + +{- ORMOLU_ENABLE -} + +-- * Server helper + +-- | Creates a new server, if it doesn't exist, and returns the passed key hash if it is different from stored. +createServer_ :: DB.Connection -> SMPServer -> IO (Maybe C.KeyHash) +createServer_ db newSrv@ProtocolServer {host, port, keyHash} = + getServerKeyHash_ db newSrv >>= \case + Right keyHash_ -> pure keyHash_ + Left _ -> insertNewServer_ $> Nothing + where + insertNewServer_ = + DB.execute db "INSERT INTO servers (host, port, key_hash) VALUES (?,?,?)" (host, port, keyHash) + +-- | Returns the passed server key hash if it is different from the stored one, or the error if the server does not exist. +getServerKeyHash_ :: DB.Connection -> SMPServer -> IO (Either StoreError (Maybe C.KeyHash)) +getServerKeyHash_ db ProtocolServer {host, port, keyHash} = do + firstRow useKeyHash SEServerNotFound $ + DB.query db "SELECT key_hash FROM servers WHERE host = ? AND port = ?" (host, port) + where + useKeyHash (Only keyHash') = if keyHash /= keyHash' then Just keyHash else Nothing + +upsertNtfServer_ :: DB.Connection -> NtfServer -> IO () +upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do + DB.executeNamed + db + [sql| + INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash) VALUES (:host,:port,:key_hash) + ON CONFLICT (ntf_host, ntf_port) DO UPDATE SET + ntf_host=excluded.ntf_host, + ntf_port=excluded.ntf_port, + ntf_key_hash=excluded.ntf_key_hash; + |] + [":host" := host, ":port" := port, ":key_hash" := keyHash] + +-- * createRcvConn helpers + +insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue +insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ + DB.execute + db + [sql| + INSERT INTO rcv_queues + (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); + |] + ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, sndSecure, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} + +-- * createSndConn helpers + +insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue +insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ + DB.execute + db + [sql| + INSERT OR REPLACE INTO snd_queues + (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); + |] + ((host server, port server, sndId, sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId} + +newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored +newQueueId_ [] = DBQueueId 1 +newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1) + +-- * getConn helpers + +getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn) +getConn = getAnyConn False +{-# INLINE getConn #-} + +getDeletedConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn) +getDeletedConn = getAnyConn True +{-# INLINE getDeletedConn #-} + +getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn) +getAnyConn deleted' dbConn connId = + getConnData dbConn connId >>= \case + Nothing -> pure $ Left SEConnNotFound + Just (cData@ConnData {deleted}, cMode) + | deleted /= deleted' -> pure $ Left SEConnNotFound + | otherwise -> do + rQ <- getRcvQueuesByConnId_ dbConn connId + sQ <- getSndQueuesByConnId_ dbConn connId + pure $ case (rQ, sQ, cMode) of + (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs) + (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq) + (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq) + (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq) + (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData) + _ -> Left SEConnNotFound + +getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn] +getConns = getAnyConns_ False +{-# INLINE getConns #-} + +getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn] +getDeletedConns = getAnyConns_ True +{-# INLINE getDeletedConns #-} + +getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn] +getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db + where + handleDBError :: E.SomeException -> IO (Either StoreError SomeConn) + handleDBError = pure . Left . SEInternal . bshow + +getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode)) +getConnData db connId' = + maybeFirstRow cData $ + DB.query + db + [sql| + SELECT + user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support + FROM connections + WHERE conn_id = ? + |] + (Only connId') + where + cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport) = + (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode) + +setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO () +setConnDeleted db waitDelivery connId + | waitDelivery = do + currentTs <- getCurrentTime + DB.execute db "UPDATE connections SET deleted_at_wait_delivery = ? WHERE conn_id = ?" (currentTs, connId) + | otherwise = + DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId) + +setConnUserId :: DB.Connection -> UserId -> ConnId -> UserId -> IO () +setConnUserId db oldUserId connId newUserId = + DB.execute db "UPDATE connections SET user_id = ? WHERE conn_id = ? and user_id = ?" (newUserId, connId, oldUserId) + +setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO () +setConnAgentVersion db connId aVersion = + DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId) + +setConnPQSupport :: DB.Connection -> ConnId -> PQSupport -> IO () +setConnPQSupport db connId pqSupport = + DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId) + +getDeletedConnIds :: DB.Connection -> IO [ConnId] +getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True) + +getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId] +getDeletedWaitingDeliveryConnIds db = + map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted_at_wait_delivery IS NOT NULL" + +setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO () +setConnRatchetSync db connId ratchetSyncState = + DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId) + +addProcessedRatchetKeyHash :: DB.Connection -> ConnId -> ByteString -> IO () +addProcessedRatchetKeyHash db connId hash = + DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, hash) + +checkRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool +checkRatchetKeyHashExists db connId hash = do + fromMaybe False + <$> maybeFirstRow + fromOnly + ( DB.query + db + "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1" + (connId, hash) + ) + +deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO () +deleteRatchetKeyHashesExpired db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + DB.execute db "DELETE FROM processed_ratchet_key_hashes WHERE created_at < ?" (Only cutoffTs) + +-- | returns all connection queues, the first queue is the primary one +getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue)) +getRcvQueuesByConnId_ db connId = + L.nonEmpty . sortBy primaryFirst . map toRcvQueue + <$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.deleted = 0") (Only connId) + where + primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} = + -- the current primary queue is ordered first, the next primary - second + compare (Down p) (Down p') <> compare i i' + +rcvQueueQuery :: Query +rcvQueueQuery = + [sql| + SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, + q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, + q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret + FROM rcv_queues q + JOIN servers s ON q.host = s.host AND q.port = s.port + JOIN connections c ON q.conn_id = c.conn_id + |] + +toRcvQueue :: + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, SenderCanSecure) + :. (QueueStatus, DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) + :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> + RcvQueue +toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure) :. (status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = + let server = SMPServer host port keyHash + smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ + clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of + (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} + _ -> Nothing + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} + +getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) +getRcvQueueById db connId dbRcvId = + firstRow toRcvQueue SEConnNotFound $ + DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ? AND q.deleted = 0") (connId, dbRcvId) + +-- | returns all connection queues, the first queue is the primary one +getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue)) +getSndQueuesByConnId_ dbConn connId = + L.nonEmpty . sortBy primaryFirst . map toSndQueue + <$> DB.query dbConn (sndQueueQuery <> "WHERE q.conn_id = ?") (Only connId) + where + primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} = + -- the current primary queue is ordered first, the next primary - second + compare (Down p) (Down p') <> compare i i' + +sndQueueQuery :: Query +sndQueueQuery = + [sql| + SELECT + c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.snd_secure, + q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, + q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version + FROM snd_queues q + JOIN servers s ON q.host = s.host AND q.port = s.port + JOIN connections c ON q.conn_id = c.conn_id + |] + +toSndQueue :: + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, SenderCanSecure) + :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) + :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> + SndQueue +toSndQueue + ( (userId, keyHash, connId, host, port, sndId, sndSecure) + :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status) + :. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) + ) = + let server = SMPServer host port keyHash + sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey + in SndQueue {userId, connId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} + +getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue) +getSndQueueById db connId dbSndId = + firstRow toSndQueue SEConnNotFound $ + DB.query db (sndQueueQuery <> " WHERE q.conn_id = ? AND q.snd_queue_id = ?") (connId, dbSndId) + +-- * updateRcvIds helpers + +retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) +retrieveLastIdsAndHashRcv_ dbConn connId = do + [(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)] <- + DB.queryNamed + dbConn + [sql| + SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash + FROM connections + WHERE conn_id = :conn_id; + |] + [":conn_id" := connId] + return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) + +updateLastIdsRcv_ :: DB.Connection -> ConnId -> InternalId -> InternalRcvId -> IO () +updateLastIdsRcv_ dbConn connId 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_id = :conn_id; + |] + [ ":last_internal_msg_id" := newInternalId, + ":last_internal_rcv_msg_id" := newInternalRcvId, + ":conn_id" := connId + ] + +-- * createRcvMsg helpers + +insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO () +insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody, internalRcvId} = do + let MsgMeta {recipient = (internalId, internalTs), pqEncryption} = msgMeta + DB.execute + dbConn + [sql| + INSERT INTO messages + (conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption) + VALUES (?,?,?,?,?,?,?,?,?); + |] + (connId, internalId, internalTs, internalRcvId, Nothing :: Maybe Int64, msgType, msgFlags, msgBody, pqEncryption) + +insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () +insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash, encryptedMsgHash} = do + let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta + DB.executeNamed + db + [sql| + INSERT INTO rcv_messages + ( conn_id, rcv_queue_id, internal_rcv_id, internal_id, external_snd_id, + broker_id, broker_ts, + internal_hash, external_prev_snd_hash, integrity) + VALUES + (:conn_id,:rcv_queue_id,:internal_rcv_id,:internal_id,:external_snd_id, + :broker_id,:broker_ts, + :internal_hash,:external_prev_snd_hash,:integrity); + |] + [ ":conn_id" := connId, + ":rcv_queue_id" := dbQueueId, + ":internal_rcv_id" := internalRcvId, + ":internal_id" := fst recipient, + ":external_snd_id" := sndMsgId, + ":broker_id" := fst broker, + ":broker_ts" := snd broker, + ":internal_hash" := internalHash, + ":external_prev_snd_hash" := externalPrevSndHash, + ":integrity" := integrity + ] + DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash) + +updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO () +updateRcvMsgHash db connId sndMsgId internalRcvId internalHash = + DB.executeNamed + db + -- 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_id = :conn_id + AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id; + |] + [ ":last_external_snd_msg_id" := sndMsgId, + ":last_rcv_msg_hash" := internalHash, + ":conn_id" := connId, + ":last_internal_rcv_msg_id" := internalRcvId + ] + +-- * updateSndIds helpers + +retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) +retrieveLastIdsAndHashSnd_ dbConn connId = do + firstRow id SEConnNotFound $ + DB.queryNamed + dbConn + [sql| + SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash + FROM connections + WHERE conn_id = :conn_id; + |] + [":conn_id" := connId] + +updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO () +updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId = + DB.executeNamed + dbConn + [sql| + UPDATE connections + SET last_internal_msg_id = :last_internal_msg_id, + last_internal_snd_msg_id = :last_internal_snd_msg_id + WHERE conn_id = :conn_id; + |] + [ ":last_internal_msg_id" := newInternalId, + ":last_internal_snd_msg_id" := newInternalSndId, + ":conn_id" := connId + ] + +-- * createSndMsg helpers + +insertSndMsgBase_ :: DB.Connection -> ConnId -> SndMsgData -> IO () +insertSndMsgBase_ db connId SndMsgData {internalId, internalTs, internalSndId, msgType, msgFlags, msgBody, pqEncryption} = do + DB.execute + db + [sql| + INSERT INTO messages + (conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption) + VALUES + (?,?,?,?,?,?,?,?,?); + |] + (connId, internalId, internalTs, Nothing :: Maybe Int64, internalSndId, msgType, msgFlags, msgBody, pqEncryption) + +insertSndMsgDetails_ :: DB.Connection -> ConnId -> SndMsgData -> IO () +insertSndMsgDetails_ dbConn connId SndMsgData {..} = + DB.executeNamed + dbConn + [sql| + INSERT INTO snd_messages + ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash) + VALUES + (:conn_id,:internal_snd_id,:internal_id,:internal_hash,:previous_msg_hash); + |] + [ ":conn_id" := connId, + ":internal_snd_id" := internalSndId, + ":internal_id" := internalId, + ":internal_hash" := internalHash, + ":previous_msg_hash" := prevMsgHash + ] + +updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () +updateSndMsgHash db connId internalSndId internalHash = + DB.executeNamed + db + -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved + [sql| + UPDATE connections + SET last_snd_msg_hash = :last_snd_msg_hash + WHERE conn_id = :conn_id + AND last_internal_snd_msg_id = :last_internal_snd_msg_id; + |] + [ ":last_snd_msg_hash" := internalHash, + ":conn_id" := connId, + ":last_internal_snd_msg_id" := internalSndId + ] + +-- create record with a random ID +createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString) +createWithRandomId gVar create = fst <$$> createWithRandomId' gVar create + +createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError (ByteString, a)) +createWithRandomId' gVar create = tryCreate 3 + where + tryCreate :: Int -> IO (Either StoreError (ByteString, a)) + tryCreate 0 = pure $ Left SEUniqueID + tryCreate n = do + id' <- randomId gVar 12 + E.try (create id') >>= \case + Right r -> pure $ Right (id', r) + Left e + | SQL.sqlError e == SQL.ErrorConstraint -> tryCreate (n - 1) + | otherwise -> pure . Left . SEInternal $ bshow e + +randomId :: TVar ChaChaDRG -> Int -> IO ByteString +randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar + +ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction) +ntfSubAndSMPAction (NSANtf action) = (Just action, Nothing) +ntfSubAndSMPAction (NSASMP action) = (Nothing, Just action) + +createXFTPServer_ :: DB.Connection -> XFTPServer -> IO Int64 +createXFTPServer_ db newSrv@ProtocolServer {host, port, keyHash} = + getXFTPServerId_ db newSrv >>= \case + Right srvId -> pure srvId + Left _ -> insertNewServer_ + where + insertNewServer_ = do + DB.execute db "INSERT INTO xftp_servers (xftp_host, xftp_port, xftp_key_hash) VALUES (?,?,?)" (host, port, keyHash) + insertedRowId db + +getXFTPServerId_ :: DB.Connection -> XFTPServer -> IO (Either StoreError Int64) +getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do + firstRow fromOnly SEXFTPServerNotFound $ + DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash) + +createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file approvedRelays = runExceptT $ do + (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing approvedRelays + liftIO $ + forM_ chunks $ \fc@FileChunk {replicas} -> do + chunkId <- insertRcvFileChunk db fc rcvFileId + forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId + pure rcvFileEntityId + +createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" +createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do + (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays + (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) approvedRelays + liftIO $ + forM_ redirectChunks $ \fc@FileChunk {replicas} -> do + chunkId <- insertRcvFileChunk db fc redirectId + forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId + pure dstEntityId + where + dummyDst = + FileDescription + { party = SFRecipient, + size, + digest, + redirect = Nothing, + -- updated later with updateRcvFileRedirect + key = C.unsafeSbKey $ B.replicate 32 '#', + nonce = C.cbNonce "", + chunkSize = FileSize 0, + chunks = [] + } + +insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId)) +insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ approvedRelays = runExceptT $ do + let (redirectDigest_, redirectSize_) = case redirect of + Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s) + Nothing -> (Nothing, Nothing) + rcvFileEntityId <- ExceptT $ + createWithRandomId gVar $ \rcvFileEntityId -> + DB.execute + db + "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_, approvedRelays)) + rcvFileId <- liftIO $ insertedRowId db + pure (rcvFileEntityId, rcvFileId) + +insertRcvFileChunk :: DB.Connection -> FileChunk -> DBRcvFileId -> IO Int64 +insertRcvFileChunk db FileChunk {chunkNo, chunkSize, digest} rcvFileId = do + DB.execute + db + "INSERT INTO rcv_file_chunks (rcv_file_id, chunk_no, chunk_size, digest) VALUES (?,?,?,?)" + (rcvFileId, chunkNo, chunkSize, digest) + insertedRowId db + +insertRcvFileChunkReplica :: DB.Connection -> Int -> FileChunkReplica -> Int64 -> IO () +insertRcvFileChunkReplica db replicaNo FileChunkReplica {server, replicaId, replicaKey} chunkId = do + srvId <- createXFTPServer_ db server + DB.execute + db + "INSERT INTO rcv_file_chunk_replicas (replica_number, rcv_file_chunk_id, xftp_server_id, replica_id, replica_key) VALUES (?,?,?,?,?)" + (replicaNo, chunkId, srvId, replicaId, replicaKey) + +getRcvFileByEntityId :: DB.Connection -> RcvFileId -> IO (Either StoreError RcvFile) +getRcvFileByEntityId db rcvFileEntityId = runExceptT $ do + rcvFileId <- ExceptT $ getRcvFileIdByEntityId_ db rcvFileEntityId + ExceptT $ getRcvFile db rcvFileId + +getRcvFileIdByEntityId_ :: DB.Connection -> RcvFileId -> IO (Either StoreError DBRcvFileId) +getRcvFileIdByEntityId_ db rcvFileEntityId = + firstRow fromOnly SEFileNotFound $ + DB.query db "SELECT rcv_file_id FROM rcv_files WHERE rcv_file_entity_id = ?" (Only rcvFileEntityId) + +getRcvFileRedirects :: DB.Connection -> DBRcvFileId -> IO [RcvFile] +getRcvFileRedirects db rcvFileId = do + redirects <- fromOnly <$$> DB.query db "SELECT rcv_file_id FROM rcv_files WHERE redirect_id = ?" (Only rcvFileId) + fmap catMaybes . forM redirects $ getRcvFile db >=> either (const $ pure Nothing) (pure . Just) + +getRcvFile :: DB.Connection -> DBRcvFileId -> IO (Either StoreError RcvFile) +getRcvFile db rcvFileId = runExceptT $ do + f@RcvFile {rcvFileEntityId, userId, tmpPath} <- ExceptT getFile + chunks <- maybe (pure []) (liftIO . getChunks rcvFileEntityId userId) tmpPath + pure (f {chunks} :: RcvFile) + where + getFile :: IO (Either StoreError RcvFile) + getFile = do + firstRow toFile SEFileNotFound $ + DB.query + db + [sql| + SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, deleted, redirect_id, redirect_entity_id, redirect_size, redirect_digest + FROM rcv_files + WHERE rcv_file_id = ? + |] + (Only rcvFileId) + where + toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath) :. (FilePath, Maybe C.SbKey, Maybe C.CbNonce, RcvFileStatus, Bool, Maybe DBRcvFileId, Maybe RcvFileId, Maybe (FileSize Int64), Maybe FileDigest) -> RcvFile + toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, deleted, redirectDbId, redirectEntityId, redirectSize_, redirectDigest_)) = + let cfArgs = CFArgs <$> saveKey_ <*> saveNonce_ + saveFile = CryptoFile savePath cfArgs + redirect = + RcvFileRedirect + <$> redirectDbId + <*> redirectEntityId + <*> (RedirectFileInfo <$> redirectSize_ <*> redirectDigest_) + in RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, redirect, prefixPath, tmpPath, saveFile, status, deleted, chunks = []} + getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk] + getChunks rcvFileEntityId userId fileTmpPath = do + chunks <- + map toChunk + <$> DB.query + db + [sql| + SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path + FROM rcv_file_chunks + WHERE rcv_file_id = ? + |] + (Only rcvFileId) + forM chunks $ \chunk@RcvFileChunk {rcvChunkId} -> do + replicas' <- getChunkReplicas rcvChunkId + pure (chunk {replicas = replicas'} :: RcvFileChunk) + where + toChunk :: (Int64, Int, FileSize Word32, FileDigest, Maybe FilePath) -> RcvFileChunk + toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath) = + RcvFileChunk {rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, replicas = []} + getChunkReplicas :: Int64 -> IO [RcvFileChunkReplica] + getChunkReplicas chunkId = do + map toReplica + <$> DB.query + db + [sql| + SELECT + r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM rcv_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + WHERE r.rcv_file_chunk_id = ? + |] + (Only chunkId) + where + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica + toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) = + let server = XFTPServer host port keyHash + in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries} + +updateRcvChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () +updateRcvChunkReplicaDelay db replicaId delay = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (delay, updatedAt, replicaId) + +updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> FilePath -> IO () +updateRcvFileChunkReceived db replicaId chunkId chunkTmpPath = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_file_chunk_replicas SET received = 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (updatedAt, replicaId) + DB.execute db "UPDATE rcv_file_chunks SET tmp_path = ?, updated_at = ? WHERE rcv_file_chunk_id = ?" (chunkTmpPath, updatedAt, chunkId) + +updateRcvFileStatus :: DB.Connection -> DBRcvFileId -> RcvFileStatus -> IO () +updateRcvFileStatus db rcvFileId status = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET status = ?, updated_at = ? WHERE rcv_file_id = ?" (status, updatedAt, rcvFileId) + +updateRcvFileError :: DB.Connection -> DBRcvFileId -> String -> IO () +updateRcvFileError db rcvFileId errStr = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET tmp_path = NULL, error = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (errStr, RFSError, updatedAt, rcvFileId) + +updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> IO () +updateRcvFileComplete db rcvFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET tmp_path = NULL, status = ?, updated_at = ? WHERE rcv_file_id = ?" (RFSComplete, updatedAt, rcvFileId) + +updateRcvFileRedirect :: DB.Connection -> DBRcvFileId -> FileDescription 'FRecipient -> IO (Either StoreError ()) +updateRcvFileRedirect db rcvFileId FileDescription {key, nonce, chunkSize, chunks} = runExceptT $ do + updatedAt <- liftIO getCurrentTime + liftIO $ DB.execute db "UPDATE rcv_files SET key = ?, nonce = ?, chunk_size = ?, updated_at = ? WHERE rcv_file_id = ?" (key, nonce, chunkSize, updatedAt, rcvFileId) + liftIO $ forM_ chunks $ \fc@FileChunk {replicas} -> do + chunkId <- insertRcvFileChunk db fc rcvFileId + forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId + +updateRcvFileNoTmpPath :: DB.Connection -> DBRcvFileId -> IO () +updateRcvFileNoTmpPath db rcvFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET tmp_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId) + +updateRcvFileDeleted :: DB.Connection -> DBRcvFileId -> IO () +updateRcvFileDeleted db rcvFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET deleted = 1, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId) + +deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO () +deleteRcvFile' db rcvFileId = + DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId) + +getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool, Maybe RcvFileId))) +getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do + getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd) + where + getReplicaId :: IO (Maybe (Int64, DBRcvFileId)) + getReplicaId = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + maybeFirstRow id $ + DB.query + db + [sql| + SELECT r.rcv_file_chunk_replica_id, f.rcv_file_id + FROM rcv_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id + JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id + WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ? + AND r.received = 0 AND r.replica_number = 1 + AND f.status = ? AND f.deleted = 0 AND f.created_at >= ? + AND f.failed = 0 + ORDER BY r.retries ASC, r.created_at ASC + LIMIT 1 + |] + (host, port, keyHash, RFSReceiving, cutoffTs) + getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool, Maybe RcvFileId)) + getChunkData (rcvFileChunkReplicaId, _fileId) = + firstRow toChunk SEFileNotFound $ + DB.query + db + [sql| + SELECT + f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, + r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, + f.approved_relays, f.redirect_entity_id + FROM rcv_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id + JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id + WHERE r.rcv_file_chunk_replica_id = ? + |] + (Only rcvFileChunkReplicaId) + where + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. (Bool, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId) + toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (approvedRelays, redirectEntityId_)) = + ( RcvFileChunk + { rcvFileId, + rcvFileEntityId, + userId, + rcvChunkId, + chunkNo, + chunkSize, + digest, + fileTmpPath, + chunkTmpPath, + replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] + }, + approvedRelays, + redirectEntityId_ + ) + +getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile)) +getNextRcvFileToDecrypt db ttl = + getWorkItem "rcv_file_decrypt" getFileId (getRcvFile db) (markRcvFileFailed db) + where + getFileId :: IO (Maybe DBRcvFileId) + getFileId = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT rcv_file_id + FROM rcv_files + WHERE status IN (?,?) AND deleted = 0 AND created_at >= ? + AND failed = 0 + ORDER BY created_at ASC LIMIT 1 + |] + (RFSReceived, RFSDecrypting, cutoffTs) + +markRcvFileFailed :: DB.Connection -> DBRcvFileId -> IO () +markRcvFileFailed db fileId = do + DB.execute db "UPDATE rcv_files SET failed = 1 WHERE rcv_file_id = ?" (Only fileId) + +getPendingRcvFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer] +getPendingRcvFilesServers db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + map toXFTPServer + <$> DB.query + db + [sql| + SELECT DISTINCT + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM rcv_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id + JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id + WHERE r.received = 0 AND r.replica_number = 1 + AND f.status = ? AND f.deleted = 0 AND f.created_at >= ? + |] + (RFSReceiving, cutoffTs) + +toXFTPServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer +toXFTPServer (host, port, keyHash) = XFTPServer host port keyHash + +getCleanupRcvFilesTmpPaths :: DB.Connection -> IO [(DBRcvFileId, RcvFileId, FilePath)] +getCleanupRcvFilesTmpPaths db = + DB.query + db + [sql| + SELECT rcv_file_id, rcv_file_entity_id, tmp_path + FROM rcv_files + WHERE status IN (?,?) AND tmp_path IS NOT NULL + |] + (RFSComplete, RFSError) + +getCleanupRcvFilesDeleted :: DB.Connection -> IO [(DBRcvFileId, RcvFileId, FilePath)] +getCleanupRcvFilesDeleted db = + DB.query_ + db + [sql| + SELECT rcv_file_id, rcv_file_entity_id, prefix_path + FROM rcv_files + WHERE deleted = 1 + |] + +getRcvFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBRcvFileId, RcvFileId, FilePath)] +getRcvFilesExpired db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + DB.query + db + [sql| + SELECT rcv_file_id, rcv_file_entity_id, prefix_path + FROM rcv_files + WHERE created_at < ? + |] + (Only cutoffTs) + +createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId) +createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ = + createWithRandomId gVar $ \sndFileEntityId -> + DB.execute + db + "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" + ((sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_)) + where + (redirectSize_, redirectDigest_) = + case redirect_ of + Nothing -> (Nothing, Nothing) + Just RedirectFileInfo {size, digest} -> (Just size, Just digest) + +getSndFileByEntityId :: DB.Connection -> SndFileId -> IO (Either StoreError SndFile) +getSndFileByEntityId db sndFileEntityId = runExceptT $ do + sndFileId <- ExceptT $ getSndFileIdByEntityId_ db sndFileEntityId + ExceptT $ getSndFile db sndFileId + +getSndFileIdByEntityId_ :: DB.Connection -> SndFileId -> IO (Either StoreError DBSndFileId) +getSndFileIdByEntityId_ db sndFileEntityId = + firstRow fromOnly SEFileNotFound $ + DB.query db "SELECT snd_file_id FROM snd_files WHERE snd_file_entity_id = ?" (Only sndFileEntityId) + +getSndFile :: DB.Connection -> DBSndFileId -> IO (Either StoreError SndFile) +getSndFile db sndFileId = runExceptT $ do + f@SndFile {sndFileEntityId, userId, numRecipients, prefixPath} <- ExceptT getFile + chunks <- maybe (pure []) (liftIO . getChunks sndFileEntityId userId numRecipients) prefixPath + pure (f {chunks} :: SndFile) + where + getFile :: IO (Either StoreError SndFile) + getFile = do + firstRow toFile SEFileNotFound $ + DB.query + db + [sql| + SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest + FROM snd_files + WHERE snd_file_id = ? + |] + (Only sndFileId) + where + toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, Bool, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, deleted, redirectSize_, redirectDigest_)) = + let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ + srcFile = CryptoFile srcPath cfArgs + redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ + in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []} + getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] + getChunks sndFileEntityId userId numRecipients filePrefixPath = do + chunks <- + map toChunk + <$> DB.query + db + [sql| + SELECT snd_file_chunk_id, chunk_no, chunk_offset, chunk_size, digest + FROM snd_file_chunks + WHERE snd_file_id = ? + |] + (Only sndFileId) + forM chunks $ \chunk@SndFileChunk {sndChunkId} -> do + replicas' <- getChunkReplicas sndChunkId + pure (chunk {replicas = replicas'} :: SndFileChunk) + where + toChunk :: (Int64, Int, Int64, Word32, FileDigest) -> SndFileChunk + toChunk (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) = + let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize} + in SndFileChunk {sndFileId, sndFileEntityId, userId, numRecipients, sndChunkId, chunkNo, chunkSpec, filePrefixPath, digest, replicas = []} + getChunkReplicas :: Int64 -> IO [SndFileChunkReplica] + getChunkReplicas chunkId = do + replicas <- + map toReplica + <$> DB.query + db + [sql| + SELECT + r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM snd_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + WHERE r.snd_file_chunk_id = ? + |] + (Only chunkId) + forM replicas $ \replica@SndFileChunkReplica {sndChunkReplicaId} -> do + rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId + pure (replica :: SndFileChunkReplica) {rcvIdsKeys} + where + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica + toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) = + let server = XFTPServer host port keyHash + in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []} + +getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)] +getChunkReplicaRecipients_ db replicaId = + DB.query + db + [sql| + SELECT rcv_replica_id, rcv_replica_key + FROM snd_file_chunk_replica_recipients + WHERE snd_file_chunk_replica_id = ? + |] + (Only replicaId) + +getNextSndFileToPrepare :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe SndFile)) +getNextSndFileToPrepare db ttl = + getWorkItem "snd_file_prepare" getFileId (getSndFile db) (markSndFileFailed db) + where + getFileId :: IO (Maybe DBSndFileId) + getFileId = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT snd_file_id + FROM snd_files + WHERE status IN (?,?,?) AND deleted = 0 AND created_at >= ? + AND failed = 0 + ORDER BY created_at ASC LIMIT 1 + |] + (SFSNew, SFSEncrypting, SFSEncrypted, cutoffTs) + +markSndFileFailed :: DB.Connection -> DBSndFileId -> IO () +markSndFileFailed db fileId = + DB.execute db "UPDATE snd_files SET failed = 1 WHERE snd_file_id = ?" (Only fileId) + +updateSndFileError :: DB.Connection -> DBSndFileId -> String -> IO () +updateSndFileError db sndFileId errStr = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_files SET prefix_path = NULL, error = ?, status = ?, updated_at = ? WHERE snd_file_id = ?" (errStr, SFSError, updatedAt, sndFileId) + +updateSndFileStatus :: DB.Connection -> DBSndFileId -> SndFileStatus -> IO () +updateSndFileStatus db sndFileId status = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_files SET status = ?, updated_at = ? WHERE snd_file_id = ?" (status, updatedAt, sndFileId) + +updateSndFileEncrypted :: DB.Connection -> DBSndFileId -> FileDigest -> [(XFTPChunkSpec, FileDigest)] -> IO () +updateSndFileEncrypted db sndFileId digest chunkSpecsDigests = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_files SET status = ?, digest = ?, updated_at = ? WHERE snd_file_id = ?" (SFSEncrypted, digest, updatedAt, sndFileId) + forM_ (zip [1 ..] chunkSpecsDigests) $ \(chunkNo :: Int, (XFTPChunkSpec {chunkOffset, chunkSize}, chunkDigest)) -> + DB.execute db "INSERT INTO snd_file_chunks (snd_file_id, chunk_no, chunk_offset, chunk_size, digest) VALUES (?,?,?,?,?)" (sndFileId, chunkNo, chunkOffset, chunkSize, chunkDigest) + +updateSndFileComplete :: DB.Connection -> DBSndFileId -> IO () +updateSndFileComplete db sndFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_files SET prefix_path = NULL, status = ?, updated_at = ? WHERE snd_file_id = ?" (SFSComplete, updatedAt, sndFileId) + +updateSndFileNoPrefixPath :: DB.Connection -> DBSndFileId -> IO () +updateSndFileNoPrefixPath db sndFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_files SET prefix_path = NULL, updated_at = ? WHERE snd_file_id = ?" (updatedAt, sndFileId) + +updateSndFileDeleted :: DB.Connection -> DBSndFileId -> IO () +updateSndFileDeleted db sndFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_files SET deleted = 1, updated_at = ? WHERE snd_file_id = ?" (updatedAt, sndFileId) + +deleteSndFile' :: DB.Connection -> DBSndFileId -> IO () +deleteSndFile' db sndFileId = + DB.execute db "DELETE FROM snd_files WHERE snd_file_id = ?" (Only sndFileId) + +getSndFileDeleted :: DB.Connection -> DBSndFileId -> IO Bool +getSndFileDeleted db sndFileId = + fromMaybe True + <$> maybeFirstRow fromOnly (DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)) + +createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> IO () +createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId + +createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO () +createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do + srvId <- createXFTPServer_ db server + DB.execute + db + [sql| + INSERT INTO snd_file_chunk_replicas + (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status) + VALUES (?,?,?,?,?,?) + |] + (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated) + rId <- insertedRowId db + forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do + DB.execute + db + [sql| + INSERT INTO snd_file_chunk_replica_recipients + (snd_file_chunk_replica_id, rcv_replica_id, rcv_replica_key) + VALUES (?,?,?) + |] + (rId, rcvId, rcvKey) + +getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe SndFileChunk)) +getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do + getWorkItem "snd_file_upload" getReplicaId getChunkData (markSndFileFailed db . snd) + where + getReplicaId :: IO (Maybe (Int64, DBSndFileId)) + getReplicaId = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + maybeFirstRow id $ + DB.query + db + [sql| + SELECT r.snd_file_chunk_replica_id, f.snd_file_id + FROM snd_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id + JOIN snd_files f ON f.snd_file_id = c.snd_file_id + WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ? + AND r.replica_status = ? AND r.replica_number = 1 + AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ? + AND f.failed = 0 + ORDER BY r.retries ASC, r.created_at ASC + LIMIT 1 + |] + (host, port, keyHash, SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs) + getChunkData :: (Int64, DBSndFileId) -> IO (Either StoreError SndFileChunk) + getChunkData (sndFileChunkReplicaId, _fileId) = do + chunk_ <- + firstRow toChunk SEFileNotFound $ + DB.query + db + [sql| + SELECT + f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path, + c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest, + r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries + FROM snd_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id + JOIN snd_files f ON f.snd_file_id = c.snd_file_id + WHERE r.snd_file_chunk_replica_id = ? + |] + (Only sndFileChunkReplicaId) + forM chunk_ $ \chunk@SndFileChunk {replicas} -> do + replicas' <- forM replicas $ \replica@SndFileChunkReplica {sndChunkReplicaId} -> do + rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId + pure (replica :: SndFileChunkReplica) {rcvIdsKeys} + pure (chunk {replicas = replicas'} :: SndFileChunk) + where + toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk + toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) = + let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize} + in SndFileChunk + { sndFileId, + sndFileEntityId, + userId, + numRecipients, + sndChunkId, + chunkNo, + chunkSpec, + digest, + filePrefixPath, + replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}] + } + +updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () +updateSndChunkReplicaDelay db replicaId delay = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (delay, updatedAt, replicaId) + +addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateAuthKey)] -> IO SndFileChunkReplica +addSndChunkReplicaRecipients db r@SndFileChunkReplica {sndChunkReplicaId} rcvIdsKeys = do + forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do + DB.execute + db + [sql| + INSERT INTO snd_file_chunk_replica_recipients + (snd_file_chunk_replica_id, rcv_replica_id, rcv_replica_key) + VALUES (?,?,?) + |] + (sndChunkReplicaId, rcvId, rcvKey) + rcvIdsKeys' <- getChunkReplicaRecipients_ db sndChunkReplicaId + pure (r :: SndFileChunkReplica) {rcvIdsKeys = rcvIdsKeys'} + +updateSndChunkReplicaStatus :: DB.Connection -> Int64 -> SndFileReplicaStatus -> IO () +updateSndChunkReplicaStatus db replicaId status = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE snd_file_chunk_replicas SET replica_status = ?, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (status, updatedAt, replicaId) + +getPendingSndFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer] +getPendingSndFilesServers db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + map toXFTPServer + <$> DB.query + db + [sql| + SELECT DISTINCT + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM snd_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id + JOIN snd_files f ON f.snd_file_id = c.snd_file_id + WHERE r.replica_status = ? AND r.replica_number = 1 + AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ? + |] + (SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs) + +getCleanupSndFilesPrefixPaths :: DB.Connection -> IO [(DBSndFileId, SndFileId, FilePath)] +getCleanupSndFilesPrefixPaths db = + DB.query + db + [sql| + SELECT snd_file_id, snd_file_entity_id, prefix_path + FROM snd_files + WHERE status IN (?,?) AND prefix_path IS NOT NULL + |] + (SFSComplete, SFSError) + +getCleanupSndFilesDeleted :: DB.Connection -> IO [(DBSndFileId, SndFileId, Maybe FilePath)] +getCleanupSndFilesDeleted db = + DB.query_ + db + [sql| + SELECT snd_file_id, snd_file_entity_id, prefix_path + FROM snd_files + WHERE deleted = 1 + |] + +getSndFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBSndFileId, SndFileId, Maybe FilePath)] +getSndFilesExpired db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + DB.query + db + [sql| + SELECT snd_file_id, snd_file_entity_id, prefix_path + FROM snd_files + WHERE created_at < ? + |] + (Only cutoffTs) + +createDeletedSndChunkReplica :: DB.Connection -> UserId -> FileChunkReplica -> FileDigest -> IO () +createDeletedSndChunkReplica db userId FileChunkReplica {server, replicaId, replicaKey} chunkDigest = do + srvId <- createXFTPServer_ db server + DB.execute + db + "INSERT INTO deleted_snd_chunk_replicas (user_id, xftp_server_id, replica_id, replica_key, chunk_digest) VALUES (?,?,?,?,?)" + (userId, srvId, replicaId, replicaKey, chunkDigest) + +getDeletedSndChunkReplica :: DB.Connection -> DBSndFileId -> IO (Either StoreError DeletedSndChunkReplica) +getDeletedSndChunkReplica db deletedSndChunkReplicaId = + firstRow toReplica SEDeletedSndChunkReplicaNotFound $ + DB.query + db + [sql| + SELECT + r.user_id, r.replica_id, r.replica_key, r.chunk_digest, r.delay, r.retries, + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM deleted_snd_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + WHERE r.deleted_snd_chunk_replica_id = ? + |] + (Only deletedSndChunkReplicaId) + where + toReplica :: (UserId, ChunkReplicaId, C.APrivateAuthKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica + toReplica (userId, replicaId, replicaKey, chunkDigest, delay, retries, host, port, keyHash) = + let server = XFTPServer host port keyHash + in DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, replicaId, replicaKey, chunkDigest, delay, retries} + +getNextDeletedSndChunkReplica :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe DeletedSndChunkReplica)) +getNextDeletedSndChunkReplica db ProtocolServer {host, port, keyHash} ttl = + getWorkItem "deleted replica" getReplicaId (getDeletedSndChunkReplica db) markReplicaFailed + where + getReplicaId :: IO (Maybe Int64) + getReplicaId = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT r.deleted_snd_chunk_replica_id + FROM deleted_snd_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ? + AND r.created_at >= ? + AND failed = 0 + ORDER BY r.retries ASC, r.created_at ASC + LIMIT 1 + |] + (host, port, keyHash, cutoffTs) + markReplicaFailed :: Int64 -> IO () + markReplicaFailed replicaId = do + DB.execute db "UPDATE deleted_snd_chunk_replicas SET failed = 1 WHERE deleted_snd_chunk_replica_id = ?" (Only replicaId) + +updateDeletedSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () +updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId delay = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE deleted_snd_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE deleted_snd_chunk_replica_id = ?" (delay, updatedAt, deletedSndChunkReplicaId) + +deleteDeletedSndChunkReplica :: DB.Connection -> Int64 -> IO () +deleteDeletedSndChunkReplica db deletedSndChunkReplicaId = + DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE deleted_snd_chunk_replica_id = ?" (Only deletedSndChunkReplicaId) + +getPendingDelFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer] +getPendingDelFilesServers db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + map toXFTPServer + <$> DB.query + db + [sql| + SELECT DISTINCT + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM deleted_snd_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + WHERE r.created_at >= ? + |] + (Only cutoffTs) + +deleteDeletedSndChunkReplicasExpired :: DB.Connection -> NominalDiffTime -> IO () +deleteDeletedSndChunkReplicasExpired db ttl = do + cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime + DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE created_at < ?" (Only cutoffTs) + +updateServersStats :: DB.Connection -> AgentPersistedServerStats -> IO () +updateServersStats db stats = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE servers_stats SET servers_stats = ?, updated_at = ? WHERE servers_stats_id = 1" (stats, updatedAt) + +getServersStats :: DB.Connection -> IO (Either StoreError (UTCTime, Maybe AgentPersistedServerStats)) +getServersStats db = + firstRow id SEServersStatsNotFound $ + DB.query_ db "SELECT started_at, servers_stats FROM servers_stats WHERE servers_stats_id = 1" + +resetServersStats :: DB.Connection -> UTCTime -> IO () +resetServersStats db startedAt = + DB.execute db "UPDATE servers_stats SET servers_stats = NULL, started_at = ?, updated_at = ? WHERE servers_stats_id = 1" (startedAt, startedAt) diff --git a/src/Simplex/Messaging/Agent/Store/Common.hs b/src/Simplex/Messaging/Agent/Store/Common.hs new file mode 100644 index 000000000..e83cfe03b --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Common.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} + +module Simplex.Messaging.Agent.Store.Common +#if defined(dbPostgres) + ( module Simplex.Messaging.Agent.Store.Postgres.Common, + ) + where +import Simplex.Messaging.Agent.Store.Postgres.Common +#else + ( module Simplex.Messaging.Agent.Store.SQLite.Common, + ) + where +import Simplex.Messaging.Agent.Store.SQLite.Common +#endif diff --git a/src/Simplex/Messaging/Agent/Store/DB.hs b/src/Simplex/Messaging/Agent/Store/DB.hs new file mode 100644 index 000000000..f8c54e463 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/DB.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE CPP #-} + +module Simplex.Messaging.Agent.Store.DB +#if defined(dbPostgres) + ( module Simplex.Messaging.Agent.Store.Postgres.DB, + ) + where +import Simplex.Messaging.Agent.Store.Postgres.DB +#else + ( module Simplex.Messaging.Agent.Store.SQLite.DB, + ) + where +import Simplex.Messaging.Agent.Store.SQLite.DB +#endif + diff --git a/src/Simplex/Messaging/Agent/Store/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Migrations.hs new file mode 100644 index 000000000..35015f634 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Migrations.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +module Simplex.Messaging.Agent.Store.Migrations + ( Migration (..), + MigrationsToRun (..), + DownMigration (..), + Migrations.app, + Migrations.getCurrent, + get, + Migrations.initialize, + Migrations.run, + migrateSchema, + -- for tests + migrationsToRun, + toDownMigration, + ) +where + +import Control.Monad +import Data.Char (toLower) +import Data.Functor (($>)) +import Data.Maybe (isNothing, mapMaybe) +import Simplex.Messaging.Agent.Store.Common +import Simplex.Messaging.Agent.Store.Shared +import System.Exit (exitFailure) +import System.IO (hFlush, stdout) +#if defined(dbPostgres) +import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations +#else +import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import System.Directory (copyFile) +#endif + +get :: DBStore -> [Migration] -> IO (Either MTRError MigrationsToRun) +get st migrations = migrationsToRun migrations <$> withTransaction st Migrations.getCurrent + +migrationsToRun :: [Migration] -> [Migration] -> Either MTRError MigrationsToRun +migrationsToRun [] [] = Right MTRNone +migrationsToRun appMs [] = Right $ MTRUp appMs +migrationsToRun [] dbMs + | length dms == length dbMs = Right $ MTRDown dms + | otherwise = Left $ MTRENoDown $ mapMaybe nameNoDown dbMs + where + dms = mapMaybe toDownMigration dbMs + nameNoDown m = if isNothing (down m) then Just $ name m else Nothing +migrationsToRun (a : as) (d : ds) + | name a == name d = migrationsToRun as ds + | otherwise = Left $ MTREDifferent (name a) (name d) + +migrateSchema :: DBStore -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ()) +migrateSchema st migrations confirmMigrations = do + Migrations.initialize st + get st migrations >>= \case + Left e -> do + when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e) + pure . Left $ MigrationError e + Right MTRNone -> pure $ Right () + Right ms@(MTRUp ums) + | dbNew st -> Migrations.run st ms $> Right () + | otherwise -> case confirmMigrations of + MCYesUp -> runWithBackup st ms + MCYesUpDown -> runWithBackup st ms + MCConsole -> confirm err >> runWithBackup st ms + MCError -> pure $ Left err + where + err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums) + Right ms@(MTRDown dms) -> case confirmMigrations of + MCYesUpDown -> runWithBackup st ms + MCConsole -> confirm err >> runWithBackup st ms + MCYesUp -> pure $ Left err + MCError -> pure $ Left err + where + err = MEDowngrade $ map downName dms + where + confirm err = confirmOrExit $ migrationErrorDescription err + +runWithBackup :: DBStore -> MigrationsToRun -> IO (Either a ()) +#if defined(dbPostgres) +runWithBackup st ms = Migrations.run st ms $> Right () +#else +runWithBackup st ms = do + let f = dbFilePath st + copyFile f (f <> ".bak") + Migrations.run st ms + pure $ Right () +#endif + +confirmOrExit :: String -> IO () +confirmOrExit s = do + putStrLn s + putStr "Continue (y/N): " + hFlush stdout + ok <- getLine + when (map toLower ok /= "y") exitFailure diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs new file mode 100644 index 000000000..037ac6bb9 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -0,0 +1,42 @@ +module Simplex.Messaging.Agent.Store.Postgres + ( createDBStore, + closeDBStore, + execSQL, + ) +where + +import Data.Text (Text) +import qualified Database.PostgreSQL.Simple as PSQL +import Simplex.Messaging.Agent.Store.Postgres.Common +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) + +-- TODO [postgres] pass db name / ConnectInfo? +createDBStore :: [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createDBStore = undefined + +closeDBStore :: DBStore -> IO () +closeDBStore = undefined + +execSQL :: PSQL.Connection -> Text -> IO [Text] +execSQL = undefined + +-- createDatabaseIfNotExists :: ConnectInfo -> String -> IO () +-- createDatabaseIfNotExists defaultConnectInfo targetDbName = do +-- -- Connect to the default maintenance database (e.g., postgres) +-- bracket (connect defaultConnectInfo) close $ \conn -> do +-- -- Check if the database already exists +-- [Only dbExists] <- query conn +-- [sql| +-- SELECT EXISTS ( +-- SELECT 1 FROM pg_catalog.pg_database +-- WHERE datname = ? +-- ) +-- |] (Only targetDbName) + +-- -- If it doesn't exist, create the database +-- if not dbExists +-- then do +-- putStrLn $ "Creating database: " ++ targetDbName +-- execute_ conn (Query $ "CREATE DATABASE " <> targetDbName) +-- putStrLn "Database created." +-- else putStrLn "Database already exists." diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs new file mode 100644 index 000000000..bdcb63bbd --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Messaging.Agent.Store.Postgres.Common + ( DBStore (..), + withConnection, + withConnection', + withTransaction, + withTransaction', + withTransactionPriority, + ) +where + +import qualified Database.PostgreSQL.Simple as PSQL +import UnliftIO.MVar +import UnliftIO.STM + +-- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type) +data DBStore = DBStore + { dbConnectInfo :: PSQL.ConnectInfo, + dbConnection :: MVar PSQL.Connection, + dbClosed :: TVar Bool, + dbNew :: Bool + } + +-- TODO [postgres] semaphore / connection pool? +withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a +withConnectionPriority DBStore {dbConnection} _priority action = + withMVar dbConnection action + +withConnection :: DBStore -> (PSQL.Connection -> IO a) -> IO a +withConnection st = withConnectionPriority st False + +withConnection' :: DBStore -> (PSQL.Connection -> IO a) -> IO a +withConnection' = withConnection + +withTransaction' :: DBStore -> (PSQL.Connection -> IO a) -> IO a +withTransaction' = withTransaction + +withTransaction :: DBStore -> (PSQL.Connection -> IO a) -> IO a +withTransaction st = withTransactionPriority st False +{-# INLINE withTransaction #-} + +-- TODO [postgres] analogue for dbBusyLoop? +withTransactionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a +withTransactionPriority st priority action = withConnectionPriority st priority transaction + where + transaction conn = PSQL.withTransaction conn $ action conn diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs new file mode 100644 index 000000000..3fb8f593e --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs @@ -0,0 +1,26 @@ +module Simplex.Messaging.Agent.Store.Postgres.DB + ( PSQL.Connection, + PSQL.connect, + PSQL.close, + execute, + execute_, + executeMany, + PSQL.query, + PSQL.query_, + ) +where + +import Control.Monad (void) +import qualified Database.PostgreSQL.Simple as PSQL + +execute :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> q -> IO () +execute db q qs = void $ PSQL.execute db q qs +{-# INLINE execute #-} + +execute_ :: PSQL.Connection -> PSQL.Query -> IO () +execute_ db q = void $ PSQL.execute_ db q +{-# INLINE execute_ #-} + +executeMany :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> [q] -> IO () +executeMany db q qs = void $ PSQL.executeMany db q qs +{-# INLINE executeMany #-} diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs new file mode 100644 index 000000000..ed44c09b6 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations + ( app, + initialize, + run, + getCurrent, + ) +where + +import Data.List (sortOn) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Database.PostgreSQL.Simple as PSQL +import Simplex.Messaging.Agent.Store.Postgres.Common +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial +import Simplex.Messaging.Agent.Store.Shared + +schemaMigrations :: [(String, Text, Maybe Text)] +schemaMigrations = + [ ("20241210_initial", m20241210_initial, Nothing) + ] + +-- | The list of migrations in ascending order by date +app :: [Migration] +app = sortOn name $ map migration schemaMigrations + where + migration (name, up, down) = Migration {name, up, down = down} + +-- TODO [postgres] initialize +initialize :: DBStore -> IO () +initialize st = undefined + +-- TODO [postgres] run +run :: DBStore -> MigrationsToRun -> IO () +run st = undefined + +getCurrent :: PSQL.Connection -> IO [Migration] +getCurrent db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;" + where + toMigration (name, down) = Migration {name, up = T.pack "", down} diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs index 9008c86ce..3fab63768 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs @@ -2,26 +2,22 @@ module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial where -import Database.PostgreSQL.Simple (Query) -import Database.PostgreSQL.Simple.SqlQQ (sql) +import Data.Text (Text) +import qualified Data.Text as T +import Text.RawString.QQ (r) -m20241210_initial :: Query +m20241210_initial :: Text m20241210_initial = - [sql| + T.pack + [r| REVOKE CREATE ON SCHEMA public FROM PUBLIC; --- TODO remove +-- TODO [postgres] remove DROP SCHEMA IF EXISTS agent_schema CASCADE; CREATE SCHEMA agent_schema; SET search_path TO agent_schema; -CREATE TABLE migrations( - name TEXT NOT NULL, - ts TEXT NOT NULL, - down TEXT, - PRIMARY KEY(name) -); CREATE TABLE users( user_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, deleted INTEGER NOT NULL DEFAULT 0 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 7e60e4070..b0c53dee2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -18,7 +18,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,384 +25,54 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Simplex.Messaging.Agent.Store.SQLite - ( SQLiteStore (..), - MigrationConfirmation (..), - MigrationError (..), - UpMigration (..), - createSQLiteStore, + ( createDBStore, connectSQLiteStore, - closeSQLiteStore, + closeDBStore, openSQLiteStore, reopenSQLiteStore, sqlString, keyString, storeKey, execSQL, - upMigration, -- used in tests - - -- * Users - createUserRecord, - deleteUserRecord, - setUserDeleted, - deleteUserWithoutConns, - deleteUsersWithoutConns, - checkUser, - - -- * Queues and connections - createNewConn, - updateNewConnRcv, - updateNewConnSnd, - createSndConn, - getConn, - getDeletedConn, - getConns, - getDeletedConns, - getConnData, - setConnDeleted, - setConnUserId, - setConnAgentVersion, - setConnPQSupport, - getDeletedConnIds, - getDeletedWaitingDeliveryConnIds, - setConnRatchetSync, - addProcessedRatchetKeyHash, - checkRatchetKeyHashExists, - deleteRatchetKeyHashesExpired, - getRcvConn, - getRcvQueueById, - getSndQueueById, - deleteConn, - upgradeRcvConnToDuplex, - upgradeSndConnToDuplex, - addConnRcvQueue, - addConnSndQueue, - setRcvQueueStatus, - setRcvSwitchStatus, - setRcvQueueDeleted, - setRcvQueueConfirmedE2E, - setSndQueueStatus, - setSndSwitchStatus, - setRcvQueuePrimary, - setSndQueuePrimary, - deleteConnRcvQueue, - incRcvDeleteErrors, - deleteConnSndQueue, - getPrimaryRcvQueue, - getRcvQueue, - getDeletedRcvQueue, - setRcvQueueNtfCreds, - -- Confirmations - createConfirmation, - acceptConfirmation, - getAcceptedConfirmation, - removeConfirmations, - -- Invitations - sent via Contact connections - createInvitation, - getInvitation, - acceptInvitation, - unacceptInvitation, - deleteInvitation, - -- Messages - updateRcvIds, - createRcvMsg, - updateRcvMsgHash, - updateSndIds, - createSndMsg, - updateSndMsgHash, - createSndMsgDelivery, - getSndMsgViaRcpt, - updateSndMsgRcpt, - getPendingQueueMsg, - getConnectionsForDelivery, - updatePendingMsgRIState, - deletePendingMsgs, - getExpiredSndMessages, - setMsgUserAck, - getRcvMsg, - getLastMsg, - checkRcvMsgHashExists, - getRcvMsgBrokerTs, - deleteMsg, - deleteDeliveredSndMsg, - deleteSndMsgDelivery, - deleteRcvMsgHashesExpired, - deleteSndMsgsExpired, - -- Double ratchet persistence - createRatchetX3dhKeys, - getRatchetX3dhKeys, - setRatchetX3dhKeys, - createRatchet, - deleteRatchet, - getRatchet, - getSkippedMsgKeys, - updateRatchet, - -- Async commands - createCommand, - getPendingCommandServers, - getPendingServerCommand, - updateCommandServer, - deleteCommand, - -- Notification device token persistence - createNtfToken, - getSavedNtfToken, - updateNtfTokenRegistration, - updateDeviceToken, - updateNtfMode, - updateNtfToken, - removeNtfToken, - addNtfTokenToDelete, - deleteExpiredNtfTokensToDelete, - NtfTokenToDelete, - getNextNtfTokenToDelete, - markNtfTokenToDeleteFailed_, -- exported for tests - getPendingDelTknServers, - deleteNtfTokenToDelete, - -- Notification subscription persistence - NtfSupervisorSub, - getNtfSubscription, - createNtfSubscription, - supervisorUpdateNtfSub, - supervisorUpdateNtfAction, - updateNtfSubscription, - setNullNtfSubscriptionAction, - deleteNtfSubscription, - deleteNtfSubscription', - getNextNtfSubNTFActions, - markNtfSubActionNtfFailed_, -- exported for tests - getNextNtfSubSMPActions, - markNtfSubActionSMPFailed_, -- exported for tests - getActiveNtfToken, - getNtfRcvQueue, - setConnectionNtfs, - - -- * File transfer - - -- Rcv files - createRcvFile, - createRcvFileRedirect, - getRcvFile, - getRcvFileByEntityId, - getRcvFileRedirects, - updateRcvChunkReplicaDelay, - updateRcvFileChunkReceived, - updateRcvFileStatus, - updateRcvFileError, - updateRcvFileComplete, - updateRcvFileRedirect, - updateRcvFileNoTmpPath, - updateRcvFileDeleted, - deleteRcvFile', - getNextRcvChunkToDownload, - getNextRcvFileToDecrypt, - getPendingRcvFilesServers, - getCleanupRcvFilesTmpPaths, - getCleanupRcvFilesDeleted, - getRcvFilesExpired, - -- Snd files - createSndFile, - getSndFile, - getSndFileByEntityId, - getNextSndFileToPrepare, - updateSndFileError, - updateSndFileStatus, - updateSndFileEncrypted, - updateSndFileComplete, - updateSndFileNoPrefixPath, - updateSndFileDeleted, - deleteSndFile', - getSndFileDeleted, - createSndFileReplica, - createSndFileReplica_, -- exported for tests - getNextSndChunkToUpload, - updateSndChunkReplicaDelay, - addSndChunkReplicaRecipients, - updateSndChunkReplicaStatus, - getPendingSndFilesServers, - getCleanupSndFilesPrefixPaths, - getCleanupSndFilesDeleted, - getSndFilesExpired, - createDeletedSndChunkReplica, - getNextDeletedSndChunkReplica, - updateDeletedSndChunkReplicaDelay, - deleteDeletedSndChunkReplica, - getPendingDelFilesServers, - deleteDeletedSndChunkReplicasExpired, - -- Stats - updateServersStats, - getServersStats, - resetServersStats, - - -- * utilities - withConnection, - withTransaction, - withTransactionPriority, - firstRow, - firstRow', - maybeFirstRow, ) where -import Control.Logger.Simple import Control.Monad -import Control.Monad.Except -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Crypto.Random (ChaChaDRG) -import qualified Data.Aeson.TH as J -import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Bifunctor (first, second) import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base64.URL as U -import qualified Data.ByteString.Char8 as B -import Data.Char (toLower) import Data.Functor (($>)) import Data.IORef -import Data.Int (Int64) -import Data.List (foldl', intercalate, sortBy) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as L -import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) -import Data.Ord (Down (..)) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) -import Data.Word (Word32) -import Database.SQLite.Simple (FromRow (..), NamedParam (..), Only (..), Query (..), SQLError, ToRow (..), field, (:.) (..)) +import Database.SQLite.Simple (Query (..)) import qualified Database.SQLite.Simple as SQL -import Database.SQLite.Simple.FromField import Database.SQLite.Simple.QQ (sql) -import Database.SQLite.Simple.ToField (ToField (..)) import qualified Database.SQLite3 as SQLite3 -import Network.Socket (ServiceName) -import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) -import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) -import Simplex.FileTransfer.Types -import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) -import Simplex.Messaging.Agent.Stats -import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Agent.Store.Migrations (migrateSchema) import Simplex.Messaging.Agent.Store.SQLite.Common import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB -import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRError, Migration (..), MigrationsToRun (..), mtrErrorDescription) -import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations -import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) -import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys) -import qualified Simplex.Messaging.Crypto.Ratchet as CR -import Simplex.Messaging.Encoding -import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..)) -import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Parsers (blobFieldParser, defaultJSON, dropPrefix, fromTextField_, sumTypeJSON) -import Simplex.Messaging.Protocol -import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, tshow, ($>>=), (<$$>)) -import Simplex.Messaging.Version.Internal -import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist) -import System.Exit (exitFailure) +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) +import Simplex.Messaging.Util (ifM, safeDecodeUtf8) +import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (takeDirectory) -import System.IO (hFlush, stdout) import UnliftIO.Exception (bracketOnError, onException) -import qualified UnliftIO.Exception as E import UnliftIO.MVar import UnliftIO.STM -- * SQLite Store implementation -data MigrationError - = MEUpgrade {upMigrations :: [UpMigration]} - | MEDowngrade {downMigrations :: [String]} - | MigrationError {mtrError :: MTRError} - deriving (Eq, Show) - -migrationErrorDescription :: MigrationError -> String -migrationErrorDescription = \case - MEUpgrade ums -> - "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums) - MEDowngrade dms -> - "Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms - MigrationError err -> mtrErrorDescription err - -data UpMigration = UpMigration {upName :: String, withDown :: Bool} - deriving (Eq, Show) - -upMigration :: Migration -> UpMigration -upMigration Migration {name, down} = UpMigration name $ isJust down - -data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError - deriving (Eq, Show) - -instance StrEncoding MigrationConfirmation where - strEncode = \case - MCYesUp -> "yesUp" - MCYesUpDown -> "yesUpDown" - MCConsole -> "console" - MCError -> "error" - strP = - A.takeByteString >>= \case - "yesUp" -> pure MCYesUp - "yesUpDown" -> pure MCYesUpDown - "console" -> pure MCConsole - "error" -> pure MCError - _ -> fail "invalid MigrationConfirmation" - -createSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore) -createSQLiteStore dbFilePath dbKey keepKey migrations confirmMigrations = do +createDBStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createDBStore dbFilePath dbKey keepKey migrations confirmMigrations = do let dbDir = takeDirectory dbFilePath createDirectoryIfMissing True dbDir st <- connectSQLiteStore dbFilePath dbKey keepKey - r <- migrateSchema st migrations confirmMigrations `onException` closeSQLiteStore st + r <- migrateSchema st migrations confirmMigrations `onException` closeDBStore st case r of Right () -> pure $ Right st - Left e -> closeSQLiteStore st $> Left e + Left e -> closeDBStore st $> Left e -migrateSchema :: SQLiteStore -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ()) -migrateSchema st migrations confirmMigrations = do - Migrations.initialize st - Migrations.get st migrations >>= \case - Left e -> do - when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e) - pure . Left $ MigrationError e - Right MTRNone -> pure $ Right () - Right ms@(MTRUp ums) - | dbNew st -> Migrations.run st ms $> Right () - | otherwise -> case confirmMigrations of - MCYesUp -> run ms - MCYesUpDown -> run ms - MCConsole -> confirm err >> run ms - MCError -> pure $ Left err - where - err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums) - Right ms@(MTRDown dms) -> case confirmMigrations of - MCYesUpDown -> run ms - MCConsole -> confirm err >> run ms - MCYesUp -> pure $ Left err - MCError -> pure $ Left err - where - err = MEDowngrade $ map downName dms - where - confirm err = confirmOrExit $ migrationErrorDescription err - run ms = do - let f = dbFilePath st - copyFile f (f <> ".bak") - Migrations.run st ms - pure $ Right () - -confirmOrExit :: String -> IO () -confirmOrExit s = do - putStrLn s - putStr "Continue (y/N): " - hFlush stdout - ok <- getLine - when (map toLower ok /= "y") exitFailure - -connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> IO SQLiteStore +connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> IO DBStore connectSQLiteStore dbFilePath key keepKey = do dbNew <- not <$> doesFileExist dbFilePath dbConn <- dbBusyLoop (connectDB dbFilePath key) @@ -411,7 +80,7 @@ connectSQLiteStore dbFilePath key keepKey = do dbKey <- newTVarIO $! storeKey key keepKey dbClosed <- newTVarIO False dbSem <- newTVarIO 0 - pure SQLiteStore {dbFilePath, dbKey, dbSem, dbConnection, dbNew, dbClosed} + pure DBStore {dbFilePath, dbKey, dbSem, dbConnection, dbNew, dbClosed} connectDB :: FilePath -> ScrubbedBytes -> IO DB.Connection connectDB path key = do @@ -432,19 +101,19 @@ connectDB path key = do PRAGMA auto_vacuum = FULL; |] -closeSQLiteStore :: SQLiteStore -> IO () -closeSQLiteStore st@SQLiteStore {dbClosed} = - ifM (readTVarIO dbClosed) (putStrLn "closeSQLiteStore: already closed") $ +closeDBStore :: DBStore -> IO () +closeDBStore st@DBStore {dbClosed} = + ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ withConnection st $ \conn -> do DB.close conn atomically $ writeTVar dbClosed True -openSQLiteStore :: SQLiteStore -> ScrubbedBytes -> Bool -> IO () -openSQLiteStore st@SQLiteStore {dbClosed} key keepKey = +openSQLiteStore :: DBStore -> ScrubbedBytes -> Bool -> IO () +openSQLiteStore st@DBStore {dbClosed} key keepKey = ifM (readTVarIO dbClosed) (openSQLiteStore_ st key keepKey) (putStrLn "openSQLiteStore: already opened") -openSQLiteStore_ :: SQLiteStore -> ScrubbedBytes -> Bool -> IO () -openSQLiteStore_ SQLiteStore {dbConnection, dbFilePath, dbKey, dbClosed} key keepKey = +openSQLiteStore_ :: DBStore -> ScrubbedBytes -> Bool -> IO () +openSQLiteStore_ DBStore {dbConnection, dbFilePath, dbKey, dbClosed} key keepKey = bracketOnError (takeMVar dbConnection) (tryPutMVar dbConnection) @@ -455,8 +124,8 @@ openSQLiteStore_ SQLiteStore {dbConnection, dbFilePath, dbKey, dbClosed} key kee writeTVar dbKey $! storeKey key keepKey putMVar dbConnection DB.Connection {conn, slow} -reopenSQLiteStore :: SQLiteStore -> IO () -reopenSQLiteStore st@SQLiteStore {dbKey, dbClosed} = +reopenSQLiteStore :: DBStore -> IO () +reopenSQLiteStore st@DBStore {dbKey, dbClosed} = ifM (readTVarIO dbClosed) open (putStrLn "reopenSQLiteStore: already opened") where open = @@ -496,2696 +165,3 @@ addSQLResultRow rs _count names values = modifyIORef' rs $ \case rs' -> showValues values : rs' where showValues = T.intercalate "|" . map (fromMaybe "") - -checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a) -checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err) - -handleSQLError :: StoreError -> SQLError -> StoreError -handleSQLError err e - | SQL.sqlError e == SQL.ErrorConstraint = err - | otherwise = SEInternal $ bshow e - -createUserRecord :: DB.Connection -> IO UserId -createUserRecord db = do - DB.execute_ db "INSERT INTO users DEFAULT VALUES" - insertedRowId db - -checkUser :: DB.Connection -> UserId -> IO (Either StoreError ()) -checkUser db userId = - firstRow (\(_ :: Only Int64) -> ()) SEUserNotFound $ - DB.query db "SELECT user_id FROM users WHERE user_id = ? AND deleted = ?" (userId, False) - -deleteUserRecord :: DB.Connection -> UserId -> IO (Either StoreError ()) -deleteUserRecord db userId = runExceptT $ do - ExceptT $ checkUser db userId - liftIO $ DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) - -setUserDeleted :: DB.Connection -> UserId -> IO (Either StoreError [ConnId]) -setUserDeleted db userId = runExceptT $ do - ExceptT $ checkUser db userId - liftIO $ do - DB.execute db "UPDATE users SET deleted = ? WHERE user_id = ?" (True, userId) - map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE user_id = ?" (Only userId) - -deleteUserWithoutConns :: DB.Connection -> UserId -> IO Bool -deleteUserWithoutConns db userId = do - userId_ :: Maybe Int64 <- - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT user_id FROM users u - WHERE u.user_id = ? - AND u.deleted = ? - AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) - |] - (userId, True) - case userId_ of - Just _ -> DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) $> True - _ -> pure False - -deleteUsersWithoutConns :: DB.Connection -> IO [Int64] -deleteUsersWithoutConns db = do - userIds <- - map fromOnly - <$> DB.query - db - [sql| - SELECT user_id FROM users u - WHERE u.deleted = ? - AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) - |] - (Only True) - forM_ userIds $ DB.execute db "DELETE FROM users WHERE user_id = ?" . Only - pure userIds - -createConn_ :: - TVar ChaChaDRG -> - ConnData -> - (ConnId -> IO a) -> - IO (Either StoreError (ConnId, a)) -createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of - ConnData {connId = ""} -> createWithRandomId' gVar create - ConnData {connId} -> Right . (connId,) <$> create connId - -createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId) -createNewConn db gVar cData cMode = do - fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode) - -updateNewConnRcv :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue) -updateNewConnRcv db connId rq = - getConn db connId $>>= \case - (SomeConn _ NewConnection {}) -> updateConn - (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries - (SomeConn c _) -> pure . Left . SEBadConnType $ connType c - where - updateConn :: IO (Either StoreError RcvQueue) - updateConn = Right <$> addConnRcvQueue_ db connId rq - -updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue) -updateNewConnSnd db connId sq = - getConn db connId $>>= \case - (SomeConn _ NewConnection {}) -> updateConn - (SomeConn _ SndConnection {}) -> updateConn -- to allow retries - (SomeConn c _) -> pure . Left . SEBadConnType $ connType c - where - updateConn :: IO (Either StoreError SndQueue) - updateConn = Right <$> addConnSndQueue_ db connId sq - -createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewSndQueue -> IO (Either StoreError (ConnId, SndQueue)) -createSndConn db gVar cData q@SndQueue {server} = - -- check confirmed snd queue doesn't already exist, to prevent it being deleted by REPLACE in insertSndQueue_ - ifM (liftIO $ checkConfirmedSndQueueExists_ db q) (pure $ Left SESndQueueExists) $ - createConn_ gVar cData $ \connId -> do - serverKeyHash_ <- createServer_ db server - createConnRecord db connId cData SCMInvitation - insertSndQueue_ db connId q serverKeyHash_ - -createConnRecord :: DB.Connection -> ConnId -> ConnData -> SConnectionMode c -> IO () -createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport} cMode = - DB.execute - db - [sql| - INSERT INTO connections - (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake) VALUES (?,?,?,?,?,?,?) - |] - (userId, connId, cMode, connAgentVersion, enableNtfs, pqSupport, True) - -checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool -checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do - fromMaybe False - <$> maybeFirstRow - fromOnly - ( DB.query - db - "SELECT 1 FROM snd_queues WHERE host = ? AND port = ? AND snd_id = ? AND status != ? LIMIT 1" - (host server, port server, sndId, New) - ) - -getRcvConn :: DB.Connection -> SMPServer -> SMP.RecipientId -> IO (Either StoreError (RcvQueue, SomeConn)) -getRcvConn db ProtocolServer {host, port} rcvId = runExceptT $ do - rq@RcvQueue {connId} <- - ExceptT . firstRow toRcvQueue SEConnNotFound $ - DB.query db (rcvQueueQuery <> " WHERE q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (host, port, rcvId) - (rq,) <$> ExceptT (getConn db connId) - --- | Deletes connection, optionally checking for pending snd message deliveries; returns connection id if it was deleted -deleteConn :: DB.Connection -> Maybe NominalDiffTime -> ConnId -> IO (Maybe ConnId) -deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of - Nothing -> delete - Just timeout -> - ifM - checkNoPendingDeliveries_ - delete - ( ifM - (checkWaitDeliveryTimeout_ timeout) - delete - (pure Nothing) - ) - where - delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId - checkNoPendingDeliveries_ = do - r :: (Maybe Int64) <- - maybeFirstRow fromOnly $ - DB.query db "SELECT 1 FROM snd_message_deliveries WHERE conn_id = ? AND failed = 0 LIMIT 1" (Only connId) - pure $ isNothing r - checkWaitDeliveryTimeout_ timeout = do - cutoffTs <- addUTCTime (-timeout) <$> getCurrentTime - r :: (Maybe Int64) <- - maybeFirstRow fromOnly $ - DB.query db "SELECT 1 FROM connections WHERE conn_id = ? AND deleted_at_wait_delivery < ? LIMIT 1" (connId, cutoffTs) - pure $ isJust r - -upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue) -upgradeRcvConnToDuplex db connId sq = - getConn db connId $>>= \case - (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq - (SomeConn c _) -> pure . Left . SEBadConnType $ connType c - -upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue) -upgradeSndConnToDuplex db connId rq = - getConn db connId >>= \case - Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq - Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c - _ -> pure $ Left SEConnNotFound - -addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue) -addConnRcvQueue db connId rq = - getConn db connId >>= \case - Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq - Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c - _ -> pure $ Left SEConnNotFound - -addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue -addConnRcvQueue_ db connId rq@RcvQueue {server} = do - serverKeyHash_ <- createServer_ db server - insertRcvQueue_ db connId rq serverKeyHash_ - -addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreError SndQueue) -addConnSndQueue db connId sq = - getConn db connId >>= \case - Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq - Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c - _ -> pure $ Left SEConnNotFound - -addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue -addConnSndQueue_ db connId sq@SndQueue {server} = do - serverKeyHash_ <- createServer_ db server - insertSndQueue_ db connId sq serverKeyHash_ - -setRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO () -setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} status = - -- ? return error if queue does not exist? - DB.executeNamed - db - [sql| - UPDATE rcv_queues - SET status = :status - WHERE host = :host AND port = :port AND rcv_id = :rcv_id; - |] - [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId] - -setRcvSwitchStatus :: DB.Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue -setRcvSwitchStatus db rq@RcvQueue {rcvId, server = ProtocolServer {host, port}} rcvSwchStatus = do - DB.execute - db - [sql| - UPDATE rcv_queues - SET switch_status = ? - WHERE host = ? AND port = ? AND rcv_id = ? - |] - (rcvSwchStatus, host, port, rcvId) - pure rq {rcvSwchStatus} - -setRcvQueueDeleted :: DB.Connection -> RcvQueue -> IO () -setRcvQueueDeleted db RcvQueue {rcvId, server = ProtocolServer {host, port}} = do - DB.execute - db - [sql| - UPDATE rcv_queues - SET deleted = 1 - WHERE host = ? AND port = ? AND rcv_id = ? - |] - (host, port, rcvId) - -setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> VersionSMPC -> IO () -setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion = - DB.executeNamed - db - [sql| - UPDATE rcv_queues - SET e2e_dh_secret = :e2e_dh_secret, - status = :status, - smp_client_version = :smp_client_version - WHERE host = :host AND port = :port AND rcv_id = :rcv_id - |] - [ ":status" := Confirmed, - ":e2e_dh_secret" := e2eDhSecret, - ":smp_client_version" := smpClientVersion, - ":host" := host, - ":port" := port, - ":rcv_id" := rcvId - ] - -setSndQueueStatus :: DB.Connection -> SndQueue -> QueueStatus -> IO () -setSndQueueStatus db SndQueue {sndId, server = ProtocolServer {host, port}} status = - -- ? return error if queue does not exist? - DB.executeNamed - db - [sql| - UPDATE snd_queues - SET status = :status - WHERE host = :host AND port = :port AND snd_id = :snd_id; - |] - [":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId] - -setSndSwitchStatus :: DB.Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue -setSndSwitchStatus db sq@SndQueue {sndId, server = ProtocolServer {host, port}} sndSwchStatus = do - DB.execute - db - [sql| - UPDATE snd_queues - SET switch_status = ? - WHERE host = ? AND port = ? AND snd_id = ? - |] - (sndSwchStatus, host, port, sndId) - pure sq {sndSwchStatus} - -setRcvQueuePrimary :: DB.Connection -> ConnId -> RcvQueue -> IO () -setRcvQueuePrimary db connId RcvQueue {dbQueueId} = do - DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (False, connId) - DB.execute - db - "UPDATE rcv_queues SET rcv_primary = ?, replace_rcv_queue_id = ? WHERE conn_id = ? AND rcv_queue_id = ?" - (True, Nothing :: Maybe Int64, connId, dbQueueId) - -setSndQueuePrimary :: DB.Connection -> ConnId -> SndQueue -> IO () -setSndQueuePrimary db connId SndQueue {dbQueueId} = do - DB.execute db "UPDATE snd_queues SET snd_primary = ? WHERE conn_id = ?" (False, connId) - DB.execute - db - "UPDATE snd_queues SET snd_primary = ?, replace_snd_queue_id = ? WHERE conn_id = ? AND snd_queue_id = ?" - (True, Nothing :: Maybe Int64, connId, dbQueueId) - -incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO () -incRcvDeleteErrors db RcvQueue {connId, dbQueueId} = - DB.execute db "UPDATE rcv_queues SET delete_errors = delete_errors + 1 WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) - -deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO () -deleteConnRcvQueue db RcvQueue {connId, dbQueueId} = - DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) - -deleteConnSndQueue :: DB.Connection -> ConnId -> SndQueue -> IO () -deleteConnSndQueue db connId SndQueue {dbQueueId} = do - DB.execute db "DELETE FROM snd_queues WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId) - DB.execute db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId) - -getPrimaryRcvQueue :: DB.Connection -> ConnId -> IO (Either StoreError RcvQueue) -getPrimaryRcvQueue db connId = - maybe (Left SEConnNotFound) (Right . L.head) <$> getRcvQueuesByConnId_ db connId - -getRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue) -getRcvQueue db connId (SMPServer host port _) rcvId = - firstRow toRcvQueue SEConnNotFound $ - DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (connId, host, port, rcvId) - -getDeletedRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue) -getDeletedRcvQueue db connId (SMPServer host port _) rcvId = - firstRow toRcvQueue SEConnNotFound $ - DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 1") (connId, host, port, rcvId) - -setRcvQueueNtfCreds :: DB.Connection -> ConnId -> Maybe ClientNtfCreds -> IO () -setRcvQueueNtfCreds db connId clientNtfCreds = - DB.execute - db - [sql| - UPDATE rcv_queues - SET ntf_public_key = ?, ntf_private_key = ?, ntf_id = ?, rcv_ntf_dh_secret = ? - WHERE conn_id = ? - |] - (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_, connId) - where - (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) = case clientNtfCreds of - Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) - Nothing -> (Nothing, Nothing, Nothing, Nothing) - -type SMPConfirmationRow = (Maybe SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) - -smpConfirmation :: SMPConfirmationRow -> SMPConfirmation -smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) = - SMPConfirmation - { senderKey, - e2ePubKey, - connInfo, - smpReplyQueues = fromMaybe [] smpReplyQueues_, - smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ - } - -createConfirmation :: DB.Connection -> TVar ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId) -createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues, smpClientVersion}, ratchetState} = - createWithRandomId gVar $ \confirmationId -> - DB.execute - db - [sql| - INSERT INTO conn_confirmations - (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, smp_client_version, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, ?, 0); - |] - (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues, smpClientVersion) - -acceptConfirmation :: DB.Connection -> ConfirmationId -> ConnInfo -> IO (Either StoreError AcceptedConfirmation) -acceptConfirmation db confirmationId ownConnInfo = do - DB.executeNamed - db - [sql| - UPDATE conn_confirmations - SET accepted = 1, - own_conn_info = :own_conn_info - WHERE confirmation_id = :confirmation_id; - |] - [ ":own_conn_info" := ownConnInfo, - ":confirmation_id" := confirmationId - ] - firstRow confirmation SEConfirmationNotFound $ - DB.query - db - [sql| - SELECT conn_id, ratchet_state, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version - FROM conn_confirmations - WHERE confirmation_id = ?; - |] - (Only confirmationId) - where - confirmation ((connId, ratchetState) :. confRow) = - AcceptedConfirmation - { confirmationId, - connId, - senderConf = smpConfirmation confRow, - ratchetState, - ownConnInfo - } - -getAcceptedConfirmation :: DB.Connection -> ConnId -> IO (Either StoreError AcceptedConfirmation) -getAcceptedConfirmation db connId = - firstRow confirmation SEConfirmationNotFound $ - DB.query - db - [sql| - SELECT confirmation_id, ratchet_state, own_conn_info, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version - FROM conn_confirmations - WHERE conn_id = ? AND accepted = 1; - |] - (Only connId) - where - confirmation ((confirmationId, ratchetState, ownConnInfo) :. confRow) = - AcceptedConfirmation - { confirmationId, - connId, - senderConf = smpConfirmation confRow, - ratchetState, - ownConnInfo - } - -removeConfirmations :: DB.Connection -> ConnId -> IO () -removeConfirmations db connId = - DB.executeNamed - db - [sql| - DELETE FROM conn_confirmations - WHERE conn_id = :conn_id; - |] - [":conn_id" := connId] - -createInvitation :: DB.Connection -> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId) -createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo} = - createWithRandomId gVar $ \invitationId -> - DB.execute - db - [sql| - INSERT INTO conn_invitations - (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0); - |] - (invitationId, contactConnId, connReq, recipientConnInfo) - -getInvitation :: DB.Connection -> String -> InvitationId -> IO (Either StoreError Invitation) -getInvitation db cxt invitationId = - firstRow invitation (SEInvitationNotFound cxt invitationId) $ - DB.query - db - [sql| - SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted - FROM conn_invitations - WHERE invitation_id = ? - AND accepted = 0 - |] - (Only invitationId) - where - invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted) = - Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted} - -acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO () -acceptInvitation db invitationId ownConnInfo = - DB.executeNamed - db - [sql| - UPDATE conn_invitations - SET accepted = 1, - own_conn_info = :own_conn_info - WHERE invitation_id = :invitation_id - |] - [ ":own_conn_info" := ownConnInfo, - ":invitation_id" := invitationId - ] - -unacceptInvitation :: DB.Connection -> InvitationId -> IO () -unacceptInvitation db invitationId = - DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only invitationId) - -deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ()) -deleteInvitation db contactConnId invId = - getConn db contactConnId $>>= \case - SomeConn SCContact _ -> - Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, invId) - _ -> pure $ Left SEConnNotFound - -updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) -updateRcvIds db connId = do - (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId - let internalId = InternalId $ unId lastInternalId + 1 - internalRcvId = InternalRcvId $ unRcvId lastInternalRcvId + 1 - updateLastIdsRcv_ db connId internalId internalRcvId - pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash) - -createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () -createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId, broker = (_, brokerTs)}, internalRcvId, internalHash} = do - insertRcvMsgBase_ db connId rcvMsgData - insertRcvMsgDetails_ db connId rq rcvMsgData - updateRcvMsgHash db connId sndMsgId internalRcvId internalHash - DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId) - -updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) -updateSndIds db connId = runExceptT $ do - (lastInternalId, lastInternalSndId, prevSndHash) <- ExceptT $ retrieveLastIdsAndHashSnd_ db connId - let internalId = InternalId $ unId lastInternalId + 1 - internalSndId = InternalSndId $ unSndId lastInternalSndId + 1 - liftIO $ updateLastIdsSnd_ db connId internalId internalSndId - pure (internalId, internalSndId, prevSndHash) - -createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO () -createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do - insertSndMsgBase_ db connId sndMsgData - insertSndMsgDetails_ db connId sndMsgData - updateSndMsgHash db connId internalSndId internalHash - -createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO () -createSndMsgDelivery db connId SndQueue {dbQueueId} msgId = - DB.execute db "INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id) VALUES (?, ?, ?)" (connId, dbQueueId, msgId) - -getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg) -getSndMsgViaRcpt db connId sndMsgId = - firstRow toSndMsg SEMsgNotFound $ - DB.query - db - [sql| - SELECT s.internal_id, m.msg_type, s.internal_hash, s.rcpt_internal_id, s.rcpt_status - FROM snd_messages s - JOIN messages m ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id - WHERE s.conn_id = ? AND s.internal_snd_id = ? - |] - (connId, sndMsgId) - where - toSndMsg :: (InternalId, AgentMessageType, MsgHash, Maybe AgentMsgId, Maybe MsgReceiptStatus) -> SndMsg - toSndMsg (internalId, msgType, internalHash, rcptInternalId_, rcptStatus_) = - let msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_ - in SndMsg {internalId, internalSndId = sndMsgId, msgType, internalHash, msgReceipt} - -updateSndMsgRcpt :: DB.Connection -> ConnId -> InternalSndId -> MsgReceipt -> IO () -updateSndMsgRcpt db connId sndMsgId MsgReceipt {agentMsgId, msgRcptStatus} = - DB.execute - db - "UPDATE snd_messages SET rcpt_internal_id = ?, rcpt_status = ? WHERE conn_id = ? AND internal_snd_id = ?" - (agentMsgId, msgRcptStatus, connId, sndMsgId) - -getConnectionsForDelivery :: DB.Connection -> IO [ConnId] -getConnectionsForDelivery db = - map fromOnly <$> DB.query_ db "SELECT DISTINCT conn_id FROM snd_message_deliveries WHERE failed = 0" - -getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData))) -getPendingQueueMsg db connId SndQueue {dbQueueId} = - getWorkItem "message" getMsgId getMsgData markMsgFailed - where - getMsgId :: IO (Maybe InternalId) - getMsgId = - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT internal_id - FROM snd_message_deliveries d - WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0 - ORDER BY internal_id ASC - LIMIT 1 - |] - (connId, dbQueueId) - getMsgData :: InternalId -> IO (Either StoreError (Maybe RcvQueue, PendingMsgData)) - getMsgData msgId = runExceptT $ do - msg <- ExceptT $ firstRow pendingMsgData err getMsgData_ - rq_ <- liftIO $ L.head <$$> getRcvQueuesByConnId_ db connId - pure (rq_, msg) - where - getMsgData_ = - DB.query - db - [sql| - SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast - FROM messages m - JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id - WHERE m.conn_id = ? AND m.internal_id = ? - |] - (connId, msgId) - err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []" - pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData - pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_) = - let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_ - msgRetryState = RI2State <$> riSlow_ <*> riFast_ - in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs} - markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId) - -getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a)) -getWorkItem itemName getId getItem markFailed = - runExceptT $ handleWrkErr itemName "getId" getId >>= mapM (tryGetItem itemName getItem markFailed) - -getWorkItems :: Show i => ByteString -> IO [i] -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError [Either StoreError a]) -getWorkItems itemName getIds getItem markFailed = - runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed) - -tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a -tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e - where - mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId - -catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a -catchStoreError = catchAllErrors (SEInternal . bshow) - --- Errors caught by this function will suspend worker as if there is no more work, -handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a -handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action - where - mkError :: E.SomeException -> StoreError - mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e - -updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO () -updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} = - DB.execute db "UPDATE snd_messages SET retry_int_slow = ?, retry_int_fast = ? WHERE conn_id = ? AND internal_id = ?" (slowInterval, fastInterval, connId, msgId) - -deletePendingMsgs :: DB.Connection -> ConnId -> SndQueue -> IO () -deletePendingMsgs db connId SndQueue {dbQueueId} = - DB.execute db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ?" (connId, dbQueueId) - -getExpiredSndMessages :: DB.Connection -> ConnId -> SndQueue -> UTCTime -> IO [InternalId] -getExpiredSndMessages db connId SndQueue {dbQueueId} expireTs = do - -- type is Maybe InternalId because MAX always returns one row, possibly with NULL value - maxId :: [Maybe InternalId] <- - map fromOnly - <$> DB.query - db - [sql| - SELECT MAX(internal_id) - FROM messages - WHERE conn_id = ? AND internal_snd_id IS NOT NULL AND internal_ts < ? - |] - (connId, expireTs) - case maxId of - Just msgId : _ -> - map fromOnly - <$> DB.query - db - [sql| - SELECT internal_id - FROM snd_message_deliveries - WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0 AND internal_id <= ? - ORDER BY internal_id ASC - |] - (connId, dbQueueId, msgId) - _ -> pure [] - -setMsgUserAck :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError (RcvQueue, SMP.MsgId)) -setMsgUserAck db connId agentMsgId = runExceptT $ do - (dbRcvId, srvMsgId) <- - ExceptT . firstRow id SEMsgNotFound $ - DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId) - rq <- ExceptT $ getRcvQueueById db connId dbRcvId - liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId) - pure (rq, srvMsgId) - -getRcvMsg :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg) -getRcvMsg db connId agentMsgId = - firstRow toRcvMsg SEMsgNotFound $ - DB.query - db - [sql| - SELECT - r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash, - m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack - FROM rcv_messages r - JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id - LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id - WHERE r.conn_id = ? AND r.internal_id = ? - |] - (connId, agentMsgId) - -getLastMsg :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Maybe RcvMsg) -getLastMsg db connId msgId = - maybeFirstRow toRcvMsg $ - DB.query - db - [sql| - SELECT - r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash, - m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack - FROM rcv_messages r - JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id - JOIN connections c ON r.conn_id = c.conn_id AND c.last_internal_msg_id = r.internal_id - LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id - WHERE r.conn_id = ? AND r.broker_id = ? - |] - (connId, msgId) - -toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg -toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, userAck)) = - let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity, pqEncryption} - msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_ - in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck} - -checkRcvMsgHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool -checkRcvMsgHashExists db connId hash = do - fromMaybe False - <$> maybeFirstRow - fromOnly - ( DB.query - db - "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1" - (connId, hash) - ) - -getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs) -getRcvMsgBrokerTs db connId msgId = - firstRow fromOnly SEMsgNotFound $ - DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId) - -deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO () -deleteMsg db connId msgId = - DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId) - -deleteMsgContent :: DB.Connection -> ConnId -> InternalId -> IO () -deleteMsgContent db connId msgId = - DB.execute db "UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?;" (connId, msgId) - -deleteDeliveredSndMsg :: DB.Connection -> ConnId -> InternalId -> IO () -deleteDeliveredSndMsg db connId msgId = do - cnt <- countPendingSndDeliveries_ db connId msgId - when (cnt == 0) $ deleteMsg db connId msgId - -deleteSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> Bool -> IO () -deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do - DB.execute - db - "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? AND internal_id = ?" - (connId, dbQueueId, msgId) - cnt <- countPendingSndDeliveries_ db connId msgId - when (cnt == 0) $ do - del <- - maybeFirstRow id (DB.query db "SELECT rcpt_internal_id, rcpt_status FROM snd_messages WHERE conn_id = ? AND internal_id = ?" (connId, msgId)) >>= \case - Just (Just (_ :: Int64), Just MROk) -> pure deleteMsg - _ -> pure $ if keepForReceipt then deleteMsgContent else deleteMsg - del db connId msgId - -countPendingSndDeliveries_ :: DB.Connection -> ConnId -> InternalId -> IO Int -countPendingSndDeliveries_ db connId msgId = do - (Only cnt : _) <- DB.query db "SELECT count(*) FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ? AND failed = 0" (connId, msgId) - pure cnt - -deleteRcvMsgHashesExpired :: DB.Connection -> NominalDiffTime -> IO () -deleteRcvMsgHashesExpired db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - DB.execute db "DELETE FROM encrypted_rcv_message_hashes WHERE created_at < ?" (Only cutoffTs) - -deleteSndMsgsExpired :: DB.Connection -> NominalDiffTime -> IO () -deleteSndMsgsExpired db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - DB.execute - db - "DELETE FROM messages WHERE internal_ts < ? AND internal_snd_id IS NOT NULL" - (Only cutoffTs) - -createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO () -createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = - DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem) VALUES (?, ?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2, pqPrivKem) - -getRatchetX3dhKeys :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams)) -getRatchetX3dhKeys db connId = - firstRow' keys SEX3dhKeysNotFound $ - DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem FROM ratchets WHERE conn_id = ?" (Only connId) - where - keys = \case - (Just k1, Just k2, pKem) -> Right (k1, k2, pKem) - _ -> Left SEX3dhKeysNotFound - --- used to remember new keys when starting ratchet re-synchronization --- TODO remove the columns for public keys in v5.7. --- Currently, the keys are not used but still stored to support app downgrade to the previous version. -setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO () -setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = - DB.execute - db - [sql| - UPDATE ratchets - SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? - WHERE conn_id = ? - |] - (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId) - --- TODO remove the columns for public keys in v5.7. -createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO () -createRatchet db connId rc = - DB.executeNamed - db - [sql| - INSERT INTO ratchets (conn_id, ratchet_state) - VALUES (:conn_id, :ratchet_state) - ON CONFLICT (conn_id) DO UPDATE SET - ratchet_state = :ratchet_state, - x3dh_priv_key_1 = NULL, - x3dh_priv_key_2 = NULL, - x3dh_pub_key_1 = NULL, - x3dh_pub_key_2 = NULL, - pq_priv_kem = NULL - |] - [":conn_id" := connId, ":ratchet_state" := rc] - -deleteRatchet :: DB.Connection -> ConnId -> IO () -deleteRatchet db connId = - DB.execute db "DELETE FROM ratchets WHERE conn_id = ?" (Only connId) - -getRatchet :: DB.Connection -> ConnId -> IO (Either StoreError RatchetX448) -getRatchet db connId = - firstRow' ratchet SERatchetNotFound $ DB.query db "SELECT ratchet_state FROM ratchets WHERE conn_id = ?" (Only connId) - where - ratchet = maybe (Left SERatchetNotFound) Right . fromOnly - -getSkippedMsgKeys :: DB.Connection -> ConnId -> IO SkippedMsgKeys -getSkippedMsgKeys db connId = - skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId) - where - skipped = foldl' addSkippedKey M.empty - addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks - where - addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk) - -updateRatchet :: DB.Connection -> ConnId -> RatchetX448 -> SkippedMsgDiff -> IO () -updateRatchet db connId rc skipped = do - DB.execute db "UPDATE ratchets SET ratchet_state = ? WHERE conn_id = ?" (rc, connId) - case skipped of - SMDNoChange -> pure () - SMDRemove hk msgN -> - DB.execute db "DELETE FROM skipped_messages WHERE conn_id = ? AND header_key = ? AND msg_n = ?" (connId, hk, msgN) - SMDAdd smks -> - forM_ (M.assocs smks) $ \(hk, mks) -> - forM_ (M.assocs mks) $ \(msgN, mk) -> - DB.execute db "INSERT INTO skipped_messages (conn_id, header_key, msg_n, msg_key) VALUES (?, ?, ?, ?)" (connId, hk, msgN, mk) - -createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> IO (Either StoreError ()) -createCommand db corrId connId srv_ cmd = runExceptT $ do - (host_, port_, serverKeyHash_) <- serverFields - createdAt <- liftIO getCurrentTime - liftIO . E.handle handleErr $ - DB.execute - db - "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash, created_at) VALUES (?,?,?,?,?,?,?,?)" - (host_, port_, corrId, connId, cmdTag, cmd, serverKeyHash_, createdAt) - where - cmdTag = agentCommandTag cmd - handleErr e - | SQL.sqlError e == SQL.ErrorConstraint = logError $ "tried to create command " <> tshow cmdTag <> " for deleted connection" - | otherwise = E.throwIO e - serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash) - serverFields = case srv_ of - Just srv@(SMPServer host port _) -> - (Just host,Just port,) <$> ExceptT (getServerKeyHash_ db srv) - Nothing -> pure (Nothing, Nothing, Nothing) - -insertedRowId :: DB.Connection -> IO Int64 -insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" - -getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer] -getPendingCommandServers db connId = do - -- TODO review whether this can break if, e.g., the server has another key hash. - map smpServer - <$> DB.query - db - [sql| - SELECT DISTINCT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash) - FROM commands c - LEFT JOIN servers s ON s.host = c.host AND s.port = c.port - WHERE conn_id = ? - |] - (Only connId) - where - smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash - -getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand)) -getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed - where - getCmdId :: IO (Maybe Int64) - getCmdId = - maybeFirstRow fromOnly $ case srv_ of - Nothing -> - DB.query - db - [sql| - SELECT command_id FROM commands - WHERE conn_id = ? AND host IS NULL AND port IS NULL AND failed = 0 - ORDER BY created_at ASC, command_id ASC - LIMIT 1 - |] - (Only connId) - Just (SMPServer host port _) -> - DB.query - db - [sql| - SELECT command_id FROM commands - WHERE conn_id = ? AND host = ? AND port = ? AND failed = 0 - ORDER BY created_at ASC, command_id ASC - LIMIT 1 - |] - (connId, host, port) - getCommand :: Int64 -> IO (Either StoreError PendingCommand) - getCommand cmdId = - firstRow pendingCommand err $ - DB.query - db - [sql| - SELECT c.corr_id, cs.user_id, c.command - FROM commands c - JOIN connections cs USING (conn_id) - WHERE c.command_id = ? - |] - (Only cmdId) - where - err = SEInternal $ "command " <> bshow cmdId <> " returned []" - pendingCommand (corrId, userId, command) = PendingCommand {cmdId, corrId, userId, connId, command} - markCommandFailed cmdId = DB.execute db "UPDATE commands SET failed = 1 WHERE command_id = ?" (Only cmdId) - -updateCommandServer :: DB.Connection -> AsyncCmdId -> SMPServer -> IO (Either StoreError ()) -updateCommandServer db cmdId srv@(SMPServer host port _) = runExceptT $ do - serverKeyHash_ <- ExceptT $ getServerKeyHash_ db srv - liftIO $ - DB.execute - db - [sql| - UPDATE commands - SET host = ?, port = ?, server_key_hash = ? - WHERE command_id = ? - |] - (host, port, serverKeyHash_, cmdId) - -deleteCommand :: DB.Connection -> AsyncCmdId -> IO () -deleteCommand db cmdId = - DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId) - -createNtfToken :: DB.Connection -> NtfToken -> IO () -createNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do - upsertNtfServer_ db srv - DB.execute - db - [sql| - INSERT INTO ntf_tokens - (provider, device_token, ntf_host, ntf_port, tkn_id, tkn_pub_key, tkn_priv_key, tkn_pub_dh_key, tkn_priv_dh_key, tkn_dh_secret, tkn_status, tkn_action, ntf_mode) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) - |] - ((provider, token, host, port, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode)) - -getSavedNtfToken :: DB.Connection -> IO (Maybe NtfToken) -getSavedNtfToken db = do - maybeFirstRow ntfToken $ - DB.query_ - db - [sql| - SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash, - t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, - t.tkn_status, t.tkn_action, t.ntf_mode - FROM ntf_tokens t - JOIN ntf_servers s USING (ntf_host, ntf_port) - |] - where - ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) = - let ntfServer = NtfServer host port keyHash - ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey) - ntfMode = fromMaybe NMPeriodic ntfMode_ - in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} - -updateNtfTokenRegistration :: DB.Connection -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> IO () -updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE ntf_tokens - SET tkn_id = ?, tkn_dh_secret = ?, tkn_status = ?, tkn_action = ?, updated_at = ? - WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? - |] - (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port) - -updateDeviceToken :: DB.Connection -> NtfToken -> DeviceToken -> IO () -updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} (DeviceToken toProvider toToken) = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE ntf_tokens - SET provider = ?, device_token = ?, tkn_status = ?, tkn_action = ?, updated_at = ? - WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? - |] - (toProvider, toToken, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port) - -updateNtfMode :: DB.Connection -> NtfToken -> NotificationsMode -> IO () -updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} ntfMode = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE ntf_tokens - SET ntf_mode = ?, updated_at = ? - WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? - |] - (ntfMode, updatedAt, provider, token, host, port) - -updateNtfToken :: DB.Connection -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO () -updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE ntf_tokens - SET tkn_status = ?, tkn_action = ?, updated_at = ? - WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? - |] - (tknStatus, tknAction, updatedAt, provider, token, host, port) - -removeNtfToken :: DB.Connection -> NtfToken -> IO () -removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} = - DB.execute - db - [sql| - DELETE FROM ntf_tokens - WHERE provider = ? AND device_token = ? AND ntf_host = ? AND ntf_port = ? - |] - (provider, token, host, port) - -addNtfTokenToDelete :: DB.Connection -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> IO () -addNtfTokenToDelete db ProtocolServer {host, port, keyHash} ntfPrivKey tknId = - DB.execute db "INSERT INTO ntf_tokens_to_delete (ntf_host, ntf_port, ntf_key_hash, tkn_id, tkn_priv_key) VALUES (?,?,?,?,?)" (host, port, keyHash, tknId, ntfPrivKey) - -deleteExpiredNtfTokensToDelete :: DB.Connection -> NominalDiffTime -> IO () -deleteExpiredNtfTokensToDelete db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE created_at < ?" (Only cutoffTs) - -type NtfTokenToDelete = (Int64, C.APrivateAuthKey, NtfTokenId) - -getNextNtfTokenToDelete :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe NtfTokenToDelete)) -getNextNtfTokenToDelete db (NtfServer ntfHost ntfPort _) = - getWorkItem "ntf tkn del" getNtfTknDbId getNtfTknToDelete (markNtfTokenToDeleteFailed_ db) - where - getNtfTknDbId :: IO (Maybe Int64) - getNtfTknDbId = - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT ntf_token_to_delete_id - FROM ntf_tokens_to_delete - WHERE ntf_host = ? AND ntf_port = ? - AND del_failed = 0 - ORDER BY created_at ASC - LIMIT 1 - |] - (ntfHost, ntfPort) - getNtfTknToDelete :: Int64 -> IO (Either StoreError NtfTokenToDelete) - getNtfTknToDelete tknDbId = - firstRow ntfTokenToDelete err $ - DB.query - db - [sql| - SELECT tkn_priv_key, tkn_id - FROM ntf_tokens_to_delete - WHERE ntf_token_to_delete_id = ? - |] - (Only tknDbId) - where - err = SEInternal $ "ntf token to delete " <> bshow tknDbId <> " returned []" - ntfTokenToDelete (tknPrivKey, tknId) = (tknDbId, tknPrivKey, tknId) - -markNtfTokenToDeleteFailed_ :: DB.Connection -> Int64 -> IO () -markNtfTokenToDeleteFailed_ db tknDbId = - DB.execute db "UPDATE ntf_tokens_to_delete SET del_failed = 1 where ntf_token_to_delete_id = ?" (Only tknDbId) - -getPendingDelTknServers :: DB.Connection -> IO [NtfServer] -getPendingDelTknServers db = - map toNtfServer - <$> DB.query_ - db - [sql| - SELECT DISTINCT ntf_host, ntf_port, ntf_key_hash - FROM ntf_tokens_to_delete - |] - where - toNtfServer (host, port, keyHash) = NtfServer host port keyHash - -deleteNtfTokenToDelete :: DB.Connection -> Int64 -> IO () -deleteNtfTokenToDelete db tknDbId = - DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE ntf_token_to_delete_id = ?" (Only tknDbId) - -type NtfSupervisorSub = (NtfSubscription, Maybe (NtfSubAction, NtfActionTs)) - -getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe NtfSupervisorSub) -getNtfSubscription db connId = - maybeFirstRow ntfSubscription $ - DB.query - db - [sql| - SELECT c.user_id, s.host, s.port, COALESCE(nsb.smp_server_key_hash, s.key_hash), ns.ntf_host, ns.ntf_port, ns.ntf_key_hash, - nsb.smp_ntf_id, nsb.ntf_sub_id, nsb.ntf_sub_status, nsb.ntf_sub_action, nsb.ntf_sub_smp_action, nsb.ntf_sub_action_ts - FROM ntf_subscriptions nsb - JOIN connections c USING (conn_id) - JOIN servers s ON s.host = nsb.smp_host AND s.port = nsb.smp_port - JOIN ntf_servers ns USING (ntf_host, ntf_port) - WHERE nsb.conn_id = ? - |] - (Only connId) - where - ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) = - let smpServer = SMPServer smpHost smpPort smpKeyHash - ntfServer = NtfServer ntfHost ntfPort ntfKeyHash - action = case (ntfAction_, smpAction_, actionTs_) of - (Just ntfAction, Nothing, Just actionTs) -> Just (NSANtf ntfAction, actionTs) - (Nothing, Just smpAction, Just actionTs) -> Just (NSASMP smpAction, actionTs) - _ -> Nothing - in (NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}, action) - -createNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO (Either StoreError ()) -createNtfSubscription db ntfSubscription action = runExceptT $ do - let NtfSubscription {connId, smpServer = smpServer@(SMPServer host port _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} = ntfSubscription - smpServerKeyHash_ <- ExceptT $ getServerKeyHash_ db smpServer - actionTs <- liftIO getCurrentTime - liftIO $ - DB.execute - db - [sql| - INSERT INTO ntf_subscriptions - (conn_id, smp_host, smp_port, smp_ntf_id, ntf_host, ntf_port, ntf_sub_id, - ntf_sub_status, ntf_sub_action, ntf_sub_smp_action, ntf_sub_action_ts, smp_server_key_hash) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (connId, host, port, ntfQueueId, ntfHost, ntfPort, ntfSubId) - :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, smpServerKeyHash_) - ) - where - (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action - -supervisorUpdateNtfSub :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO () -supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHost smpPort _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do - ts <- getCurrentTime - DB.execute - db - [sql| - UPDATE ntf_subscriptions - SET smp_host = ?, smp_port = ?, smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, - ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? - WHERE conn_id = ? - |] - ( (smpHost, smpPort, ntfQueueId, ntfHost, ntfPort, ntfSubId) - :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId) - ) - where - (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action - -supervisorUpdateNtfAction :: DB.Connection -> ConnId -> NtfSubAction -> IO () -supervisorUpdateNtfAction db connId action = do - ts <- getCurrentTime - DB.execute - db - [sql| - UPDATE ntf_subscriptions - SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? - WHERE conn_id = ? - |] - (ntfSubAction, ntfSubSMPAction, ts, True, ts, connId) - where - (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action - -updateNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> NtfActionTs -> IO () -updateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action actionTs = do - r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) - forM_ r $ \updatedBySupervisor -> do - updatedAt <- getCurrentTime - if updatedBySupervisor - then - DB.execute - db - [sql| - UPDATE ntf_subscriptions - SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, updated_by_supervisor = ?, updated_at = ? - WHERE conn_id = ? - |] - (ntfQueueId, ntfSubId, ntfSubStatus, False, updatedAt, connId) - else - DB.execute - db - [sql| - UPDATE ntf_subscriptions - SET smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? - WHERE conn_id = ? - |] - ((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, False, updatedAt, connId)) - where - (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action - -setNullNtfSubscriptionAction :: DB.Connection -> ConnId -> IO () -setNullNtfSubscriptionAction db connId = do - r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) - forM_ r $ \updatedBySupervisor -> - unless updatedBySupervisor $ do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE ntf_subscriptions - SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? - WHERE conn_id = ? - |] - (Nothing :: Maybe NtfSubNTFAction, Nothing :: Maybe NtfSubSMPAction, Nothing :: Maybe UTCTime, False, updatedAt, connId) - -deleteNtfSubscription :: DB.Connection -> ConnId -> IO () -deleteNtfSubscription db connId = do - r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) - forM_ r $ \updatedBySupervisor -> do - updatedAt <- getCurrentTime - if updatedBySupervisor - then - DB.execute - db - [sql| - UPDATE ntf_subscriptions - SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, updated_by_supervisor = ?, updated_at = ? - WHERE conn_id = ? - |] - (Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, False, updatedAt, connId) - else deleteNtfSubscription' db connId - -deleteNtfSubscription' :: DB.Connection -> ConnId -> IO () -deleteNtfSubscription' db connId = do - DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) - -getNextNtfSubNTFActions :: DB.Connection -> NtfServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs)]) -getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _) ntfBatchSize = - getWorkItems "ntf NTF" getNtfConnIds getNtfSubAction (markNtfSubActionNtfFailed_ db) - where - getNtfConnIds :: IO [ConnId] - getNtfConnIds = - map fromOnly - <$> DB.query - db - [sql| - SELECT conn_id - FROM ntf_subscriptions - WHERE ntf_host = ? AND ntf_port = ? AND ntf_sub_action IS NOT NULL - AND (ntf_failed = 0 OR updated_by_supervisor = 1) - ORDER BY ntf_sub_action_ts ASC - LIMIT ? - |] - (ntfHost, ntfPort, ntfBatchSize) - getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs)) - getNtfSubAction connId = do - markUpdatedByWorker db connId - firstRow ntfSubAction err $ - DB.query - db - [sql| - SELECT c.user_id, s.host, s.port, COALESCE(ns.smp_server_key_hash, s.key_hash), - ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_action - FROM ntf_subscriptions ns - JOIN connections c USING (conn_id) - JOIN servers s ON s.host = ns.smp_host AND s.port = ns.smp_port - WHERE ns.conn_id = ? - |] - (Only connId) - where - err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []" - ntfSubAction (userId, smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) = - let smpServer = SMPServer smpHost smpPort smpKeyHash - ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus} - in (action, ntfSubscription, actionTs) - -markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO () -markNtfSubActionNtfFailed_ db connId = - DB.execute db "UPDATE ntf_subscriptions SET ntf_failed = 1 where conn_id = ?" (Only connId) - -getNextNtfSubSMPActions :: DB.Connection -> SMPServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubSMPAction, NtfSubscription)]) -getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize = - getWorkItems "ntf SMP" getNtfConnIds getNtfSubAction (markNtfSubActionSMPFailed_ db) - where - getNtfConnIds :: IO [ConnId] - getNtfConnIds = - map fromOnly - <$> DB.query - db - [sql| - SELECT conn_id - FROM ntf_subscriptions ns - WHERE smp_host = ? AND smp_port = ? AND ntf_sub_smp_action IS NOT NULL AND ntf_sub_action_ts IS NOT NULL - AND (smp_failed = 0 OR updated_by_supervisor = 1) - ORDER BY ntf_sub_action_ts ASC - LIMIT ? - |] - (smpHost, smpPort, ntfBatchSize) - getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubSMPAction, NtfSubscription)) - getNtfSubAction connId = do - markUpdatedByWorker db connId - firstRow ntfSubAction err $ - DB.query - db - [sql| - SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash, - ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_smp_action - FROM ntf_subscriptions ns - JOIN connections c USING (conn_id) - JOIN ntf_servers s USING (ntf_host, ntf_port) - WHERE ns.conn_id = ? - |] - (Only connId) - where - err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []" - ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, action) = - let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash - ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus} - in (action, ntfSubscription) - -markNtfSubActionSMPFailed_ :: DB.Connection -> ConnId -> IO () -markNtfSubActionSMPFailed_ db connId = - DB.execute db "UPDATE ntf_subscriptions SET smp_failed = 1 where conn_id = ?" (Only connId) - -markUpdatedByWorker :: DB.Connection -> ConnId -> IO () -markUpdatedByWorker db connId = - DB.execute db "UPDATE ntf_subscriptions SET updated_by_supervisor = 0 WHERE conn_id = ?" (Only connId) - -getActiveNtfToken :: DB.Connection -> IO (Maybe NtfToken) -getActiveNtfToken db = - maybeFirstRow ntfToken $ - DB.query - db - [sql| - SELECT s.ntf_host, s.ntf_port, s.ntf_key_hash, - t.provider, t.device_token, t.tkn_id, t.tkn_pub_key, t.tkn_priv_key, t.tkn_pub_dh_key, t.tkn_priv_dh_key, t.tkn_dh_secret, - t.tkn_status, t.tkn_action, t.ntf_mode - FROM ntf_tokens t - JOIN ntf_servers s USING (ntf_host, ntf_port) - WHERE t.tkn_status = ? - |] - (Only NTActive) - where - ntfToken ((host, port, keyHash) :. (provider, dt, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhPubKey, ntfDhPrivKey, ntfDhSecret) :. (ntfTknStatus, ntfTknAction, ntfMode_)) = - let ntfServer = NtfServer host port keyHash - ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey) - ntfMode = fromMaybe NMPeriodic ntfMode_ - in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} - -getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret, Maybe UTCTime)) -getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} = - firstRow' res SEConnNotFound $ - DB.query - db - [sql| - SELECT conn_id, rcv_ntf_dh_secret, last_broker_ts - FROM rcv_queues - WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0 - |] - (host, port, notifierId) - where - res (connId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, rcvNtfDhSecret, lastBrokerTs_) - res _ = Left SEConnNotFound - -setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO () -setConnectionNtfs db connId enableNtfs = - DB.execute db "UPDATE connections SET enable_ntfs = ? WHERE conn_id = ?" (enableNtfs, connId) - --- * Auxiliary helpers - -instance ToField QueueStatus where toField = toField . serializeQueueStatus - -instance FromField QueueStatus where fromField = fromTextField_ queueStatusT - -instance ToField (DBQueueId 'QSStored) where toField (DBQueueId qId) = toField qId - -instance FromField (DBQueueId 'QSStored) where fromField x = DBQueueId <$> fromField x - -instance ToField InternalRcvId where toField (InternalRcvId x) = toField x - -instance FromField InternalRcvId where fromField x = InternalRcvId <$> fromField x - -instance ToField InternalSndId where toField (InternalSndId x) = toField x - -instance FromField InternalSndId where fromField x = InternalSndId <$> fromField x - -instance ToField InternalId where toField (InternalId x) = toField x - -instance FromField InternalId where fromField x = InternalId <$> fromField x - -instance ToField AgentMessageType where toField = toField . smpEncode - -instance FromField AgentMessageType where fromField = blobFieldParser smpP - -instance ToField MsgIntegrity where toField = toField . strEncode - -instance FromField MsgIntegrity where fromField = blobFieldParser strP - -instance ToField SMPQueueUri where toField = toField . strEncode - -instance FromField SMPQueueUri where fromField = blobFieldParser strP - -instance ToField AConnectionRequestUri where toField = toField . strEncode - -instance FromField AConnectionRequestUri where fromField = blobFieldParser strP - -instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . strEncode - -instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldParser strP - -instance ToField ConnectionMode where toField = toField . decodeLatin1 . strEncode - -instance FromField ConnectionMode where fromField = fromTextField_ connModeT - -instance ToField (SConnectionMode c) where toField = toField . connMode - -instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT - -instance ToField MsgFlags where toField = toField . decodeLatin1 . smpEncode - -instance FromField MsgFlags where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 - -instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList - -instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP - -instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 . strEncode - -instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - -instance ToField AgentCommand where toField = toField . strEncode - -instance FromField AgentCommand where fromField = blobFieldParser strP - -instance ToField AgentCommandTag where toField = toField . strEncode - -instance FromField AgentCommandTag where fromField = blobFieldParser strP - -instance ToField MsgReceiptStatus where toField = toField . decodeLatin1 . strEncode - -instance FromField MsgReceiptStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - -instance ToField (Version v) where toField (Version v) = toField v - -instance FromField (Version v) where fromField f = Version <$> fromField f - -deriving newtype instance ToField EntityId - -deriving newtype instance FromField EntityId - -deriving newtype instance ToField ChunkReplicaId - -deriving newtype instance FromField ChunkReplicaId - -listToEither :: e -> [a] -> Either e a -listToEither _ (x : _) = Right x -listToEither e _ = Left e - -firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b) -firstRow f e a = second f . listToEither e <$> a - -maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b) -maybeFirstRow f q = fmap f . listToMaybe <$> q - -firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b) -firstRow' f e a = (f <=< listToEither e) <$> a - -{- ORMOLU_DISABLE -} --- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries -instance (FromField a, FromField b, FromField c, FromField d, FromField e, - FromField f, FromField g, FromField h, FromField i, FromField j, - FromField k) => - FromRow (a,b,c,d,e,f,g,h,i,j,k) where - fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field - <*> field <*> field <*> field <*> field <*> field - <*> field - -instance (FromField a, FromField b, FromField c, FromField d, FromField e, - FromField f, FromField g, FromField h, FromField i, FromField j, - FromField k, FromField l) => - FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where - fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field - <*> field <*> field <*> field <*> field <*> field - <*> field <*> field - -instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, - ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) => - ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where - toRow (a,b,c,d,e,f,g,h,i,j,k,l) = - [ toField a, toField b, toField c, toField d, toField e, toField f, - toField g, toField h, toField i, toField j, toField k, toField l - ] - -{- ORMOLU_ENABLE -} - --- * Server helper - --- | Creates a new server, if it doesn't exist, and returns the passed key hash if it is different from stored. -createServer_ :: DB.Connection -> SMPServer -> IO (Maybe C.KeyHash) -createServer_ db newSrv@ProtocolServer {host, port, keyHash} = - getServerKeyHash_ db newSrv >>= \case - Right keyHash_ -> pure keyHash_ - Left _ -> insertNewServer_ $> Nothing - where - insertNewServer_ = - DB.execute db "INSERT INTO servers (host, port, key_hash) VALUES (?,?,?)" (host, port, keyHash) - --- | Returns the passed server key hash if it is different from the stored one, or the error if the server does not exist. -getServerKeyHash_ :: DB.Connection -> SMPServer -> IO (Either StoreError (Maybe C.KeyHash)) -getServerKeyHash_ db ProtocolServer {host, port, keyHash} = do - firstRow useKeyHash SEServerNotFound $ - DB.query db "SELECT key_hash FROM servers WHERE host = ? AND port = ?" (host, port) - where - useKeyHash (Only keyHash') = if keyHash /= keyHash' then Just keyHash else Nothing - -upsertNtfServer_ :: DB.Connection -> NtfServer -> IO () -upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do - DB.executeNamed - db - [sql| - INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash) VALUES (:host,:port,:key_hash) - ON CONFLICT (ntf_host, ntf_port) DO UPDATE SET - ntf_host=excluded.ntf_host, - ntf_port=excluded.ntf_port, - ntf_key_hash=excluded.ntf_key_hash; - |] - [":host" := host, ":port" := port, ":key_hash" := keyHash] - --- * createRcvConn helpers - -insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue -insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do - -- to preserve ID if the queue already exists. - -- possibly, it can be done in one query. - currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) - qId <- maybe (newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ - DB.execute - db - [sql| - INSERT INTO rcv_queues - (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); - |] - ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, sndSecure, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) - pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} - --- * createSndConn helpers - -insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue -insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do - -- to preserve ID if the queue already exists. - -- possibly, it can be done in one query. - currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) - qId <- maybe (newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ - DB.execute - db - [sql| - INSERT OR REPLACE INTO snd_queues - (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); - |] - ((host server, port server, sndId, sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) - pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId} - -newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored -newQueueId_ [] = DBQueueId 1 -newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1) - --- * getConn helpers - -getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn) -getConn = getAnyConn False -{-# INLINE getConn #-} - -getDeletedConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn) -getDeletedConn = getAnyConn True -{-# INLINE getDeletedConn #-} - -getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn) -getAnyConn deleted' dbConn connId = - getConnData dbConn connId >>= \case - Nothing -> pure $ Left SEConnNotFound - Just (cData@ConnData {deleted}, cMode) - | deleted /= deleted' -> pure $ Left SEConnNotFound - | otherwise -> do - rQ <- getRcvQueuesByConnId_ dbConn connId - sQ <- getSndQueuesByConnId_ dbConn connId - pure $ case (rQ, sQ, cMode) of - (Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs) - (Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq) - (Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq) - (Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq) - (Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData) - _ -> Left SEConnNotFound - -getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn] -getConns = getAnyConns_ False -{-# INLINE getConns #-} - -getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn] -getDeletedConns = getAnyConns_ True -{-# INLINE getDeletedConns #-} - -getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn] -getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db - where - handleDBError :: E.SomeException -> IO (Either StoreError SomeConn) - handleDBError = pure . Left . SEInternal . bshow - -getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode)) -getConnData db connId' = - maybeFirstRow cData $ - DB.query - db - [sql| - SELECT - user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support - FROM connections - WHERE conn_id = ? - |] - (Only connId') - where - cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport) = - (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode) - -setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO () -setConnDeleted db waitDelivery connId - | waitDelivery = do - currentTs <- getCurrentTime - DB.execute db "UPDATE connections SET deleted_at_wait_delivery = ? WHERE conn_id = ?" (currentTs, connId) - | otherwise = - DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId) - -setConnUserId :: DB.Connection -> UserId -> ConnId -> UserId -> IO () -setConnUserId db oldUserId connId newUserId = - DB.execute db "UPDATE connections SET user_id = ? WHERE conn_id = ? and user_id = ?" (newUserId, connId, oldUserId) - -setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO () -setConnAgentVersion db connId aVersion = - DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId) - -setConnPQSupport :: DB.Connection -> ConnId -> PQSupport -> IO () -setConnPQSupport db connId pqSupport = - DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId) - -getDeletedConnIds :: DB.Connection -> IO [ConnId] -getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True) - -getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId] -getDeletedWaitingDeliveryConnIds db = - map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted_at_wait_delivery IS NOT NULL" - -setConnRatchetSync :: DB.Connection -> ConnId -> RatchetSyncState -> IO () -setConnRatchetSync db connId ratchetSyncState = - DB.execute db "UPDATE connections SET ratchet_sync_state = ? WHERE conn_id = ?" (ratchetSyncState, connId) - -addProcessedRatchetKeyHash :: DB.Connection -> ConnId -> ByteString -> IO () -addProcessedRatchetKeyHash db connId hash = - DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, hash) - -checkRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool -checkRatchetKeyHashExists db connId hash = do - fromMaybe False - <$> maybeFirstRow - fromOnly - ( DB.query - db - "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1" - (connId, hash) - ) - -deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO () -deleteRatchetKeyHashesExpired db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - DB.execute db "DELETE FROM processed_ratchet_key_hashes WHERE created_at < ?" (Only cutoffTs) - --- | returns all connection queues, the first queue is the primary one -getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue)) -getRcvQueuesByConnId_ db connId = - L.nonEmpty . sortBy primaryFirst . map toRcvQueue - <$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.deleted = 0") (Only connId) - where - primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} = - -- the current primary queue is ordered first, the next primary - second - compare (Down p) (Down p') <> compare i i' - -rcvQueueQuery :: Query -rcvQueueQuery = - [sql| - SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, - q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status, - q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, - q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret - FROM rcv_queues q - JOIN servers s ON q.host = s.host AND q.port = s.port - JOIN connections c ON q.conn_id = c.conn_id - |] - -toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, SenderCanSecure) - :. (QueueStatus, DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) - :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> - RcvQueue -toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure) :. (status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = - let server = SMPServer host port keyHash - smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ - clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of - (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} - _ -> Nothing - in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} - -getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) -getRcvQueueById db connId dbRcvId = - firstRow toRcvQueue SEConnNotFound $ - DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.rcv_queue_id = ? AND q.deleted = 0") (connId, dbRcvId) - --- | returns all connection queues, the first queue is the primary one -getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue)) -getSndQueuesByConnId_ dbConn connId = - L.nonEmpty . sortBy primaryFirst . map toSndQueue - <$> DB.query dbConn (sndQueueQuery <> "WHERE q.conn_id = ?") (Only connId) - where - primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} = - -- the current primary queue is ordered first, the next primary - second - compare (Down p) (Down p') <> compare i i' - -sndQueueQuery :: Query -sndQueueQuery = - [sql| - SELECT - c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.snd_secure, - q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, - q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version - FROM snd_queues q - JOIN servers s ON q.host = s.host AND q.port = s.port - JOIN connections c ON q.conn_id = c.conn_id - |] - -toSndQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, SenderCanSecure) - :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) - :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> - SndQueue -toSndQueue - ( (userId, keyHash, connId, host, port, sndId, sndSecure) - :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status) - :. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) - ) = - let server = SMPServer host port keyHash - sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey - in SndQueue {userId, connId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} - -getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue) -getSndQueueById db connId dbSndId = - firstRow toSndQueue SEConnNotFound $ - DB.query db (sndQueueQuery <> " WHERE q.conn_id = ? AND q.snd_queue_id = ?") (connId, dbSndId) - --- * updateRcvIds helpers - -retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) -retrieveLastIdsAndHashRcv_ dbConn connId = do - [(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)] <- - DB.queryNamed - dbConn - [sql| - SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash - FROM connections - WHERE conn_id = :conn_id; - |] - [":conn_id" := connId] - return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) - -updateLastIdsRcv_ :: DB.Connection -> ConnId -> InternalId -> InternalRcvId -> IO () -updateLastIdsRcv_ dbConn connId 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_id = :conn_id; - |] - [ ":last_internal_msg_id" := newInternalId, - ":last_internal_rcv_msg_id" := newInternalRcvId, - ":conn_id" := connId - ] - --- * createRcvMsg helpers - -insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO () -insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody, internalRcvId} = do - let MsgMeta {recipient = (internalId, internalTs), pqEncryption} = msgMeta - DB.execute - dbConn - [sql| - INSERT INTO messages - (conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption) - VALUES (?,?,?,?,?,?,?,?,?); - |] - (connId, internalId, internalTs, internalRcvId, Nothing :: Maybe Int64, msgType, msgFlags, msgBody, pqEncryption) - -insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () -insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash, encryptedMsgHash} = do - let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta - DB.executeNamed - db - [sql| - INSERT INTO rcv_messages - ( conn_id, rcv_queue_id, internal_rcv_id, internal_id, external_snd_id, - broker_id, broker_ts, - internal_hash, external_prev_snd_hash, integrity) - VALUES - (:conn_id,:rcv_queue_id,:internal_rcv_id,:internal_id,:external_snd_id, - :broker_id,:broker_ts, - :internal_hash,:external_prev_snd_hash,:integrity); - |] - [ ":conn_id" := connId, - ":rcv_queue_id" := dbQueueId, - ":internal_rcv_id" := internalRcvId, - ":internal_id" := fst recipient, - ":external_snd_id" := sndMsgId, - ":broker_id" := fst broker, - ":broker_ts" := snd broker, - ":internal_hash" := internalHash, - ":external_prev_snd_hash" := externalPrevSndHash, - ":integrity" := integrity - ] - DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash) - -updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO () -updateRcvMsgHash db connId sndMsgId internalRcvId internalHash = - DB.executeNamed - db - -- 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_id = :conn_id - AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id; - |] - [ ":last_external_snd_msg_id" := sndMsgId, - ":last_rcv_msg_hash" := internalHash, - ":conn_id" := connId, - ":last_internal_rcv_msg_id" := internalRcvId - ] - --- * updateSndIds helpers - -retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) -retrieveLastIdsAndHashSnd_ dbConn connId = do - firstRow id SEConnNotFound $ - DB.queryNamed - dbConn - [sql| - SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash - FROM connections - WHERE conn_id = :conn_id; - |] - [":conn_id" := connId] - -updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO () -updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId = - DB.executeNamed - dbConn - [sql| - UPDATE connections - SET last_internal_msg_id = :last_internal_msg_id, - last_internal_snd_msg_id = :last_internal_snd_msg_id - WHERE conn_id = :conn_id; - |] - [ ":last_internal_msg_id" := newInternalId, - ":last_internal_snd_msg_id" := newInternalSndId, - ":conn_id" := connId - ] - --- * createSndMsg helpers - -insertSndMsgBase_ :: DB.Connection -> ConnId -> SndMsgData -> IO () -insertSndMsgBase_ db connId SndMsgData {internalId, internalTs, internalSndId, msgType, msgFlags, msgBody, pqEncryption} = do - DB.execute - db - [sql| - INSERT INTO messages - (conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption) - VALUES - (?,?,?,?,?,?,?,?,?); - |] - (connId, internalId, internalTs, Nothing :: Maybe Int64, internalSndId, msgType, msgFlags, msgBody, pqEncryption) - -insertSndMsgDetails_ :: DB.Connection -> ConnId -> SndMsgData -> IO () -insertSndMsgDetails_ dbConn connId SndMsgData {..} = - DB.executeNamed - dbConn - [sql| - INSERT INTO snd_messages - ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash) - VALUES - (:conn_id,:internal_snd_id,:internal_id,:internal_hash,:previous_msg_hash); - |] - [ ":conn_id" := connId, - ":internal_snd_id" := internalSndId, - ":internal_id" := internalId, - ":internal_hash" := internalHash, - ":previous_msg_hash" := prevMsgHash - ] - -updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () -updateSndMsgHash db connId internalSndId internalHash = - DB.executeNamed - db - -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved - [sql| - UPDATE connections - SET last_snd_msg_hash = :last_snd_msg_hash - WHERE conn_id = :conn_id - AND last_internal_snd_msg_id = :last_internal_snd_msg_id; - |] - [ ":last_snd_msg_hash" := internalHash, - ":conn_id" := connId, - ":last_internal_snd_msg_id" := internalSndId - ] - --- create record with a random ID -createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString) -createWithRandomId gVar create = fst <$$> createWithRandomId' gVar create - -createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError (ByteString, a)) -createWithRandomId' gVar create = tryCreate 3 - where - tryCreate :: Int -> IO (Either StoreError (ByteString, a)) - tryCreate 0 = pure $ Left SEUniqueID - tryCreate n = do - id' <- randomId gVar 12 - E.try (create id') >>= \case - Right r -> pure $ Right (id', r) - Left e - | SQL.sqlError e == SQL.ErrorConstraint -> tryCreate (n - 1) - | otherwise -> pure . Left . SEInternal $ bshow e - -randomId :: TVar ChaChaDRG -> Int -> IO ByteString -randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar - -ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction) -ntfSubAndSMPAction (NSANtf action) = (Just action, Nothing) -ntfSubAndSMPAction (NSASMP action) = (Nothing, Just action) - -createXFTPServer_ :: DB.Connection -> XFTPServer -> IO Int64 -createXFTPServer_ db newSrv@ProtocolServer {host, port, keyHash} = - getXFTPServerId_ db newSrv >>= \case - Right srvId -> pure srvId - Left _ -> insertNewServer_ - where - insertNewServer_ = do - DB.execute db "INSERT INTO xftp_servers (xftp_host, xftp_port, xftp_key_hash) VALUES (?,?,?)" (host, port, keyHash) - insertedRowId db - -getXFTPServerId_ :: DB.Connection -> XFTPServer -> IO (Either StoreError Int64) -getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do - firstRow fromOnly SEXFTPServerNotFound $ - DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash) - -createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) -createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file approvedRelays = runExceptT $ do - (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing approvedRelays - liftIO $ - forM_ chunks $ \fc@FileChunk {replicas} -> do - chunkId <- insertRcvFileChunk db fc rcvFileId - forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId - pure rcvFileEntityId - -createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) -createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" -createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do - (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays - (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) approvedRelays - liftIO $ - forM_ redirectChunks $ \fc@FileChunk {replicas} -> do - chunkId <- insertRcvFileChunk db fc redirectId - forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId - pure dstEntityId - where - dummyDst = - FileDescription - { party = SFRecipient, - size, - digest, - redirect = Nothing, - -- updated later with updateRcvFileRedirect - key = C.unsafeSbKey $ B.replicate 32 '#', - nonce = C.cbNonce "", - chunkSize = FileSize 0, - chunks = [] - } - -insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId)) -insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ approvedRelays = runExceptT $ do - let (redirectDigest_, redirectSize_) = case redirect of - Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s) - Nothing -> (Nothing, Nothing) - rcvFileEntityId <- ExceptT $ - createWithRandomId gVar $ \rcvFileEntityId -> - DB.execute - db - "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" - ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_, approvedRelays)) - rcvFileId <- liftIO $ insertedRowId db - pure (rcvFileEntityId, rcvFileId) - -insertRcvFileChunk :: DB.Connection -> FileChunk -> DBRcvFileId -> IO Int64 -insertRcvFileChunk db FileChunk {chunkNo, chunkSize, digest} rcvFileId = do - DB.execute - db - "INSERT INTO rcv_file_chunks (rcv_file_id, chunk_no, chunk_size, digest) VALUES (?,?,?,?)" - (rcvFileId, chunkNo, chunkSize, digest) - insertedRowId db - -insertRcvFileChunkReplica :: DB.Connection -> Int -> FileChunkReplica -> Int64 -> IO () -insertRcvFileChunkReplica db replicaNo FileChunkReplica {server, replicaId, replicaKey} chunkId = do - srvId <- createXFTPServer_ db server - DB.execute - db - "INSERT INTO rcv_file_chunk_replicas (replica_number, rcv_file_chunk_id, xftp_server_id, replica_id, replica_key) VALUES (?,?,?,?,?)" - (replicaNo, chunkId, srvId, replicaId, replicaKey) - -getRcvFileByEntityId :: DB.Connection -> RcvFileId -> IO (Either StoreError RcvFile) -getRcvFileByEntityId db rcvFileEntityId = runExceptT $ do - rcvFileId <- ExceptT $ getRcvFileIdByEntityId_ db rcvFileEntityId - ExceptT $ getRcvFile db rcvFileId - -getRcvFileIdByEntityId_ :: DB.Connection -> RcvFileId -> IO (Either StoreError DBRcvFileId) -getRcvFileIdByEntityId_ db rcvFileEntityId = - firstRow fromOnly SEFileNotFound $ - DB.query db "SELECT rcv_file_id FROM rcv_files WHERE rcv_file_entity_id = ?" (Only rcvFileEntityId) - -getRcvFileRedirects :: DB.Connection -> DBRcvFileId -> IO [RcvFile] -getRcvFileRedirects db rcvFileId = do - redirects <- fromOnly <$$> DB.query db "SELECT rcv_file_id FROM rcv_files WHERE redirect_id = ?" (Only rcvFileId) - fmap catMaybes . forM redirects $ getRcvFile db >=> either (const $ pure Nothing) (pure . Just) - -getRcvFile :: DB.Connection -> DBRcvFileId -> IO (Either StoreError RcvFile) -getRcvFile db rcvFileId = runExceptT $ do - f@RcvFile {rcvFileEntityId, userId, tmpPath} <- ExceptT getFile - chunks <- maybe (pure []) (liftIO . getChunks rcvFileEntityId userId) tmpPath - pure (f {chunks} :: RcvFile) - where - getFile :: IO (Either StoreError RcvFile) - getFile = do - firstRow toFile SEFileNotFound $ - DB.query - db - [sql| - SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, deleted, redirect_id, redirect_entity_id, redirect_size, redirect_digest - FROM rcv_files - WHERE rcv_file_id = ? - |] - (Only rcvFileId) - where - toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath) :. (FilePath, Maybe C.SbKey, Maybe C.CbNonce, RcvFileStatus, Bool, Maybe DBRcvFileId, Maybe RcvFileId, Maybe (FileSize Int64), Maybe FileDigest) -> RcvFile - toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, deleted, redirectDbId, redirectEntityId, redirectSize_, redirectDigest_)) = - let cfArgs = CFArgs <$> saveKey_ <*> saveNonce_ - saveFile = CryptoFile savePath cfArgs - redirect = - RcvFileRedirect - <$> redirectDbId - <*> redirectEntityId - <*> (RedirectFileInfo <$> redirectSize_ <*> redirectDigest_) - in RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, redirect, prefixPath, tmpPath, saveFile, status, deleted, chunks = []} - getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk] - getChunks rcvFileEntityId userId fileTmpPath = do - chunks <- - map toChunk - <$> DB.query - db - [sql| - SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path - FROM rcv_file_chunks - WHERE rcv_file_id = ? - |] - (Only rcvFileId) - forM chunks $ \chunk@RcvFileChunk {rcvChunkId} -> do - replicas' <- getChunkReplicas rcvChunkId - pure (chunk {replicas = replicas'} :: RcvFileChunk) - where - toChunk :: (Int64, Int, FileSize Word32, FileDigest, Maybe FilePath) -> RcvFileChunk - toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath) = - RcvFileChunk {rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, replicas = []} - getChunkReplicas :: Int64 -> IO [RcvFileChunkReplica] - getChunkReplicas chunkId = do - map toReplica - <$> DB.query - db - [sql| - SELECT - r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, - s.xftp_host, s.xftp_port, s.xftp_key_hash - FROM rcv_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - WHERE r.rcv_file_chunk_id = ? - |] - (Only chunkId) - where - toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica - toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) = - let server = XFTPServer host port keyHash - in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries} - -updateRcvChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () -updateRcvChunkReplicaDelay db replicaId delay = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (delay, updatedAt, replicaId) - -updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> FilePath -> IO () -updateRcvFileChunkReceived db replicaId chunkId chunkTmpPath = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_file_chunk_replicas SET received = 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (updatedAt, replicaId) - DB.execute db "UPDATE rcv_file_chunks SET tmp_path = ?, updated_at = ? WHERE rcv_file_chunk_id = ?" (chunkTmpPath, updatedAt, chunkId) - -updateRcvFileStatus :: DB.Connection -> DBRcvFileId -> RcvFileStatus -> IO () -updateRcvFileStatus db rcvFileId status = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_files SET status = ?, updated_at = ? WHERE rcv_file_id = ?" (status, updatedAt, rcvFileId) - -updateRcvFileError :: DB.Connection -> DBRcvFileId -> String -> IO () -updateRcvFileError db rcvFileId errStr = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_files SET tmp_path = NULL, error = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (errStr, RFSError, updatedAt, rcvFileId) - -updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> IO () -updateRcvFileComplete db rcvFileId = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_files SET tmp_path = NULL, status = ?, updated_at = ? WHERE rcv_file_id = ?" (RFSComplete, updatedAt, rcvFileId) - -updateRcvFileRedirect :: DB.Connection -> DBRcvFileId -> FileDescription 'FRecipient -> IO (Either StoreError ()) -updateRcvFileRedirect db rcvFileId FileDescription {key, nonce, chunkSize, chunks} = runExceptT $ do - updatedAt <- liftIO getCurrentTime - liftIO $ DB.execute db "UPDATE rcv_files SET key = ?, nonce = ?, chunk_size = ?, updated_at = ? WHERE rcv_file_id = ?" (key, nonce, chunkSize, updatedAt, rcvFileId) - liftIO $ forM_ chunks $ \fc@FileChunk {replicas} -> do - chunkId <- insertRcvFileChunk db fc rcvFileId - forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId - -updateRcvFileNoTmpPath :: DB.Connection -> DBRcvFileId -> IO () -updateRcvFileNoTmpPath db rcvFileId = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_files SET tmp_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId) - -updateRcvFileDeleted :: DB.Connection -> DBRcvFileId -> IO () -updateRcvFileDeleted db rcvFileId = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE rcv_files SET deleted = 1, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId) - -deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO () -deleteRcvFile' db rcvFileId = - DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId) - -getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool, Maybe RcvFileId))) -getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do - getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd) - where - getReplicaId :: IO (Maybe (Int64, DBRcvFileId)) - getReplicaId = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - maybeFirstRow id $ - DB.query - db - [sql| - SELECT r.rcv_file_chunk_replica_id, f.rcv_file_id - FROM rcv_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id - JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id - WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ? - AND r.received = 0 AND r.replica_number = 1 - AND f.status = ? AND f.deleted = 0 AND f.created_at >= ? - AND f.failed = 0 - ORDER BY r.retries ASC, r.created_at ASC - LIMIT 1 - |] - (host, port, keyHash, RFSReceiving, cutoffTs) - getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool, Maybe RcvFileId)) - getChunkData (rcvFileChunkReplicaId, _fileId) = - firstRow toChunk SEFileNotFound $ - DB.query - db - [sql| - SELECT - f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, - r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, - f.approved_relays, f.redirect_entity_id - FROM rcv_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id - JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id - WHERE r.rcv_file_chunk_replica_id = ? - |] - (Only rcvFileChunkReplicaId) - where - toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. (Bool, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId) - toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (approvedRelays, redirectEntityId_)) = - ( RcvFileChunk - { rcvFileId, - rcvFileEntityId, - userId, - rcvChunkId, - chunkNo, - chunkSize, - digest, - fileTmpPath, - chunkTmpPath, - replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] - }, - approvedRelays, - redirectEntityId_ - ) - -getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile)) -getNextRcvFileToDecrypt db ttl = - getWorkItem "rcv_file_decrypt" getFileId (getRcvFile db) (markRcvFileFailed db) - where - getFileId :: IO (Maybe DBRcvFileId) - getFileId = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT rcv_file_id - FROM rcv_files - WHERE status IN (?,?) AND deleted = 0 AND created_at >= ? - AND failed = 0 - ORDER BY created_at ASC LIMIT 1 - |] - (RFSReceived, RFSDecrypting, cutoffTs) - -markRcvFileFailed :: DB.Connection -> DBRcvFileId -> IO () -markRcvFileFailed db fileId = do - DB.execute db "UPDATE rcv_files SET failed = 1 WHERE rcv_file_id = ?" (Only fileId) - -getPendingRcvFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer] -getPendingRcvFilesServers db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - map toXFTPServer - <$> DB.query - db - [sql| - SELECT DISTINCT - s.xftp_host, s.xftp_port, s.xftp_key_hash - FROM rcv_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id - JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id - WHERE r.received = 0 AND r.replica_number = 1 - AND f.status = ? AND f.deleted = 0 AND f.created_at >= ? - |] - (RFSReceiving, cutoffTs) - -toXFTPServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer -toXFTPServer (host, port, keyHash) = XFTPServer host port keyHash - -getCleanupRcvFilesTmpPaths :: DB.Connection -> IO [(DBRcvFileId, RcvFileId, FilePath)] -getCleanupRcvFilesTmpPaths db = - DB.query - db - [sql| - SELECT rcv_file_id, rcv_file_entity_id, tmp_path - FROM rcv_files - WHERE status IN (?,?) AND tmp_path IS NOT NULL - |] - (RFSComplete, RFSError) - -getCleanupRcvFilesDeleted :: DB.Connection -> IO [(DBRcvFileId, RcvFileId, FilePath)] -getCleanupRcvFilesDeleted db = - DB.query_ - db - [sql| - SELECT rcv_file_id, rcv_file_entity_id, prefix_path - FROM rcv_files - WHERE deleted = 1 - |] - -getRcvFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBRcvFileId, RcvFileId, FilePath)] -getRcvFilesExpired db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - DB.query - db - [sql| - SELECT rcv_file_id, rcv_file_entity_id, prefix_path - FROM rcv_files - WHERE created_at < ? - |] - (Only cutoffTs) - -createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId) -createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ = - createWithRandomId gVar $ \sndFileEntityId -> - DB.execute - db - "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" - ((sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_)) - where - (redirectSize_, redirectDigest_) = - case redirect_ of - Nothing -> (Nothing, Nothing) - Just RedirectFileInfo {size, digest} -> (Just size, Just digest) - -getSndFileByEntityId :: DB.Connection -> SndFileId -> IO (Either StoreError SndFile) -getSndFileByEntityId db sndFileEntityId = runExceptT $ do - sndFileId <- ExceptT $ getSndFileIdByEntityId_ db sndFileEntityId - ExceptT $ getSndFile db sndFileId - -getSndFileIdByEntityId_ :: DB.Connection -> SndFileId -> IO (Either StoreError DBSndFileId) -getSndFileIdByEntityId_ db sndFileEntityId = - firstRow fromOnly SEFileNotFound $ - DB.query db "SELECT snd_file_id FROM snd_files WHERE snd_file_entity_id = ?" (Only sndFileEntityId) - -getSndFile :: DB.Connection -> DBSndFileId -> IO (Either StoreError SndFile) -getSndFile db sndFileId = runExceptT $ do - f@SndFile {sndFileEntityId, userId, numRecipients, prefixPath} <- ExceptT getFile - chunks <- maybe (pure []) (liftIO . getChunks sndFileEntityId userId numRecipients) prefixPath - pure (f {chunks} :: SndFile) - where - getFile :: IO (Either StoreError SndFile) - getFile = do - firstRow toFile SEFileNotFound $ - DB.query - db - [sql| - SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest - FROM snd_files - WHERE snd_file_id = ? - |] - (Only sndFileId) - where - toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, Bool, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile - toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, deleted, redirectSize_, redirectDigest_)) = - let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ - srcFile = CryptoFile srcPath cfArgs - redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ - in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []} - getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] - getChunks sndFileEntityId userId numRecipients filePrefixPath = do - chunks <- - map toChunk - <$> DB.query - db - [sql| - SELECT snd_file_chunk_id, chunk_no, chunk_offset, chunk_size, digest - FROM snd_file_chunks - WHERE snd_file_id = ? - |] - (Only sndFileId) - forM chunks $ \chunk@SndFileChunk {sndChunkId} -> do - replicas' <- getChunkReplicas sndChunkId - pure (chunk {replicas = replicas'} :: SndFileChunk) - where - toChunk :: (Int64, Int, Int64, Word32, FileDigest) -> SndFileChunk - toChunk (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) = - let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize} - in SndFileChunk {sndFileId, sndFileEntityId, userId, numRecipients, sndChunkId, chunkNo, chunkSpec, filePrefixPath, digest, replicas = []} - getChunkReplicas :: Int64 -> IO [SndFileChunkReplica] - getChunkReplicas chunkId = do - replicas <- - map toReplica - <$> DB.query - db - [sql| - SELECT - r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, - s.xftp_host, s.xftp_port, s.xftp_key_hash - FROM snd_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - WHERE r.snd_file_chunk_id = ? - |] - (Only chunkId) - forM replicas $ \replica@SndFileChunkReplica {sndChunkReplicaId} -> do - rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId - pure (replica :: SndFileChunkReplica) {rcvIdsKeys} - where - toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica - toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) = - let server = XFTPServer host port keyHash - in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []} - -getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)] -getChunkReplicaRecipients_ db replicaId = - DB.query - db - [sql| - SELECT rcv_replica_id, rcv_replica_key - FROM snd_file_chunk_replica_recipients - WHERE snd_file_chunk_replica_id = ? - |] - (Only replicaId) - -getNextSndFileToPrepare :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe SndFile)) -getNextSndFileToPrepare db ttl = - getWorkItem "snd_file_prepare" getFileId (getSndFile db) (markSndFileFailed db) - where - getFileId :: IO (Maybe DBSndFileId) - getFileId = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT snd_file_id - FROM snd_files - WHERE status IN (?,?,?) AND deleted = 0 AND created_at >= ? - AND failed = 0 - ORDER BY created_at ASC LIMIT 1 - |] - (SFSNew, SFSEncrypting, SFSEncrypted, cutoffTs) - -markSndFileFailed :: DB.Connection -> DBSndFileId -> IO () -markSndFileFailed db fileId = - DB.execute db "UPDATE snd_files SET failed = 1 WHERE snd_file_id = ?" (Only fileId) - -updateSndFileError :: DB.Connection -> DBSndFileId -> String -> IO () -updateSndFileError db sndFileId errStr = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_files SET prefix_path = NULL, error = ?, status = ?, updated_at = ? WHERE snd_file_id = ?" (errStr, SFSError, updatedAt, sndFileId) - -updateSndFileStatus :: DB.Connection -> DBSndFileId -> SndFileStatus -> IO () -updateSndFileStatus db sndFileId status = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_files SET status = ?, updated_at = ? WHERE snd_file_id = ?" (status, updatedAt, sndFileId) - -updateSndFileEncrypted :: DB.Connection -> DBSndFileId -> FileDigest -> [(XFTPChunkSpec, FileDigest)] -> IO () -updateSndFileEncrypted db sndFileId digest chunkSpecsDigests = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_files SET status = ?, digest = ?, updated_at = ? WHERE snd_file_id = ?" (SFSEncrypted, digest, updatedAt, sndFileId) - forM_ (zip [1 ..] chunkSpecsDigests) $ \(chunkNo :: Int, (XFTPChunkSpec {chunkOffset, chunkSize}, chunkDigest)) -> - DB.execute db "INSERT INTO snd_file_chunks (snd_file_id, chunk_no, chunk_offset, chunk_size, digest) VALUES (?,?,?,?,?)" (sndFileId, chunkNo, chunkOffset, chunkSize, chunkDigest) - -updateSndFileComplete :: DB.Connection -> DBSndFileId -> IO () -updateSndFileComplete db sndFileId = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_files SET prefix_path = NULL, status = ?, updated_at = ? WHERE snd_file_id = ?" (SFSComplete, updatedAt, sndFileId) - -updateSndFileNoPrefixPath :: DB.Connection -> DBSndFileId -> IO () -updateSndFileNoPrefixPath db sndFileId = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_files SET prefix_path = NULL, updated_at = ? WHERE snd_file_id = ?" (updatedAt, sndFileId) - -updateSndFileDeleted :: DB.Connection -> DBSndFileId -> IO () -updateSndFileDeleted db sndFileId = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_files SET deleted = 1, updated_at = ? WHERE snd_file_id = ?" (updatedAt, sndFileId) - -deleteSndFile' :: DB.Connection -> DBSndFileId -> IO () -deleteSndFile' db sndFileId = - DB.execute db "DELETE FROM snd_files WHERE snd_file_id = ?" (Only sndFileId) - -getSndFileDeleted :: DB.Connection -> DBSndFileId -> IO Bool -getSndFileDeleted db sndFileId = - fromMaybe True - <$> maybeFirstRow fromOnly (DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)) - -createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> IO () -createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId - -createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO () -createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do - srvId <- createXFTPServer_ db server - DB.execute - db - [sql| - INSERT INTO snd_file_chunk_replicas - (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status) - VALUES (?,?,?,?,?,?) - |] - (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated) - rId <- insertedRowId db - forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do - DB.execute - db - [sql| - INSERT INTO snd_file_chunk_replica_recipients - (snd_file_chunk_replica_id, rcv_replica_id, rcv_replica_key) - VALUES (?,?,?) - |] - (rId, rcvId, rcvKey) - -getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe SndFileChunk)) -getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do - getWorkItem "snd_file_upload" getReplicaId getChunkData (markSndFileFailed db . snd) - where - getReplicaId :: IO (Maybe (Int64, DBSndFileId)) - getReplicaId = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - maybeFirstRow id $ - DB.query - db - [sql| - SELECT r.snd_file_chunk_replica_id, f.snd_file_id - FROM snd_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id - JOIN snd_files f ON f.snd_file_id = c.snd_file_id - WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ? - AND r.replica_status = ? AND r.replica_number = 1 - AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ? - AND f.failed = 0 - ORDER BY r.retries ASC, r.created_at ASC - LIMIT 1 - |] - (host, port, keyHash, SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs) - getChunkData :: (Int64, DBSndFileId) -> IO (Either StoreError SndFileChunk) - getChunkData (sndFileChunkReplicaId, _fileId) = do - chunk_ <- - firstRow toChunk SEFileNotFound $ - DB.query - db - [sql| - SELECT - f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path, - c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest, - r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries - FROM snd_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id - JOIN snd_files f ON f.snd_file_id = c.snd_file_id - WHERE r.snd_file_chunk_replica_id = ? - |] - (Only sndFileChunkReplicaId) - forM chunk_ $ \chunk@SndFileChunk {replicas} -> do - replicas' <- forM replicas $ \replica@SndFileChunkReplica {sndChunkReplicaId} -> do - rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId - pure (replica :: SndFileChunkReplica) {rcvIdsKeys} - pure (chunk {replicas = replicas'} :: SndFileChunk) - where - toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk - toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) = - let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize} - in SndFileChunk - { sndFileId, - sndFileEntityId, - userId, - numRecipients, - sndChunkId, - chunkNo, - chunkSpec, - digest, - filePrefixPath, - replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}] - } - -updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () -updateSndChunkReplicaDelay db replicaId delay = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (delay, updatedAt, replicaId) - -addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateAuthKey)] -> IO SndFileChunkReplica -addSndChunkReplicaRecipients db r@SndFileChunkReplica {sndChunkReplicaId} rcvIdsKeys = do - forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do - DB.execute - db - [sql| - INSERT INTO snd_file_chunk_replica_recipients - (snd_file_chunk_replica_id, rcv_replica_id, rcv_replica_key) - VALUES (?,?,?) - |] - (sndChunkReplicaId, rcvId, rcvKey) - rcvIdsKeys' <- getChunkReplicaRecipients_ db sndChunkReplicaId - pure (r :: SndFileChunkReplica) {rcvIdsKeys = rcvIdsKeys'} - -updateSndChunkReplicaStatus :: DB.Connection -> Int64 -> SndFileReplicaStatus -> IO () -updateSndChunkReplicaStatus db replicaId status = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE snd_file_chunk_replicas SET replica_status = ?, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (status, updatedAt, replicaId) - -getPendingSndFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer] -getPendingSndFilesServers db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - map toXFTPServer - <$> DB.query - db - [sql| - SELECT DISTINCT - s.xftp_host, s.xftp_port, s.xftp_key_hash - FROM snd_file_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id - JOIN snd_files f ON f.snd_file_id = c.snd_file_id - WHERE r.replica_status = ? AND r.replica_number = 1 - AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ? - |] - (SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs) - -getCleanupSndFilesPrefixPaths :: DB.Connection -> IO [(DBSndFileId, SndFileId, FilePath)] -getCleanupSndFilesPrefixPaths db = - DB.query - db - [sql| - SELECT snd_file_id, snd_file_entity_id, prefix_path - FROM snd_files - WHERE status IN (?,?) AND prefix_path IS NOT NULL - |] - (SFSComplete, SFSError) - -getCleanupSndFilesDeleted :: DB.Connection -> IO [(DBSndFileId, SndFileId, Maybe FilePath)] -getCleanupSndFilesDeleted db = - DB.query_ - db - [sql| - SELECT snd_file_id, snd_file_entity_id, prefix_path - FROM snd_files - WHERE deleted = 1 - |] - -getSndFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBSndFileId, SndFileId, Maybe FilePath)] -getSndFilesExpired db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - DB.query - db - [sql| - SELECT snd_file_id, snd_file_entity_id, prefix_path - FROM snd_files - WHERE created_at < ? - |] - (Only cutoffTs) - -createDeletedSndChunkReplica :: DB.Connection -> UserId -> FileChunkReplica -> FileDigest -> IO () -createDeletedSndChunkReplica db userId FileChunkReplica {server, replicaId, replicaKey} chunkDigest = do - srvId <- createXFTPServer_ db server - DB.execute - db - "INSERT INTO deleted_snd_chunk_replicas (user_id, xftp_server_id, replica_id, replica_key, chunk_digest) VALUES (?,?,?,?,?)" - (userId, srvId, replicaId, replicaKey, chunkDigest) - -getDeletedSndChunkReplica :: DB.Connection -> DBSndFileId -> IO (Either StoreError DeletedSndChunkReplica) -getDeletedSndChunkReplica db deletedSndChunkReplicaId = - firstRow toReplica SEDeletedSndChunkReplicaNotFound $ - DB.query - db - [sql| - SELECT - r.user_id, r.replica_id, r.replica_key, r.chunk_digest, r.delay, r.retries, - s.xftp_host, s.xftp_port, s.xftp_key_hash - FROM deleted_snd_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - WHERE r.deleted_snd_chunk_replica_id = ? - |] - (Only deletedSndChunkReplicaId) - where - toReplica :: (UserId, ChunkReplicaId, C.APrivateAuthKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica - toReplica (userId, replicaId, replicaKey, chunkDigest, delay, retries, host, port, keyHash) = - let server = XFTPServer host port keyHash - in DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, replicaId, replicaKey, chunkDigest, delay, retries} - -getNextDeletedSndChunkReplica :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe DeletedSndChunkReplica)) -getNextDeletedSndChunkReplica db ProtocolServer {host, port, keyHash} ttl = - getWorkItem "deleted replica" getReplicaId (getDeletedSndChunkReplica db) markReplicaFailed - where - getReplicaId :: IO (Maybe Int64) - getReplicaId = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT r.deleted_snd_chunk_replica_id - FROM deleted_snd_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ? - AND r.created_at >= ? - AND failed = 0 - ORDER BY r.retries ASC, r.created_at ASC - LIMIT 1 - |] - (host, port, keyHash, cutoffTs) - markReplicaFailed :: Int64 -> IO () - markReplicaFailed replicaId = do - DB.execute db "UPDATE deleted_snd_chunk_replicas SET failed = 1 WHERE deleted_snd_chunk_replica_id = ?" (Only replicaId) - -updateDeletedSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () -updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId delay = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE deleted_snd_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE deleted_snd_chunk_replica_id = ?" (delay, updatedAt, deletedSndChunkReplicaId) - -deleteDeletedSndChunkReplica :: DB.Connection -> Int64 -> IO () -deleteDeletedSndChunkReplica db deletedSndChunkReplicaId = - DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE deleted_snd_chunk_replica_id = ?" (Only deletedSndChunkReplicaId) - -getPendingDelFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer] -getPendingDelFilesServers db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - map toXFTPServer - <$> DB.query - db - [sql| - SELECT DISTINCT - s.xftp_host, s.xftp_port, s.xftp_key_hash - FROM deleted_snd_chunk_replicas r - JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id - WHERE r.created_at >= ? - |] - (Only cutoffTs) - -deleteDeletedSndChunkReplicasExpired :: DB.Connection -> NominalDiffTime -> IO () -deleteDeletedSndChunkReplicasExpired db ttl = do - cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime - DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE created_at < ?" (Only cutoffTs) - -updateServersStats :: DB.Connection -> AgentPersistedServerStats -> IO () -updateServersStats db stats = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE servers_stats SET servers_stats = ?, updated_at = ? WHERE servers_stats_id = 1" (stats, updatedAt) - -getServersStats :: DB.Connection -> IO (Either StoreError (UTCTime, Maybe AgentPersistedServerStats)) -getServersStats db = - firstRow id SEServersStatsNotFound $ - DB.query_ db "SELECT started_at, servers_stats FROM servers_stats WHERE servers_stats_id = 1" - -resetServersStats :: DB.Connection -> UTCTime -> IO () -resetServersStats db startedAt = - DB.execute db "UPDATE servers_stats SET servers_stats = NULL, started_at = ?, updated_at = ? WHERE servers_stats_id = 1" (startedAt, startedAt) - -$(J.deriveJSON defaultJSON ''UpMigration) - -$(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs index a7ad47f37..3b0c4d6c8 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Common.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Simplex.Messaging.Agent.Store.SQLite.Common - ( SQLiteStore (..), + ( DBStore (..), withConnection, withConnection', withTransaction, @@ -30,7 +30,7 @@ import UnliftIO.STM storeKey :: ScrubbedBytes -> Bool -> Maybe ScrubbedBytes storeKey key keepKey = if keepKey || BA.null key then Just key else Nothing -data SQLiteStore = SQLiteStore +data DBStore = DBStore { dbFilePath :: FilePath, dbKey :: TVar (Maybe ScrubbedBytes), dbSem :: TVar Int, @@ -39,8 +39,8 @@ data SQLiteStore = SQLiteStore dbNew :: Bool } -withConnectionPriority :: SQLiteStore -> Bool -> (DB.Connection -> IO a) -> IO a -withConnectionPriority SQLiteStore {dbSem, dbConnection} priority action +withConnectionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a +withConnectionPriority DBStore {dbSem, dbConnection} priority action | priority = E.bracket_ signal release $ withMVar dbConnection action | otherwise = lowPriority where @@ -50,20 +50,20 @@ withConnectionPriority SQLiteStore {dbSem, dbConnection} priority action wait = unlessM free $ atomically $ unlessM ((0 ==) <$> readTVar dbSem) retry free = (0 ==) <$> readTVarIO dbSem -withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a +withConnection :: DBStore -> (DB.Connection -> IO a) -> IO a withConnection st = withConnectionPriority st False -withConnection' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a +withConnection' :: DBStore -> (SQL.Connection -> IO a) -> IO a withConnection' st action = withConnection st $ action . DB.conn -withTransaction' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a +withTransaction' :: DBStore -> (SQL.Connection -> IO a) -> IO a withTransaction' st action = withTransaction st $ action . DB.conn -withTransaction :: SQLiteStore -> (DB.Connection -> IO a) -> IO a +withTransaction :: DBStore -> (DB.Connection -> IO a) -> IO a withTransaction st = withTransactionPriority st False {-# INLINE withTransaction #-} -withTransactionPriority :: SQLiteStore -> Bool -> (DB.Connection -> IO a) -> IO a +withTransactionPriority :: DBStore -> Bool -> (DB.Connection -> IO a) -> IO a withTransactionPriority st priority action = withConnectionPriority st priority $ dbBusyLoop . transaction where transaction db@DB.Connection {conn} = SQL.withImmediateTransaction conn $ action db diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 4d9dbeb57..a5d5189d0 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -20,8 +20,8 @@ module Simplex.Messaging.Agent.Store.SQLite.DB where import Control.Concurrent.STM -import Control.Monad (when) import Control.Exception +import Control.Monad (when) import qualified Data.Aeson.TH as J import Data.Int (Int64) import Data.Map.Strict (Map) @@ -51,9 +51,10 @@ data SlowQueryStats = SlowQueryStats timeIt :: TMap Query SlowQueryStats -> Query -> IO a -> IO a timeIt slow sql a = do t <- getCurrentTime - r <- a `catch` \e -> do - atomically $ TM.alter (Just . updateQueryErrors e) sql slow - throwIO e + r <- + a `catch` \e -> do + atomically $ TM.alter (Just . updateQueryErrors e) sql slow + throwIO e t' <- getCurrentTime let diff = diffToMilliseconds $ diffUTCTime t' t when (diff > 1) $ atomically $ TM.alter (updateQueryStats diff) sql slow @@ -91,6 +92,7 @@ execute_ :: Connection -> Query -> IO () execute_ Connection {conn, slow} sql = timeIt slow sql $ SQL.execute_ conn sql {-# INLINE execute_ #-} +-- TODO [postgres] remove executeNamed :: Connection -> Query -> [NamedParam] -> IO () executeNamed Connection {conn, slow} sql = timeIt slow sql . SQL.executeNamed conn sql {-# INLINE executeNamed #-} @@ -107,6 +109,7 @@ query_ :: FromRow r => Connection -> Query -> IO [r] query_ Connection {conn, slow} sql = timeIt slow sql $ SQL.query_ conn sql {-# INLINE query_ #-} +-- TODO [postgres] remove queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r] queryNamed Connection {conn, slow} sql = timeIt slow sql . SQL.queryNamed conn sql {-# INLINE queryNamed #-} diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 7e58ceec5..5b9f91660 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -5,40 +5,29 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.SQLite.Migrations - ( Migration (..), - MigrationsToRun (..), - MTRError (..), - DownMigration (..), - app, + ( app, initialize, - get, run, getCurrent, - mtrErrorDescription, - -- for unit tests - migrationsToRun, - toDownMigration, ) where import Control.Monad (forM_, when) -import qualified Data.Aeson.TH as J -import Data.List (intercalate, sortOn) +import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M -import Data.Maybe (isNothing, mapMaybe) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Connection, Only (..), Query (..)) -import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple (Only (..), Query (..)) +import qualified Database.SQLite.Simple as SQL import Database.SQLite.Simple.QQ (sql) import qualified Database.SQLite3 as SQLite3 import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts) +import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.SQLite.Common import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys @@ -76,13 +65,10 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts +import Simplex.Messaging.Agent.Store.Shared import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Transport.Client (TransportHost) -data Migration = Migration {name :: String, up :: Text, down :: Maybe Text} - deriving (Eq, Show) - schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations = [ ("20220101_initial", m20220101_initial, Nothing), @@ -129,15 +115,12 @@ app = sortOn name $ map migration schemaMigrations where migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} -get :: SQLiteStore -> [Migration] -> IO (Either MTRError MigrationsToRun) -get st migrations = migrationsToRun migrations <$> withTransaction' st getCurrent - -getCurrent :: Connection -> IO [Migration] -getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;" +getCurrent :: DB.Connection -> IO [Migration] +getCurrent DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;" where toMigration (name, down) = Migration {name, up = "", down} -run :: SQLiteStore -> MigrationsToRun -> IO () +run :: DBStore -> MigrationsToRun -> IO () run st = \case MTRUp [] -> pure () MTRUp ms -> mapM_ runUp ms >> withConnection' st (`execSQL` "VACUUM;") @@ -148,27 +131,27 @@ run st = \case when (name == "m20220811_onion_hosts") $ updateServers db insert db >> execSQL db up' where - insert db = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime + insert db = SQL.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime up' | dbNew st && name == "m20230110_users" = fromQuery new_m20230110_users | otherwise = up updateServers db = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') -> let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost) - in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h) + in SQL.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h) runDown DownMigration {downName, downQuery} = withTransaction' st $ \db -> do execSQL db downQuery - DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName) - execSQL db = SQLite3.exec $ DB.connectionHandle db + SQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName) + execSQL db = SQLite3.exec $ SQL.connectionHandle db -initialize :: SQLiteStore -> IO () +initialize :: DBStore -> IO () initialize st = withTransaction' st $ \db -> do - cs :: [Text] <- map fromOnly <$> DB.query_ db "SELECT name FROM pragma_table_info('migrations')" + cs :: [Text] <- map fromOnly <$> SQL.query_ db "SELECT name FROM pragma_table_info('migrations')" case cs of [] -> createMigrations db - _ -> when ("down" `notElem` cs) $ DB.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT" + _ -> when ("down" `notElem` cs) $ SQL.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT" where createMigrations db = - DB.execute_ + SQL.execute_ db [sql| CREATE TABLE IF NOT EXISTS migrations ( @@ -178,37 +161,3 @@ initialize st = withTransaction' st $ \db -> do PRIMARY KEY (name) ); |] - -data DownMigration = DownMigration {downName :: String, downQuery :: Text} - deriving (Eq, Show) - -toDownMigration :: Migration -> Maybe DownMigration -toDownMigration Migration {name, down} = DownMigration name <$> down - -data MigrationsToRun = MTRUp [Migration] | MTRDown [DownMigration] | MTRNone - deriving (Eq, Show) - -data MTRError - = MTRENoDown {dbMigrations :: [String]} - | MTREDifferent {appMigration :: String, dbMigration :: String} - deriving (Eq, Show) - -mtrErrorDescription :: MTRError -> String -mtrErrorDescription = \case - MTRENoDown ms -> "database version is newer than the app, but no down migration for: " <> intercalate ", " ms - MTREDifferent a d -> "different migration in the app/database: " <> a <> " / " <> d - -migrationsToRun :: [Migration] -> [Migration] -> Either MTRError MigrationsToRun -migrationsToRun [] [] = Right MTRNone -migrationsToRun appMs [] = Right $ MTRUp appMs -migrationsToRun [] dbMs - | length dms == length dbMs = Right $ MTRDown dms - | otherwise = Left $ MTRENoDown $ mapMaybe nameNoDown dbMs - where - dms = mapMaybe toDownMigration dbMs - nameNoDown m = if isNothing (down m) then Just $ name m else Nothing -migrationsToRun (a : as) (d : ds) - | name a == name d = migrationsToRun as ds - | otherwise = Left $ MTREDifferent (name a) (name d) - -$(J.deriveJSON (sumTypeJSON $ dropPrefix "MTRE") ''MTRError) diff --git a/src/Simplex/Messaging/Agent/Store/Shared.hs b/src/Simplex/Messaging/Agent/Store/Shared.hs new file mode 100644 index 000000000..3921bf586 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Shared.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Agent.Store.Shared + ( Migration (..), + MigrationsToRun (..), + DownMigration (..), + MTRError (..), + mtrErrorDescription, + MigrationConfirmation (..), + MigrationError (..), + UpMigration (..), + migrationErrorDescription, + -- for tests + toDownMigration, + upMigration, + ) +where + +import qualified Data.Aeson.TH as J +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.List (intercalate) +import Data.Maybe (isJust) +import Data.Text (Text) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON) + +data Migration = Migration {name :: String, up :: Text, down :: Maybe Text} + deriving (Eq, Show) + +data DownMigration = DownMigration {downName :: String, downQuery :: Text} + deriving (Eq, Show) + +toDownMigration :: Migration -> Maybe DownMigration +toDownMigration Migration {name, down} = DownMigration name <$> down + +data MigrationsToRun = MTRUp [Migration] | MTRDown [DownMigration] | MTRNone + deriving (Eq, Show) + +data MTRError + = MTRENoDown {dbMigrations :: [String]} + | MTREDifferent {appMigration :: String, dbMigration :: String} + deriving (Eq, Show) + +mtrErrorDescription :: MTRError -> String +mtrErrorDescription = \case + MTRENoDown ms -> "database version is newer than the app, but no down migration for: " <> intercalate ", " ms + MTREDifferent a d -> "different migration in the app/database: " <> a <> " / " <> d + +data MigrationError + = MEUpgrade {upMigrations :: [UpMigration]} + | MEDowngrade {downMigrations :: [String]} + | MigrationError {mtrError :: MTRError} + deriving (Eq, Show) + +migrationErrorDescription :: MigrationError -> String +migrationErrorDescription = \case + MEUpgrade ums -> + "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums) + MEDowngrade dms -> + "Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms + MigrationError err -> mtrErrorDescription err + +data UpMigration = UpMigration {upName :: String, withDown :: Bool} + deriving (Eq, Show) + +upMigration :: Migration -> UpMigration +upMigration Migration {name, down} = UpMigration name $ isJust down + +data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError + deriving (Eq, Show) + +instance StrEncoding MigrationConfirmation where + strEncode = \case + MCYesUp -> "yesUp" + MCYesUpDown -> "yesUpDown" + MCConsole -> "console" + MCError -> "error" + strP = + A.takeByteString >>= \case + "yesUp" -> pure MCYesUp + "yesUpDown" -> pure MCYesUpDown + "console" -> pure MCConsole + "error" -> pure MCError + _ -> fail "invalid MigrationConfirmation" + +$(J.deriveJSON (sumTypeJSON $ dropPrefix "MTRE") ''MTRError) + +$(J.deriveJSON defaultJSON ''UpMigration) + +$(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index b281d8001..71000b60a 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -84,8 +85,8 @@ import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestSte import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT) import qualified Simplex.Messaging.Agent.Protocol as A -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) -import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') +import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction') +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (..), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) @@ -258,6 +259,7 @@ sendMessage c connId msgFlags msgBody = do liftIO $ pqEnc `shouldBe` PQEncOn pure msgId +-- TODO [postgres] run with postgres functionalAPITests :: ATransport -> Spec functionalAPITests t = do describe "Establishing duplex connection" $ do diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index 406bdef60..31ec79bf9 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/tests/AgentTests/MigrationTests.hs @@ -6,13 +6,16 @@ import Control.Monad import Data.Maybe (fromJust) import Data.Word (Word32) import Database.SQLite.Simple (fromOnly) -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError (MEDowngrade, MEUpgrade, MigrationError), SQLiteStore, closeSQLiteStore, createSQLiteStore, upMigration, withTransaction) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import Simplex.Messaging.Agent.Store.Migrations (migrationsToRun) +import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, createDBStore) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB -import Simplex.Messaging.Agent.Store.SQLite.Migrations +import Simplex.Messaging.Agent.Store.Shared import System.Directory (removeFile) import System.Random (randomIO) import Test.Hspec +-- TODO [postgres] run with postgres migrationTests :: Spec migrationTests = do it "should determine migrations to run" testMigrationsToRun @@ -178,20 +181,20 @@ testMigration :: testMigration (initMs, initTables) (finalMs, confirmModes, tablesOrError) = forM_ confirmModes $ \confirmMode -> do r <- randomIO :: IO Word32 let dpPath = testDB <> show r - Right st <- createSQLiteStore dpPath "" False initMs MCError + Right st <- createDBStore dpPath "" False initMs MCError st `shouldHaveTables` initTables - closeSQLiteStore st + closeDBStore st case tablesOrError of Right tables -> do - Right st' <- createSQLiteStore dpPath "" False finalMs confirmMode + Right st' <- createDBStore dpPath "" False finalMs confirmMode st' `shouldHaveTables` tables - closeSQLiteStore st' + closeDBStore st' Left e -> do - Left e' <- createSQLiteStore dpPath "" False finalMs confirmMode + Left e' <- createDBStore dpPath "" False finalMs confirmMode e `shouldBe` e' removeFile dpPath where - shouldHaveTables :: SQLiteStore -> [String] -> IO () + shouldHaveTables :: DBStore -> [String] -> IO () st `shouldHaveTables` expected = do tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT name FROM sqlite_schema WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY 1;") tables `shouldBe` "migrations" : expected diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 1e7cebff9..ce07d580a 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -61,7 +61,9 @@ import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMes import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT) -import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore, getSavedNtfToken, reopenSQLiteStore, withTransaction) +import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken) +import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, reopenSQLiteStore) +import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -500,7 +502,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 - closeSQLiteStore store + closeDBStore store threadDelay 1000000 putStrLn "before opening the database from another agent" diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 09356c5b6..3fb791af6 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -41,10 +41,12 @@ import Simplex.FileTransfer.Types import Simplex.Messaging.Agent.Client () import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store +import Simplex.Messaging.Agent.Store.AgentStore import Simplex.Messaging.Agent.Store.SQLite -import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') +import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction') import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn) @@ -59,36 +61,36 @@ import UnliftIO.Directory (removeFile) testDB :: String testDB = "tests/tmp/smp-agent.test.db" -withStore :: SpecWith SQLiteStore -> Spec -withStore = before createStore . after removeStore +withStore :: SpecWith DBStore -> Spec +withStore = before createStore' . after removeStore -withStore2 :: SpecWith (SQLiteStore, SQLiteStore) -> Spec +withStore2 :: SpecWith (DBStore, DBStore) -> Spec withStore2 = before connect2 . after (removeStore . fst) where - connect2 :: IO (SQLiteStore, SQLiteStore) + connect2 :: IO (DBStore, DBStore) connect2 = do - s1 <- createStore + s1 <- createStore' s2 <- connectSQLiteStore (dbFilePath s1) "" False pure (s1, s2) -createStore :: IO SQLiteStore -createStore = createEncryptedStore "" False +createStore' :: IO DBStore +createStore' = createEncryptedStore "" False -createEncryptedStore :: ScrubbedBytes -> Bool -> IO SQLiteStore +createEncryptedStore :: ScrubbedBytes -> Bool -> IO DBStore createEncryptedStore key keepKey = 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 - Right st <- createSQLiteStore (testDB <> show r) key keepKey Migrations.app MCError + Right st <- createDBStore (testDB <> show r) key keepKey Migrations.app MCError withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);") pure st -removeStore :: SQLiteStore -> IO () +removeStore :: DBStore -> IO () removeStore db = do close db removeFile $ dbFilePath db where - close :: SQLiteStore -> IO () + close :: DBStore -> IO () close st = mapM_ DB.close =<< tryTakeMVar (dbConnection st) storeTests :: Spec @@ -147,7 +149,7 @@ storeTests = do it "should close and re-open encrypted store" testCloseReopenEncryptedStore it "should close and re-open encrypted store (keep key)" testReopenEncryptedStoreKeepKey -testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore) +testConcurrentWrites :: SpecWith (DBStore, DBStore) testConcurrentWrites = it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do g <- C.newRandom @@ -156,22 +158,22 @@ testConcurrentWrites = let ConnData {connId} = cData1 concurrently_ (runTest s1 connId rq) (runTest s2 connId rq) where - runTest :: SQLiteStore -> ConnId -> RcvQueue -> IO () + runTest :: DBStore -> ConnId -> RcvQueue -> IO () runTest st connId rq = replicateM_ 100 . withTransaction st $ \db -> do (internalId, internalRcvId, _, _) <- updateRcvIds db connId let rcvMsgData = mkRcvMsgData internalId internalRcvId 0 "0" "hash_dummy" createRcvMsg db connId rq rcvMsgData -testCompiledThreadsafe :: SpecWith SQLiteStore +testCompiledThreadsafe :: SpecWith DBStore testCompiledThreadsafe = it "compiled sqlite library should be threadsafe" . withStoreTransaction $ \db -> do compileOptions <- DB.query_ db "pragma COMPILE_OPTIONS;" :: IO [[T.Text]] compileOptions `shouldNotContain` [["THREADSAFE=0"]] -withStoreTransaction :: (DB.Connection -> IO a) -> SQLiteStore -> IO a +withStoreTransaction :: (DB.Connection -> IO a) -> DBStore -> IO a withStoreTransaction = flip withTransaction -testForeignKeysEnabled :: SpecWith SQLiteStore +testForeignKeysEnabled :: SpecWith DBStore testForeignKeysEnabled = it "foreign keys should be enabled" . withStoreTransaction $ \db -> do let inconsistentQuery = @@ -261,7 +263,7 @@ createRcvConn db g cData rq cMode = runExceptT $ do rq' <- ExceptT $ updateNewConnRcv db connId rq pure (connId, rq') -testCreateRcvConn :: SpecWith SQLiteStore +testCreateRcvConn :: SpecWith DBStore testCreateRcvConn = it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -275,7 +277,7 @@ testCreateRcvConn = getConn db "conn1" `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq])) -testCreateRcvConnRandomId :: SpecWith SQLiteStore +testCreateRcvConnRandomId :: SpecWith DBStore testCreateRcvConnRandomId = it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -287,7 +289,7 @@ testCreateRcvConnRandomId = getConn db connId `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq] [sq])) -testCreateRcvConnDuplicate :: SpecWith SQLiteStore +testCreateRcvConnDuplicate :: SpecWith DBStore testCreateRcvConnDuplicate = it "should throw error on attempt to create duplicate RcvConnection" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -295,7 +297,7 @@ testCreateRcvConnDuplicate = createRcvConn db g cData1 rcvQueue1 SCMInvitation `shouldReturn` Left SEConnDuplicate -testCreateSndConn :: SpecWith SQLiteStore +testCreateSndConn :: SpecWith DBStore testCreateSndConn = it "should create SndConnection and add RcvQueue" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -309,7 +311,7 @@ testCreateSndConn = getConn db "conn1" `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rq] [sq])) -testCreateSndConnRandomID :: SpecWith SQLiteStore +testCreateSndConnRandomID :: SpecWith DBStore testCreateSndConnRandomID = it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -321,7 +323,7 @@ testCreateSndConnRandomID = getConn db connId `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 {connId} [rq] [sq])) -testCreateSndConnDuplicate :: SpecWith SQLiteStore +testCreateSndConnDuplicate :: SpecWith DBStore testCreateSndConnDuplicate = it "should throw error on attempt to create duplicate SndConnection" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -329,7 +331,7 @@ testCreateSndConnDuplicate = createSndConn db g cData1 sndQueue1 `shouldReturn` Left SEConnDuplicate -testGetRcvConn :: SpecWith SQLiteStore +testGetRcvConn :: SpecWith DBStore testGetRcvConn = it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash @@ -339,7 +341,7 @@ testGetRcvConn = getRcvConn db smpServer recipientId `shouldReturn` Right (rq, SomeConn SCRcv (RcvConnection cData1 rq)) -testSetConnUserIdNewConn :: SpecWith SQLiteStore +testSetConnUserIdNewConn :: SpecWith DBStore testSetConnUserIdNewConn = it "should set user id for new connection" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -352,9 +354,9 @@ testSetConnUserIdNewConn = let ConnData {userId} = connData userId `shouldBe` newUserId _ -> do - expectationFailure "Failed to get connection" + expectationFailure "Failed to get connection" -testDeleteRcvConn :: SpecWith SQLiteStore +testDeleteRcvConn :: SpecWith DBStore testDeleteRcvConn = it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -366,7 +368,7 @@ testDeleteRcvConn = getConn db "conn1" `shouldReturn` Left SEConnNotFound -testDeleteSndConn :: SpecWith SQLiteStore +testDeleteSndConn :: SpecWith DBStore testDeleteSndConn = it "should create SndConnection and delete it" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -378,7 +380,7 @@ testDeleteSndConn = getConn db "conn1" `shouldReturn` Left SEConnNotFound -testDeleteDuplexConn :: SpecWith SQLiteStore +testDeleteDuplexConn :: SpecWith DBStore testDeleteDuplexConn = it "should create DuplexConnection and delete it" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -391,7 +393,7 @@ testDeleteDuplexConn = getConn db "conn1" `shouldReturn` Left SEConnNotFound -testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore +testUpgradeRcvConnToDuplex :: SpecWith DBStore testUpgradeRcvConnToDuplex = it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -420,7 +422,7 @@ testUpgradeRcvConnToDuplex = upgradeRcvConnToDuplex db "conn1" anotherSndQueue `shouldReturn` Left (SEBadConnType CDuplex) -testUpgradeSndConnToDuplex :: SpecWith SQLiteStore +testUpgradeSndConnToDuplex :: SpecWith DBStore testUpgradeSndConnToDuplex = it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -452,7 +454,7 @@ testUpgradeSndConnToDuplex = upgradeSndConnToDuplex db "conn1" anotherRcvQueue `shouldReturn` Left (SEBadConnType CDuplex) -testSetRcvQueueStatus :: SpecWith SQLiteStore +testSetRcvQueueStatus :: SpecWith DBStore testSetRcvQueueStatus = it "should update status of RcvQueue" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -464,7 +466,7 @@ testSetRcvQueueStatus = getConn db "conn1" `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rq {status = Confirmed})) -testSetSndQueueStatus :: SpecWith SQLiteStore +testSetSndQueueStatus :: SpecWith DBStore testSetSndQueueStatus = it "should update status of SndQueue" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -476,7 +478,7 @@ testSetSndQueueStatus = getConn db "conn1" `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sq {status = Confirmed})) -testSetQueueStatusDuplex :: SpecWith SQLiteStore +testSetQueueStatusDuplex :: SpecWith DBStore testSetQueueStatusDuplex = it "should update statuses of RcvQueue and SndQueue in DuplexConnection" . withStoreTransaction $ \db -> do g <- C.newRandom @@ -529,7 +531,7 @@ testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rq rcvMsgData@Rcv createRcvMsg db connId rq rcvMsgData `shouldReturn` () -testCreateRcvMsg :: SpecWith SQLiteStore +testCreateRcvMsg :: SpecWith DBStore testCreateRcvMsg = it "should reserve internal ids and create a RcvMsg" $ \st -> do g <- C.newRandom @@ -563,7 +565,7 @@ testCreateSndMsg_ db expectedPrevHash connId sq sndMsgData@SndMsgData {..} = do createSndMsgDelivery db connId sq internalId `shouldReturn` () -testCreateSndMsg :: SpecWith SQLiteStore +testCreateSndMsg :: SpecWith DBStore testCreateSndMsg = it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \st -> do g <- C.newRandom @@ -574,7 +576,7 @@ testCreateSndMsg = testCreateSndMsg_ db "" connId sq $ mkSndMsgData (InternalId 1) (InternalSndId 1) "hash_dummy" testCreateSndMsg_ db "hash_dummy" connId sq $ mkSndMsgData (InternalId 2) (InternalSndId 2) "new_hash_dummy" -testCreateRcvAndSndMsgs :: SpecWith SQLiteStore +testCreateRcvAndSndMsgs :: SpecWith DBStore testCreateRcvAndSndMsgs = it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \st -> do let ConnData {connId} = cData1 @@ -592,15 +594,15 @@ testCreateRcvAndSndMsgs = testCloseReopenStore :: IO () testCloseReopenStore = do - st <- createStore + st <- createStore' hasMigrations st - closeSQLiteStore st - closeSQLiteStore st + closeDBStore st + closeDBStore st errorGettingMigrations st openSQLiteStore st "" False openSQLiteStore st "" False hasMigrations st - closeSQLiteStore st + closeDBStore st errorGettingMigrations st reopenSQLiteStore st hasMigrations st @@ -610,14 +612,14 @@ testCloseReopenEncryptedStore = do let key = "test_key" st <- createEncryptedStore key False hasMigrations st - closeSQLiteStore st - closeSQLiteStore st + closeDBStore st + closeDBStore st errorGettingMigrations st reopenSQLiteStore st `shouldThrow` \(e :: SomeException) -> "reopenSQLiteStore: no key" `isInfixOf` show e openSQLiteStore st key True openSQLiteStore st key True hasMigrations st - closeSQLiteStore st + closeDBStore st errorGettingMigrations st reopenSQLiteStore st hasMigrations st @@ -627,21 +629,21 @@ testReopenEncryptedStoreKeepKey = do let key = "test_key" st <- createEncryptedStore key True hasMigrations st - closeSQLiteStore st + closeDBStore st errorGettingMigrations st reopenSQLiteStore st hasMigrations st -getMigrations :: SQLiteStore -> IO Bool -getMigrations st = not . null <$> withTransaction st (Migrations.getCurrent . DB.conn) +getMigrations :: DBStore -> IO Bool +getMigrations st = not . null <$> withTransaction st Migrations.getCurrent -hasMigrations :: SQLiteStore -> Expectation +hasMigrations :: DBStore -> Expectation hasMigrations st = getMigrations st `shouldReturn` True -errorGettingMigrations :: SQLiteStore -> Expectation +errorGettingMigrations :: DBStore -> Expectation errorGettingMigrations st = getMigrations st `shouldThrow` \(e :: SomeException) -> "ErrorMisuse" `isInfixOf` show e -testGetPendingQueueMsg :: SQLiteStore -> Expectation +testGetPendingQueueMsg :: DBStore -> Expectation testGetPendingQueueMsg st = do g <- C.newRandom withTransaction st $ \db -> do @@ -658,7 +660,7 @@ testGetPendingQueueMsg st = do Right (Just (Nothing, PendingMsgData {msgId})) <- getPendingQueueMsg db connId sq msgId `shouldBe` InternalId 2 -testGetPendingServerCommand :: SQLiteStore -> Expectation +testGetPendingServerCommand :: DBStore -> Expectation testGetPendingServerCommand st = do g <- C.newRandom withTransaction st $ \db -> do @@ -728,7 +730,7 @@ testFileCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu" testFileReplicaKey :: C.APrivateAuthKey testFileReplicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" -testGetNextRcvChunkToDownload :: SQLiteStore -> Expectation +testGetNextRcvChunkToDownload :: DBStore -> Expectation testGetNextRcvChunkToDownload st = do g <- C.newRandom withTransaction st $ \db -> do @@ -745,7 +747,7 @@ testGetNextRcvChunkToDownload st = do Right (Just (RcvFileChunk {rcvFileEntityId}, _, Nothing)) <- getNextRcvChunkToDownload db xftpServer1 86400 rcvFileEntityId `shouldBe` fId2 -testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation +testGetNextRcvFileToDecrypt :: DBStore -> Expectation testGetNextRcvFileToDecrypt st = do g <- C.newRandom withTransaction st $ \db -> do @@ -764,7 +766,7 @@ testGetNextRcvFileToDecrypt st = do Right (Just RcvFile {rcvFileEntityId}) <- getNextRcvFileToDecrypt db 86400 rcvFileEntityId `shouldBe` fId2 -testGetNextSndFileToPrepare :: SQLiteStore -> Expectation +testGetNextSndFileToPrepare :: DBStore -> Expectation testGetNextSndFileToPrepare st = do g <- C.newRandom withTransaction st $ \db -> do @@ -791,7 +793,7 @@ newSndChunkReplica1 = rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)] } -testGetNextSndChunkToUpload :: SQLiteStore -> Expectation +testGetNextSndChunkToUpload :: DBStore -> Expectation testGetNextSndChunkToUpload st = do g <- C.newRandom withTransaction st $ \db -> do @@ -814,7 +816,7 @@ testGetNextSndChunkToUpload st = do Right (Just SndFileChunk {sndFileEntityId}) <- getNextSndChunkToUpload db xftpServer1 86400 sndFileEntityId `shouldBe` fId2 -testGetNextDeletedSndChunkReplica :: SQLiteStore -> Expectation +testGetNextDeletedSndChunkReplica :: DBStore -> Expectation testGetNextDeletedSndChunkReplica st = do withTransaction st $ \db -> do Right Nothing <- getNextDeletedSndChunkReplica db xftpServer1 86400 @@ -830,17 +832,17 @@ testGetNextDeletedSndChunkReplica st = do Right (Just DeletedSndChunkReplica {deletedSndChunkReplicaId}) <- getNextDeletedSndChunkReplica db xftpServer1 86400 deletedSndChunkReplicaId `shouldBe` 2 -testMarkNtfSubActionNtfFailed :: SQLiteStore -> Expectation +testMarkNtfSubActionNtfFailed :: DBStore -> Expectation testMarkNtfSubActionNtfFailed st = do withTransaction st $ \db -> do markNtfSubActionNtfFailed_ db "abc" -testMarkNtfSubActionSMPFailed :: SQLiteStore -> Expectation +testMarkNtfSubActionSMPFailed :: DBStore -> Expectation testMarkNtfSubActionSMPFailed st = do withTransaction st $ \db -> do markNtfSubActionSMPFailed_ db "abc" -testMarkNtfTokenToDeleteFailed :: SQLiteStore -> Expectation +testMarkNtfTokenToDeleteFailed :: DBStore -> Expectation testMarkNtfTokenToDeleteFailed st = do withTransaction st $ \db -> do markNtfTokenToDeleteFailed_ db 1 diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 3ee2774bc..ba344a4b1 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -12,8 +12,8 @@ import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL import Simplex.Messaging.Agent.Store.SQLite import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') -import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..), MigrationsToRun (..), toDownMigration) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import Simplex.Messaging.Util (ifM) import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive, removeFile) import System.Process (readCreateProcess, shell) @@ -37,6 +37,7 @@ appLint = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_lint.sql" testSchema :: FilePath testSchema = "tests/tmp/test_agent_schema.sql" +-- TODO [postgres] run with postgres schemaDumpTest :: Spec schemaDumpTest = do it "verify and overwrite schema dump" testVerifySchemaDump @@ -49,7 +50,7 @@ testVerifySchemaDump :: IO () testVerifySchemaDump = do savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "") savedSchema `deepseq` pure () - void $ createSQLiteStore testDB "" False Migrations.app MCConsole + void $ createDBStore testDB "" False Migrations.app MCConsole getSchema testDB appSchema `shouldReturn` savedSchema removeFile testDB @@ -57,7 +58,7 @@ testVerifyLintFKeyIndexes :: IO () testVerifyLintFKeyIndexes = do savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "") savedLint `deepseq` pure () - void $ createSQLiteStore testDB "" False Migrations.app MCConsole + void $ createDBStore testDB "" False Migrations.app MCConsole getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint removeFile testDB @@ -70,9 +71,9 @@ withTmpFiles = testSchemaMigrations :: IO () testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app - Right st <- createSQLiteStore testDB "" False noDownMigrations MCError + Right st <- createDBStore testDB "" False noDownMigrations MCError mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app - closeSQLiteStore st + closeDBStore st removeFile testDB removeFile testSchema where @@ -93,22 +94,22 @@ testSchemaMigrations = do testUsersMigrationNew :: IO () testUsersMigrationNew = do - Right st <- createSQLiteStore testDB "" False Migrations.app MCError + Right st <- createDBStore testDB "" False Migrations.app MCError withTransaction' st (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([] :: [Only Int]) - closeSQLiteStore st + closeDBStore st testUsersMigrationOld :: IO () testUsersMigrationOld = do let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app - Right st <- createSQLiteStore testDB "" False beforeUsers MCError + Right st <- createDBStore testDB "" False beforeUsers MCError withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';") `shouldReturn` ([] :: [Only String]) - closeSQLiteStore st - Right st' <- createSQLiteStore testDB "" False Migrations.app MCYesUp + closeDBStore st + Right st' <- createDBStore testDB "" False Migrations.app MCYesUp withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([Only (1 :: Int)]) - closeSQLiteStore st' + closeDBStore st' skipComparisonForDownMigrations :: [String] skipComparisonForDownMigrations = From cf66aadc206fbce1a8116b663adac2c3f1890e30 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 20 Dec 2024 15:54:58 +0400 Subject: [PATCH 03/51] postgres: store implementation, conditional compilation (#1421) * postgres: implementation wip * to from field * agent store compiles * methods * create store * tests wip * migration tests pass * tests compile * fix tests * tests wip * bool int * tests wip * tests wip * more boolint * more fixes * more fields pass * more fixes * binary * instances, binary * test passes * remove todos, more tests pass * fix conflict * fix bool * fix sequence breaking * fix insertedRowId * skip ratchet re-synchronization tests * after test * file tests * after test * rename * remove comment * format * remove unused * suppress notices * fixes * move * fix * instance * instance2 * fix * instances * comment --------- Co-authored-by: Evgeny Poberezkin --- simplexmq.cabal | 28 +- src/Simplex/FileTransfer/Description.hs | 23 +- src/Simplex/FileTransfer/Types.hs | 10 +- src/Simplex/Messaging/Agent/Client.hs | 13 +- src/Simplex/Messaging/Agent/Env/SQLite.hs | 4 +- src/Simplex/Messaging/Agent/Protocol.hs | 13 +- src/Simplex/Messaging/Agent/Stats.hs | 12 +- src/Simplex/Messaging/Agent/Store.hs | 7 +- .../Messaging/Agent/Store/AgentStore.hs | 429 ++++++++++-------- src/Simplex/Messaging/Agent/Store/Postgres.hs | 106 +++-- .../Messaging/Agent/Store/Postgres/Common.hs | 2 +- .../Messaging/Agent/Store/Postgres/DB.hs | 39 +- .../Agent/Store/Postgres/Migrations.hs | 44 +- .../Postgres/Migrations/M20241210_initial.hs | 305 ++++++------- .../Messaging/Agent/Store/Postgres/Util.hs | 111 +++++ src/Simplex/Messaging/Agent/Store/SQLite.hs | 11 +- .../Messaging/Agent/Store/SQLite/DB.hs | 29 +- src/Simplex/Messaging/Crypto.hs | 58 ++- src/Simplex/Messaging/Crypto/Ratchet.hs | 35 +- .../Messaging/Crypto/SNTRUP761/Bindings.hs | 14 +- .../Messaging/Notifications/Protocol.hs | 10 +- src/Simplex/Messaging/Notifications/Types.hs | 17 +- src/Simplex/Messaging/Parsers.hs | 34 +- tests/AgentTests.hs | 24 +- tests/AgentTests/FunctionalAPITests.hs | 35 +- tests/AgentTests/MigrationTests.hs | 66 ++- tests/AgentTests/NotificationTests.hs | 6 - tests/AgentTests/SchemaDump.hs | 1 - tests/CoreTests/StoreLogTests.hs | 13 +- tests/Fixtures.hs | 16 + tests/SMPAgentClient.hs | 13 + tests/SMPProxyTests.hs | 9 + tests/ServerTests.hs | 6 +- tests/Test.hs | 15 +- tests/Util.hs | 8 +- tests/XFTPAgent.hs | 74 +-- 36 files changed, 1076 insertions(+), 564 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Util.hs create mode 100644 tests/Fixtures.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 81f5ee808..84a4cc927 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -154,6 +154,9 @@ library Simplex.Messaging.Agent.Store.Postgres.DB Simplex.Messaging.Agent.Store.Postgres.Migrations Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial + if !flag(client_library) + exposed-modules: + Simplex.Messaging.Agent.Store.Postgres.Util else exposed-modules: Simplex.Messaging.Agent.Store.SQLite @@ -260,7 +263,6 @@ library , crypton-x509-validation ==1.6.* , cryptostore ==0.3.* , data-default ==0.7.* - , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* , hourglass ==0.2.* @@ -280,7 +282,6 @@ library , random >=1.1 && <1.3 , simple-logger ==0.1.* , socks ==0.6.* - , sqlcipher-simple ==0.4.* , stm ==2.5.* , temporary ==1.3.* , time ==1.12.* @@ -301,9 +302,14 @@ library , hashable ==1.4.* if flag(client_postgres) build-depends: - postgresql-simple ==0.6.* + postgresql-libpq >=0.10.0.0 + , postgresql-simple ==0.7.* , raw-strings-qq ==1.1.* cpp-options: -DdbPostgres + else + build-depends: + direct-sqlcipher ==2.3.* + , sqlcipher-simple ==0.4.* if impl(ghc >= 9.6.2) build-depends: bytestring ==0.11.* @@ -406,10 +412,7 @@ test-suite simplexmq-test AgentTests.EqInstances AgentTests.FunctionalAPITests AgentTests.MigrationTests - AgentTests.NotificationTests - AgentTests.SchemaDump AgentTests.ServerChoice - AgentTests.SQLiteTests CLITests CoreTests.BatchingTests CoreTests.CryptoFileTests @@ -423,6 +426,7 @@ test-suite simplexmq-test CoreTests.UtilTests CoreTests.VersionRangeTests FileDescriptionTests + Fixtures NtfClient NtfServerTests RemoteControl @@ -438,6 +442,11 @@ test-suite simplexmq-test Static Static.Embedded Paths_simplexmq + if !flag(client_postgres) + other-modules: + AgentTests.NotificationTests + AgentTests.SchemaDump + AgentTests.SQLiteTests hs-source-dirs: tests apps/smp-server/web @@ -478,7 +487,6 @@ test-suite simplexmq-test , silently ==1.2.* , simple-logger , simplexmq - , sqlcipher-simple , stm , text , time @@ -495,6 +503,10 @@ test-suite simplexmq-test default-language: Haskell2010 if flag(client_postgres) build-depends: - postgresql-simple ==0.6.* + postgresql-libpq >=0.10.0.0 + , postgresql-simple ==0.7.* , raw-strings-qq ==1.1.* cpp-options: -DdbPostgres + else + build-depends: + sqlcipher-simple diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index 8cb98fd32..11ca98edc 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} @@ -9,6 +10,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -62,17 +64,23 @@ import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Word (Word32) import qualified Data.Yaml as Y -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Protocol import Simplex.Messaging.Agent.QueryString +import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, parseAll) import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>)) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif data FileDescription (p :: FileParty) = FileDescription { party :: SFileParty p, @@ -109,6 +117,9 @@ fdSeparator = "################################\n" newtype FileDigest = FileDigest {unFileDigest :: ByteString} deriving (Eq, Show) + deriving newtype (FromField) + +instance ToField FileDigest where toField (FileDigest s) = toField $ Binary s instance StrEncoding FileDigest where strEncode (FileDigest fd) = strEncode fd @@ -122,10 +133,6 @@ instance ToJSON FileDigest where toJSON = strToJSON toEncoding = strToJEncoding -instance FromField FileDigest where fromField f = FileDigest <$> fromField f - -instance ToField FileDigest where toField (FileDigest s) = toField s - data FileChunk = FileChunk { chunkNo :: Int, chunkSize :: FileSize Word32, @@ -288,9 +295,9 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where instance (Integral a, Show a) => IsString (FileSize a) where fromString = either error id . strDecode . B.pack -instance FromField a => FromField (FileSize a) where fromField f = FileSize <$> fromField f +deriving newtype instance FromField a => FromField (FileSize a) -instance ToField a => ToField (FileSize a) where toField (FileSize s) = toField s +deriving newtype instance ToField a => ToField (FileSize a) groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [NonEmpty FileServerReplica] groupReplicasByServer defChunkSize = diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index 8569bdd12..f45ac75f8 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -13,8 +14,6 @@ import Data.Int (Int64) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Word (Word32) -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description import qualified Simplex.Messaging.Crypto as C @@ -24,6 +23,13 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol (XFTPServer) import System.FilePath (()) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif type RcvFileId = ByteString -- Agent entity ID diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 8068f171f..5d5e6fcaf 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -205,7 +206,6 @@ import Data.Text.Encoding import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Data.Time.Clock.System (getSystemTime) import Data.Word (Word16) -import qualified Database.SQLite.Simple as SQL import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) import qualified Simplex.FileTransfer.Client as X @@ -282,6 +282,9 @@ import UnliftIO.Concurrent (forkIO, mkWeakThreadId) import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile) import qualified UnliftIO.Exception as E import UnliftIO.STM +#if !defined(dbPostgres) +import qualified Database.SQLite.Simple as SQL +#endif type ClientVar msg = SessionVar (Either (AgentErrorType, Maybe UTCTime) (Client msg)) @@ -1989,6 +1992,13 @@ withStore c action = do withExceptT storeError . ExceptT . liftIO . agentOperationBracket c AODatabase (\_ -> pure ()) $ withTransaction st action `E.catches` handleDBErrors where +#if defined(dbPostgres) + -- TODO [postgres] postgres specific error handling + handleDBErrors :: [E.Handler IO (Either StoreError a)] + handleDBErrors = + [ E.Handler $ \(E.SomeException e) -> pure . Left $ SEInternal $ bshow e + ] +#else handleDBErrors :: [E.Handler IO (Either StoreError a)] handleDBErrors = [ E.Handler $ \(e :: SQL.SQLError) -> @@ -1997,6 +2007,7 @@ withStore c action = do in pure . Left . (if busy then SEDatabaseBusy else SEInternal) $ bshow se, E.Handler $ \(E.SomeException e) -> pure . Left $ SEInternal $ bshow e ] +#endif withStoreBatch :: Traversable t => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> AM' (t (Either AgentErrorType a)) withStoreBatch c actions = do diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index b6a3830c7..80a307efa 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -88,6 +88,7 @@ import System.Mem.Weak (Weak) import System.Random (StdGen, newStdGen) import UnliftIO.STM #if defined(dbPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..)) #else import Data.ByteArray (ScrubbedBytes) #endif @@ -277,8 +278,7 @@ newSMPAgentEnv config store = do pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers} #if defined(dbPostgres) --- TODO [postgres] pass db name / ConnectInfo? -createAgentStore :: MigrationConfirmation -> IO (Either MigrationError DBStore) +createAgentStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore) createAgentStore = createStore #else createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 08e8add24..b87f87f18 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -167,13 +168,12 @@ import Data.Time.Clock.System (SystemTime) import Data.Type.Equality import Data.Typeable () import Data.Word (Word16, Word32) -import Database.SQLite.Simple.FromField -import Database.SQLite.Simple.ToField import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Transport (XFTPErrorType) import Simplex.FileTransfer.Types (FileErrorType) import Simplex.Messaging.Agent.QueryString +import Simplex.Messaging.Agent.Store.DB (Binary (..)) import Simplex.Messaging.Client (ProxyClientError) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet @@ -224,6 +224,13 @@ import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import Simplex.RemoteControl.Types import UnliftIO.Exception (Exception) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif -- SMP agent protocol version history: -- 1 - binary protocol encoding (1/1/2022) @@ -644,7 +651,7 @@ instance ToJSON NotificationsMode where instance FromJSON NotificationsMode where parseJSON = strParseJSON "NotificationsMode" -instance ToField NotificationsMode where toField = toField . strEncode +instance ToField NotificationsMode where toField = toField . Binary . strEncode instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseAll strP diff --git a/src/Simplex/Messaging/Agent/Stats.hs b/src/Simplex/Messaging/Agent/Stats.hs index d4663bfb1..1d174622e 100644 --- a/src/Simplex/Messaging/Agent/Stats.hs +++ b/src/Simplex/Messaging/Agent/Stats.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} @@ -10,13 +11,18 @@ import qualified Data.Aeson.TH as J import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Messaging.Agent.Protocol (UserId) import Simplex.Messaging.Parsers (defaultJSON, fromTextField_) -import Simplex.Messaging.Protocol (SMPServer, XFTPServer, NtfServer) +import Simplex.Messaging.Protocol (NtfServer, SMPServer, XFTPServer) import Simplex.Messaging.Util (decodeJSON, encodeJSON) import UnliftIO.STM +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif data AgentSMPServerStats = AgentSMPServerStats { sentDirect :: TVar Int, -- successfully sent messages diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 1f21c7e71..c199e480b 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -55,15 +55,16 @@ import Simplex.Messaging.Protocol ) import qualified Simplex.Messaging.Protocol as SMP #if defined(dbPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..)) import qualified Simplex.Messaging.Agent.Store.Postgres as StoreFunctions #else -import qualified Simplex.Messaging.Agent.Store.SQLite as StoreFunctions import Data.ByteArray (ScrubbedBytes) +import qualified Simplex.Messaging.Agent.Store.SQLite as StoreFunctions #endif #if defined(dbPostgres) -createStore :: MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore = StoreFunctions.createDBStore Migrations.app +createStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createStore connectInfo schema = StoreFunctions.createDBStore connectInfo schema Migrations.app #else createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore) createStore dbFilePath dbKey keepKey = StoreFunctions.createDBStore dbFilePath dbKey keepKey Migrations.app diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index a2ecab6ea..c339b7a01 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -18,7 +19,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -249,11 +249,6 @@ import Data.Ord (Down (..)) import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Word (Word32) -import Database.SQLite.Simple (FromRow (..), NamedParam (..), Only (..), Query (..), SQLError, ToRow (..), field, (:.) (..)) -import qualified Database.SQLite.Simple as SQL -import Database.SQLite.Simple.FromField -import Database.SQLite.Simple.QQ (sql) -import Database.SQLite.Simple.ToField (ToField (..)) import Network.Socket (ServiceName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description @@ -265,6 +260,7 @@ import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.Common import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys) @@ -281,14 +277,34 @@ import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, tshow, import Simplex.Messaging.Version.Internal import qualified UnliftIO.Exception as E import UnliftIO.STM +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..), Query, SqlError, (:.) (..)) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.Errors (constraintViolation) +import Database.PostgreSQL.Simple.SqlQQ (sql) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple (FromRow (..), Only (..), Query (..), SQLError, ToRow (..), field, (:.) (..)) +import qualified Database.SQLite.Simple as SQL +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.QQ (sql) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a) checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err) +#if defined(dbPostgres) +handleSQLError :: StoreError -> SqlError -> StoreError +handleSQLError err e = case constraintViolation e of + Just _ -> err + Nothing -> SEInternal $ bshow e +#else handleSQLError :: StoreError -> SQLError -> StoreError handleSQLError err e | SQL.sqlError e == SQL.ErrorConstraint = err | otherwise = SEInternal $ bshow e +#endif createUserRecord :: DB.Connection -> IO UserId createUserRecord db = do @@ -298,7 +314,7 @@ createUserRecord db = do checkUser :: DB.Connection -> UserId -> IO (Either StoreError ()) checkUser db userId = firstRow (\(_ :: Only Int64) -> ()) SEUserNotFound $ - DB.query db "SELECT user_id FROM users WHERE user_id = ? AND deleted = ?" (userId, False) + DB.query db "SELECT user_id FROM users WHERE user_id = ? AND deleted = ?" (userId, BI False) deleteUserRecord :: DB.Connection -> UserId -> IO (Either StoreError ()) deleteUserRecord db userId = runExceptT $ do @@ -309,7 +325,7 @@ setUserDeleted :: DB.Connection -> UserId -> IO (Either StoreError [ConnId]) setUserDeleted db userId = runExceptT $ do ExceptT $ checkUser db userId liftIO $ do - DB.execute db "UPDATE users SET deleted = ? WHERE user_id = ?" (True, userId) + DB.execute db "UPDATE users SET deleted = ? WHERE user_id = ?" (BI True, userId) map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE user_id = ?" (Only userId) deleteUserWithoutConns :: DB.Connection -> UserId -> IO Bool @@ -324,7 +340,7 @@ deleteUserWithoutConns db userId = do AND u.deleted = ? AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) |] - (userId, True) + (userId, BI True) case userId_ of Just _ -> DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) $> True _ -> pure False @@ -340,7 +356,7 @@ deleteUsersWithoutConns db = do WHERE u.deleted = ? AND NOT EXISTS (SELECT c.conn_id FROM connections c WHERE c.user_id = u.user_id) |] - (Only True) + (Only (BI True)) forM_ userIds $ DB.execute db "DELETE FROM users WHERE user_id = ?" . Only pure userIds @@ -394,7 +410,7 @@ createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSup INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake) VALUES (?,?,?,?,?,?,?) |] - (userId, connId, cMode, connAgentVersion, enableNtfs, pqSupport, True) + (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True) checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do @@ -481,14 +497,14 @@ addConnSndQueue_ db connId sq@SndQueue {server} = do setRcvQueueStatus :: DB.Connection -> RcvQueue -> QueueStatus -> IO () setRcvQueueStatus db RcvQueue {rcvId, server = ProtocolServer {host, port}} status = -- ? return error if queue does not exist? - DB.executeNamed + DB.execute db [sql| UPDATE rcv_queues - SET status = :status - WHERE host = :host AND port = :port AND rcv_id = :rcv_id; + SET status = ? + WHERE host = ? AND port = ? AND rcv_id = ? |] - [":status" := status, ":host" := host, ":port" := port, ":rcv_id" := rcvId] + (status, host, port, rcvId) setRcvSwitchStatus :: DB.Connection -> RcvQueue -> Maybe RcvSwitchStatus -> IO RcvQueue setRcvSwitchStatus db rq@RcvQueue {rcvId, server = ProtocolServer {host, port}} rcvSwchStatus = do @@ -515,34 +531,28 @@ setRcvQueueDeleted db RcvQueue {rcvId, server = ProtocolServer {host, port}} = d setRcvQueueConfirmedE2E :: DB.Connection -> RcvQueue -> C.DhSecretX25519 -> VersionSMPC -> IO () setRcvQueueConfirmedE2E db RcvQueue {rcvId, server = ProtocolServer {host, port}} e2eDhSecret smpClientVersion = - DB.executeNamed + DB.execute db [sql| UPDATE rcv_queues - SET e2e_dh_secret = :e2e_dh_secret, - status = :status, - smp_client_version = :smp_client_version - WHERE host = :host AND port = :port AND rcv_id = :rcv_id + SET e2e_dh_secret = ?, + status = ?, + smp_client_version = ? + WHERE host = ? AND port = ? AND rcv_id = ? |] - [ ":status" := Confirmed, - ":e2e_dh_secret" := e2eDhSecret, - ":smp_client_version" := smpClientVersion, - ":host" := host, - ":port" := port, - ":rcv_id" := rcvId - ] + (e2eDhSecret, Confirmed, smpClientVersion, host, port, rcvId) setSndQueueStatus :: DB.Connection -> SndQueue -> QueueStatus -> IO () setSndQueueStatus db SndQueue {sndId, server = ProtocolServer {host, port}} status = -- ? return error if queue does not exist? - DB.executeNamed + DB.execute db [sql| UPDATE snd_queues - SET status = :status - WHERE host = :host AND port = :port AND snd_id = :snd_id; + SET status = ? + WHERE host = ? AND port = ? AND snd_id = ? |] - [":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId] + (status, host, port, sndId) setSndSwitchStatus :: DB.Connection -> SndQueue -> Maybe SndSwitchStatus -> IO SndQueue setSndSwitchStatus db sq@SndQueue {sndId, server = ProtocolServer {host, port}} sndSwchStatus = do @@ -558,19 +568,19 @@ setSndSwitchStatus db sq@SndQueue {sndId, server = ProtocolServer {host, port}} setRcvQueuePrimary :: DB.Connection -> ConnId -> RcvQueue -> IO () setRcvQueuePrimary db connId RcvQueue {dbQueueId} = do - DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (False, connId) + DB.execute db "UPDATE rcv_queues SET rcv_primary = ? WHERE conn_id = ?" (BI False, connId) DB.execute db "UPDATE rcv_queues SET rcv_primary = ?, replace_rcv_queue_id = ? WHERE conn_id = ? AND rcv_queue_id = ?" - (True, Nothing :: Maybe Int64, connId, dbQueueId) + (BI True, Nothing :: Maybe Int64, connId, dbQueueId) setSndQueuePrimary :: DB.Connection -> ConnId -> SndQueue -> IO () setSndQueuePrimary db connId SndQueue {dbQueueId} = do - DB.execute db "UPDATE snd_queues SET snd_primary = ? WHERE conn_id = ?" (False, connId) + DB.execute db "UPDATE snd_queues SET snd_primary = ? WHERE conn_id = ?" (BI False, connId) DB.execute db "UPDATE snd_queues SET snd_primary = ?, replace_snd_queue_id = ? WHERE conn_id = ? AND snd_queue_id = ?" - (True, Nothing :: Maybe Int64, connId, dbQueueId) + (BI True, Nothing :: Maybe Int64, connId, dbQueueId) incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO () incRcvDeleteErrors db RcvQueue {connId, dbQueueId} = @@ -592,12 +602,12 @@ getPrimaryRcvQueue db connId = getRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue) getRcvQueue db connId (SMPServer host port _) rcvId = firstRow toRcvQueue SEConnNotFound $ - DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (connId, host, port, rcvId) + DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 0") (connId, host, port, rcvId) getDeletedRcvQueue :: DB.Connection -> ConnId -> SMPServer -> SMP.RecipientId -> IO (Either StoreError RcvQueue) getDeletedRcvQueue db connId (SMPServer host port _) rcvId = firstRow toRcvQueue SEConnNotFound $ - DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 1") (connId, host, port, rcvId) + DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.host = ? AND q.port = ? AND q.rcv_id = ? AND q.deleted = 1") (connId, host, port, rcvId) setRcvQueueNtfCreds :: DB.Connection -> ConnId -> Maybe ClientNtfCreds -> IO () setRcvQueueNtfCreds db connId clientNtfCreds = @@ -635,21 +645,19 @@ createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation INSERT INTO conn_confirmations (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, smp_client_version, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, ?, 0); |] - (confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues, smpClientVersion) + (Binary confirmationId, connId, senderKey, e2ePubKey, ratchetState, Binary connInfo, smpReplyQueues, smpClientVersion) acceptConfirmation :: DB.Connection -> ConfirmationId -> ConnInfo -> IO (Either StoreError AcceptedConfirmation) acceptConfirmation db confirmationId ownConnInfo = do - DB.executeNamed + DB.execute db [sql| UPDATE conn_confirmations SET accepted = 1, - own_conn_info = :own_conn_info - WHERE confirmation_id = :confirmation_id; + own_conn_info = ? + WHERE confirmation_id = ? |] - [ ":own_conn_info" := ownConnInfo, - ":confirmation_id" := confirmationId - ] + (Binary ownConnInfo, Binary confirmationId) firstRow confirmation SEConfirmationNotFound $ DB.query db @@ -658,7 +666,7 @@ acceptConfirmation db confirmationId ownConnInfo = do FROM conn_confirmations WHERE confirmation_id = ?; |] - (Only confirmationId) + (Only (Binary confirmationId)) where confirmation ((connId, ratchetState) :. confRow) = AcceptedConfirmation @@ -692,13 +700,13 @@ getAcceptedConfirmation db connId = removeConfirmations :: DB.Connection -> ConnId -> IO () removeConfirmations db connId = - DB.executeNamed + DB.execute db [sql| DELETE FROM conn_confirmations - WHERE conn_id = :conn_id; + WHERE conn_id = ? |] - [":conn_id" := connId] + (Only connId) createInvitation :: DB.Connection -> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId) createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo} = @@ -709,7 +717,7 @@ createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInf INSERT INTO conn_invitations (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0); |] - (invitationId, contactConnId, connReq, recipientConnInfo) + (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo) getInvitation :: DB.Connection -> String -> InvitationId -> IO (Either StoreError Invitation) getInvitation db cxt invitationId = @@ -722,34 +730,32 @@ getInvitation db cxt invitationId = WHERE invitation_id = ? AND accepted = 0 |] - (Only invitationId) + (Only (Binary invitationId)) where - invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted) = + invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, BI accepted) = Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted} acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO () acceptInvitation db invitationId ownConnInfo = - DB.executeNamed + DB.execute db [sql| UPDATE conn_invitations SET accepted = 1, - own_conn_info = :own_conn_info - WHERE invitation_id = :invitation_id + own_conn_info = ? + WHERE invitation_id = ? |] - [ ":own_conn_info" := ownConnInfo, - ":invitation_id" := invitationId - ] + (Binary ownConnInfo, Binary invitationId) unacceptInvitation :: DB.Connection -> InvitationId -> IO () unacceptInvitation db invitationId = - DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only invitationId) + DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only (Binary invitationId)) deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ()) deleteInvitation db contactConnId invId = getConn db contactConnId $>>= \case SomeConn SCContact _ -> - Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, invId) + Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId) _ -> pure $ Left SEConnNotFound updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) @@ -919,7 +925,7 @@ setMsgUserAck db connId agentMsgId = runExceptT $ do ExceptT . firstRow id SEMsgNotFound $ DB.query db "SELECT rcv_queue_id, broker_id FROM rcv_messages WHERE conn_id = ? AND internal_id = ?" (connId, agentMsgId) rq <- ExceptT $ getRcvQueueById db connId dbRcvId - liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (True, connId, agentMsgId) + liftIO $ DB.execute db "UPDATE rcv_messages SET user_ack = ? WHERE conn_id = ? AND internal_id = ?" (BI True, connId, agentMsgId) pure (rq, srvMsgId) getRcvMsg :: DB.Connection -> ConnId -> InternalId -> IO (Either StoreError RcvMsg) @@ -953,10 +959,10 @@ getLastMsg db connId msgId = LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id WHERE r.conn_id = ? AND r.broker_id = ? |] - (connId, msgId) + (connId, Binary msgId) -toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg -toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, userAck)) = +toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, BoolInt) -> RcvMsg +toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, BI userAck)) = let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity, pqEncryption} msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_ in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck} @@ -969,13 +975,13 @@ checkRcvMsgHashExists db connId hash = do ( DB.query db "SELECT 1 FROM encrypted_rcv_message_hashes WHERE conn_id = ? AND hash = ? LIMIT 1" - (connId, hash) + (connId, Binary hash) ) getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs) getRcvMsgBrokerTs db connId msgId = firstRow fromOnly SEMsgNotFound $ - DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId) + DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, Binary msgId) deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO () deleteMsg db connId msgId = @@ -983,7 +989,11 @@ deleteMsg db connId msgId = deleteMsgContent :: DB.Connection -> ConnId -> InternalId -> IO () deleteMsgContent db connId msgId = - DB.execute db "UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?;" (connId, msgId) +#if defined(dbPostgres) + DB.execute db "UPDATE messages SET msg_body = ''::BYTEA WHERE conn_id = ? AND internal_id = ?" (connId, msgId) +#else + DB.execute db "UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?" (connId, msgId) +#endif deleteDeliveredSndMsg :: DB.Connection -> ConnId -> InternalId -> IO () deleteDeliveredSndMsg db connId msgId = do @@ -1052,20 +1062,20 @@ setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = -- TODO remove the columns for public keys in v5.7. createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO () createRatchet db connId rc = - DB.executeNamed + DB.execute db [sql| INSERT INTO ratchets (conn_id, ratchet_state) - VALUES (:conn_id, :ratchet_state) + VALUES (?, ?) ON CONFLICT (conn_id) DO UPDATE SET - ratchet_state = :ratchet_state, + ratchet_state = ?, x3dh_priv_key_1 = NULL, x3dh_priv_key_2 = NULL, x3dh_pub_key_1 = NULL, x3dh_pub_key_2 = NULL, pq_priv_kem = NULL |] - [":conn_id" := connId, ":ratchet_state" := rc] + (connId, rc, rc) deleteRatchet :: DB.Connection -> ConnId -> IO () deleteRatchet db connId = @@ -1106,12 +1116,18 @@ createCommand db corrId connId srv_ cmd = runExceptT $ do DB.execute db "INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash, created_at) VALUES (?,?,?,?,?,?,?,?)" - (host_, port_, corrId, connId, cmdTag, cmd, serverKeyHash_, createdAt) + (host_, port_, Binary corrId, connId, cmdTag, cmd, serverKeyHash_, createdAt) where cmdTag = agentCommandTag cmd +#if defined(dbPostgres) + handleErr e = case constraintViolation e of + Just _ -> logError $ "tried to create command " <> tshow cmdTag <> " for deleted connection" + Nothing -> E.throwIO e +#else handleErr e | SQL.sqlError e == SQL.ErrorConstraint = logError $ "tried to create command " <> tshow cmdTag <> " for deleted connection" | otherwise = E.throwIO e +#endif serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash) serverFields = case srv_ of Just srv@(SMPServer host port _) -> @@ -1119,7 +1135,13 @@ createCommand db corrId connId srv_ cmd = runExceptT $ do Nothing -> pure (Nothing, Nothing, Nothing) insertedRowId :: DB.Connection -> IO Int64 -insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" +insertedRowId db = fromOnly . head <$> DB.query_ db q + where +#if defined(dbPostgres) + q = "SELECT lastval()" +#else + q = "SELECT last_insert_rowid()" +#endif getPendingCommandServers :: DB.Connection -> ConnId -> IO [Maybe SMPServer] getPendingCommandServers db connId = do @@ -1408,7 +1430,7 @@ supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHos WHERE conn_id = ? |] ( (smpHost, smpPort, ntfQueueId, ntfHost, ntfPort, ntfSubId) - :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId) + :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, BI True, ts, connId) ) where (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action @@ -1423,13 +1445,13 @@ supervisorUpdateNtfAction db connId action = do SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? WHERE conn_id = ? |] - (ntfSubAction, ntfSubSMPAction, ts, True, ts, connId) + (ntfSubAction, ntfSubSMPAction, ts, BI True, ts, connId) where (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action updateNtfSubscription :: DB.Connection -> NtfSubscription -> NtfSubAction -> NtfActionTs -> IO () updateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action actionTs = do - r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) + r <- maybeFirstRow fromOnlyBI $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) forM_ r $ \updatedBySupervisor -> do updatedAt <- getCurrentTime if updatedBySupervisor @@ -1441,7 +1463,7 @@ updateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfSe SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, updated_by_supervisor = ?, updated_at = ? WHERE conn_id = ? |] - (ntfQueueId, ntfSubId, ntfSubStatus, False, updatedAt, connId) + (ntfQueueId, ntfSubId, ntfSubStatus, BI False, updatedAt, connId) else DB.execute db @@ -1450,13 +1472,13 @@ updateNtfSubscription db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfSe SET smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? WHERE conn_id = ? |] - ((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, False, updatedAt, connId)) + ((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, actionTs, BI False, updatedAt, connId)) where (ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action setNullNtfSubscriptionAction :: DB.Connection -> ConnId -> IO () setNullNtfSubscriptionAction db connId = do - r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) + r <- maybeFirstRow fromOnlyBI $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) forM_ r $ \updatedBySupervisor -> unless updatedBySupervisor $ do updatedAt <- getCurrentTime @@ -1467,11 +1489,11 @@ setNullNtfSubscriptionAction db connId = do SET ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ? WHERE conn_id = ? |] - (Nothing :: Maybe NtfSubNTFAction, Nothing :: Maybe NtfSubSMPAction, Nothing :: Maybe UTCTime, False, updatedAt, connId) + (Nothing :: Maybe NtfSubNTFAction, Nothing :: Maybe NtfSubSMPAction, Nothing :: Maybe UTCTime, BI False, updatedAt, connId) deleteNtfSubscription :: DB.Connection -> ConnId -> IO () deleteNtfSubscription db connId = do - r <- maybeFirstRow fromOnly $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) + r <- maybeFirstRow fromOnlyBI $ DB.query db "SELECT updated_by_supervisor FROM ntf_subscriptions WHERE conn_id = ?" (Only connId) forM_ r $ \updatedBySupervisor -> do updatedAt <- getCurrentTime if updatedBySupervisor @@ -1483,7 +1505,7 @@ deleteNtfSubscription db connId = do SET smp_ntf_id = ?, ntf_sub_id = ?, ntf_sub_status = ?, updated_by_supervisor = ?, updated_at = ? WHERE conn_id = ? |] - (Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, False, updatedAt, connId) + (Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, BI False, updatedAt, connId) else deleteNtfSubscription' db connId deleteNtfSubscription' :: DB.Connection -> ConnId -> IO () @@ -1620,7 +1642,7 @@ getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO () setConnectionNtfs db connId enableNtfs = - DB.execute db "UPDATE connections SET enable_ntfs = ? WHERE conn_id = ?" (enableNtfs, connId) + DB.execute db "UPDATE connections SET enable_ntfs = ? WHERE conn_id = ?" (BI enableNtfs, connId) -- * Auxiliary helpers @@ -1630,37 +1652,42 @@ instance FromField QueueStatus where fromField = fromTextField_ queueStatusT instance ToField (DBQueueId 'QSStored) where toField (DBQueueId qId) = toField qId -instance FromField (DBQueueId 'QSStored) where fromField x = DBQueueId <$> fromField x +instance FromField (DBQueueId 'QSStored) where +#if defined(dbPostgres) + fromField x dat = DBQueueId <$> fromField x dat +#else + fromField x = DBQueueId <$> fromField x +#endif instance ToField InternalRcvId where toField (InternalRcvId x) = toField x -instance FromField InternalRcvId where fromField x = InternalRcvId <$> fromField x +deriving newtype instance FromField InternalRcvId instance ToField InternalSndId where toField (InternalSndId x) = toField x -instance FromField InternalSndId where fromField x = InternalSndId <$> fromField x +deriving newtype instance FromField InternalSndId instance ToField InternalId where toField (InternalId x) = toField x -instance FromField InternalId where fromField x = InternalId <$> fromField x +deriving newtype instance FromField InternalId -instance ToField AgentMessageType where toField = toField . smpEncode +instance ToField AgentMessageType where toField = toField . Binary . smpEncode instance FromField AgentMessageType where fromField = blobFieldParser smpP -instance ToField MsgIntegrity where toField = toField . strEncode +instance ToField MsgIntegrity where toField = toField . Binary . strEncode instance FromField MsgIntegrity where fromField = blobFieldParser strP -instance ToField SMPQueueUri where toField = toField . strEncode +instance ToField SMPQueueUri where toField = toField . Binary . strEncode instance FromField SMPQueueUri where fromField = blobFieldParser strP -instance ToField AConnectionRequestUri where toField = toField . strEncode +instance ToField AConnectionRequestUri where toField = toField . Binary . strEncode instance FromField AConnectionRequestUri where fromField = blobFieldParser strP -instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . strEncode +instance ConnectionModeI c => ToField (ConnectionRequestUri c) where toField = toField . Binary . strEncode instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequestUri c) where fromField = blobFieldParser strP @@ -1676,7 +1703,7 @@ instance ToField MsgFlags where toField = toField . decodeLatin1 . smpEncode instance FromField MsgFlags where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 -instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList +instance ToField [SMPQueueInfo] where toField = toField . Binary . smpEncodeList instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP @@ -1684,11 +1711,11 @@ instance ToField (NonEmpty TransportHost) where toField = toField . decodeLatin1 instance FromField (NonEmpty TransportHost) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 -instance ToField AgentCommand where toField = toField . strEncode +instance ToField AgentCommand where toField = toField . Binary . strEncode instance FromField AgentCommand where fromField = blobFieldParser strP -instance ToField AgentCommandTag where toField = toField . strEncode +instance ToField AgentCommandTag where toField = toField . Binary . strEncode instance FromField AgentCommandTag where fromField = blobFieldParser strP @@ -1698,9 +1725,9 @@ instance FromField MsgReceiptStatus where fromField = fromTextField_ $ eitherToM instance ToField (Version v) where toField (Version v) = toField v -instance FromField (Version v) where fromField f = Version <$> fromField f +deriving newtype instance FromField (Version v) -deriving newtype instance ToField EntityId +instance ToField EntityId where toField (EntityId s) = toField $ Binary s deriving newtype instance FromField EntityId @@ -1718,9 +1745,14 @@ firstRow f e a = second f . listToEither e <$> a maybeFirstRow :: Functor f => (a -> b) -> f [a] -> f (Maybe b) maybeFirstRow f q = fmap f . listToMaybe <$> q +fromOnlyBI :: Only BoolInt -> Bool +fromOnlyBI (Only (BI b)) = b +{-# INLINE fromOnlyBI #-} + firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b) firstRow' f e a = (f <=< listToEither e) <$> a +#if !defined(dbPostgres) {- ORMOLU_DISABLE -} -- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries instance (FromField a, FromField b, FromField c, FromField d, FromField e, @@ -1748,6 +1780,7 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ] {- ORMOLU_ENABLE -} +#endif -- * Server helper @@ -1771,16 +1804,16 @@ getServerKeyHash_ db ProtocolServer {host, port, keyHash} = do upsertNtfServer_ :: DB.Connection -> NtfServer -> IO () upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do - DB.executeNamed + DB.execute db [sql| - INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash) VALUES (:host,:port,:key_hash) + INSERT INTO ntf_servers (ntf_host, ntf_port, ntf_key_hash) VALUES (?,?,?) ON CONFLICT (ntf_host, ntf_port) DO UPDATE SET ntf_host=excluded.ntf_host, ntf_port=excluded.ntf_port, ntf_key_hash=excluded.ntf_key_hash; |] - [":host" := host, ":port" := port, ":key_hash" := keyHash] + (host, port, keyHash) -- * createRcvConn helpers @@ -1796,7 +1829,7 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do INSERT INTO rcv_queues (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, sndSecure, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} -- * createSndConn helpers @@ -1810,10 +1843,29 @@ insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do DB.execute db [sql| - INSERT OR REPLACE INTO snd_queues - (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); + INSERT INTO snd_queues + (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, + status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ON CONFLICT (host, port, snd_id) DO UPDATE SET + host=EXCLUDED.host, + port=EXCLUDED.port, + snd_id=EXCLUDED.snd_id, + snd_secure=EXCLUDED.snd_secure, + conn_id=EXCLUDED.conn_id, + snd_public_key=EXCLUDED.snd_public_key, + snd_private_key=EXCLUDED.snd_private_key, + e2e_pub_key=EXCLUDED.e2e_pub_key, + e2e_dh_secret=EXCLUDED.e2e_dh_secret, + status=EXCLUDED.status, + snd_queue_id=EXCLUDED.snd_queue_id, + snd_primary=EXCLUDED.snd_primary, + replace_snd_queue_id=EXCLUDED.replace_snd_queue_id, + smp_client_version=EXCLUDED.smp_client_version, + server_key_hash=EXCLUDED.server_key_hash |] - ((host server, port server, sndId, sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, sndId, BI sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) + :. (status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId} newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored @@ -1875,8 +1927,8 @@ getConnData db connId' = |] (Only connId') where - cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport) = - (ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode) + cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport) = + (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode) setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO () setConnDeleted db waitDelivery connId @@ -1884,7 +1936,7 @@ setConnDeleted db waitDelivery connId currentTs <- getCurrentTime DB.execute db "UPDATE connections SET deleted_at_wait_delivery = ? WHERE conn_id = ?" (currentTs, connId) | otherwise = - DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId) + DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (BI True, connId) setConnUserId :: DB.Connection -> UserId -> ConnId -> UserId -> IO () setConnUserId db oldUserId connId newUserId = @@ -1899,7 +1951,7 @@ setConnPQSupport db connId pqSupport = DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId) getDeletedConnIds :: DB.Connection -> IO [ConnId] -getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True) +getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only (BI True)) getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId] getDeletedWaitingDeliveryConnIds db = @@ -1911,7 +1963,7 @@ setConnRatchetSync db connId ratchetSyncState = addProcessedRatchetKeyHash :: DB.Connection -> ConnId -> ByteString -> IO () addProcessedRatchetKeyHash db connId hash = - DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, hash) + DB.execute db "INSERT INTO processed_ratchet_key_hashes (conn_id, hash) VALUES (?,?)" (connId, Binary hash) checkRatchetKeyHashExists :: DB.Connection -> ConnId -> ByteString -> IO Bool checkRatchetKeyHashExists db connId hash = do @@ -1921,7 +1973,7 @@ checkRatchetKeyHashExists db connId hash = do ( DB.query db "SELECT 1 FROM processed_ratchet_key_hashes WHERE conn_id = ? AND hash = ? LIMIT 1" - (connId, hash) + (connId, Binary hash) ) deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO () @@ -1933,7 +1985,7 @@ deleteRatchetKeyHashesExpired db ttl = do getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue)) getRcvQueuesByConnId_ db connId = L.nonEmpty . sortBy primaryFirst . map toRcvQueue - <$> DB.query db (rcvQueueQuery <> "WHERE q.conn_id = ? AND q.deleted = 0") (Only connId) + <$> DB.query db (rcvQueueQuery <> " WHERE q.conn_id = ? AND q.deleted = 0") (Only connId) where primaryFirst RcvQueue {primary = p, dbReplaceQueueId = i} RcvQueue {primary = p', dbReplaceQueueId = i'} = -- the current primary queue is ordered first, the next primary - second @@ -1952,11 +2004,11 @@ rcvQueueQuery = |] toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, SenderCanSecure) - :. (QueueStatus, DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, BoolInt) + :. (QueueStatus, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue -toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure) :. (status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = +toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure) :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of @@ -1973,7 +2025,7 @@ getRcvQueueById db connId dbRcvId = getSndQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty SndQueue)) getSndQueuesByConnId_ dbConn connId = L.nonEmpty . sortBy primaryFirst . map toSndQueue - <$> DB.query dbConn (sndQueueQuery <> "WHERE q.conn_id = ?") (Only connId) + <$> DB.query dbConn (sndQueueQuery <> " WHERE q.conn_id = ?") (Only connId) where primaryFirst SndQueue {primary = p, dbReplaceQueueId = i} SndQueue {primary = p', dbReplaceQueueId = i'} = -- the current primary queue is ordered first, the next primary - second @@ -1992,14 +2044,14 @@ sndQueueQuery = |] toSndQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, SenderCanSecure) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, BoolInt) :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) - :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> + :. (DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> SndQueue toSndQueue - ( (userId, keyHash, connId, host, port, sndId, sndSecure) + ( (userId, keyHash, connId, host, port, sndId, BI sndSecure) :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status) - :. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) + :. (dbQueueId, BI primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) ) = let server = SMPServer host port keyHash sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey @@ -2015,30 +2067,27 @@ getSndQueueById db connId dbSndId = retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) retrieveLastIdsAndHashRcv_ dbConn connId = do [(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash)] <- - DB.queryNamed + DB.query dbConn [sql| SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash FROM connections - WHERE conn_id = :conn_id; + WHERE conn_id = ? |] - [":conn_id" := connId] + (Only connId) return (lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) updateLastIdsRcv_ :: DB.Connection -> ConnId -> InternalId -> InternalRcvId -> IO () updateLastIdsRcv_ dbConn connId newInternalId newInternalRcvId = - DB.executeNamed + DB.execute 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_id = :conn_id; + SET last_internal_msg_id = ?, + last_internal_rcv_msg_id = ? + WHERE conn_id = ? |] - [ ":last_internal_msg_id" := newInternalId, - ":last_internal_rcv_msg_id" := newInternalRcvId, - ":conn_id" := connId - ] + (newInternalId, newInternalRcvId, connId) -- * createRcvMsg helpers @@ -2052,12 +2101,12 @@ insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody, (conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption) VALUES (?,?,?,?,?,?,?,?,?); |] - (connId, internalId, internalTs, internalRcvId, Nothing :: Maybe Int64, msgType, msgFlags, msgBody, pqEncryption) + (connId, internalId, internalTs, internalRcvId, Nothing :: Maybe Int64, msgType, msgFlags, Binary msgBody, pqEncryption) insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash, encryptedMsgHash} = do let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta - DB.executeNamed + DB.execute db [sql| INSERT INTO rcv_messages @@ -2065,69 +2114,50 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna broker_id, broker_ts, internal_hash, external_prev_snd_hash, integrity) VALUES - (:conn_id,:rcv_queue_id,:internal_rcv_id,:internal_id,:external_snd_id, - :broker_id,:broker_ts, - :internal_hash,:external_prev_snd_hash,:integrity); + (?,?,?,?,?,?,?,?,?,?) |] - [ ":conn_id" := connId, - ":rcv_queue_id" := dbQueueId, - ":internal_rcv_id" := internalRcvId, - ":internal_id" := fst recipient, - ":external_snd_id" := sndMsgId, - ":broker_id" := fst broker, - ":broker_ts" := snd broker, - ":internal_hash" := internalHash, - ":external_prev_snd_hash" := externalPrevSndHash, - ":integrity" := integrity - ] - DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash) + (connId, dbQueueId, internalRcvId, fst recipient, sndMsgId, Binary (fst broker), snd broker, Binary internalHash, Binary externalPrevSndHash, integrity) + DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, Binary encryptedMsgHash) updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO () updateRcvMsgHash db connId sndMsgId internalRcvId internalHash = - DB.executeNamed + DB.execute db -- 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_id = :conn_id - AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id; + SET last_external_snd_msg_id = ?, + last_rcv_msg_hash = ? + WHERE conn_id = ? + AND last_internal_rcv_msg_id = ? |] - [ ":last_external_snd_msg_id" := sndMsgId, - ":last_rcv_msg_hash" := internalHash, - ":conn_id" := connId, - ":last_internal_rcv_msg_id" := internalRcvId - ] + (sndMsgId, Binary internalHash, connId, internalRcvId) -- * updateSndIds helpers retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) retrieveLastIdsAndHashSnd_ dbConn connId = do firstRow id SEConnNotFound $ - DB.queryNamed + DB.query dbConn [sql| SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash FROM connections - WHERE conn_id = :conn_id; + WHERE conn_id = ? |] - [":conn_id" := connId] + (Only connId) updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO () updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId = - DB.executeNamed + DB.execute dbConn [sql| UPDATE connections - SET last_internal_msg_id = :last_internal_msg_id, - last_internal_snd_msg_id = :last_internal_snd_msg_id - WHERE conn_id = :conn_id; + SET last_internal_msg_id = ?, + last_internal_snd_msg_id = ? + WHERE conn_id = ? |] - [ ":last_internal_msg_id" := newInternalId, - ":last_internal_snd_msg_id" := newInternalSndId, - ":conn_id" := connId - ] + (newInternalId, newInternalSndId, connId) -- * createSndMsg helpers @@ -2141,40 +2171,32 @@ insertSndMsgBase_ db connId SndMsgData {internalId, internalTs, internalSndId, m VALUES (?,?,?,?,?,?,?,?,?); |] - (connId, internalId, internalTs, Nothing :: Maybe Int64, internalSndId, msgType, msgFlags, msgBody, pqEncryption) + (connId, internalId, internalTs, Nothing :: Maybe Int64, internalSndId, msgType, msgFlags, Binary msgBody, pqEncryption) insertSndMsgDetails_ :: DB.Connection -> ConnId -> SndMsgData -> IO () insertSndMsgDetails_ dbConn connId SndMsgData {..} = - DB.executeNamed + DB.execute dbConn [sql| INSERT INTO snd_messages ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash) VALUES - (:conn_id,:internal_snd_id,:internal_id,:internal_hash,:previous_msg_hash); + (?,?,?,?,?) |] - [ ":conn_id" := connId, - ":internal_snd_id" := internalSndId, - ":internal_id" := internalId, - ":internal_hash" := internalHash, - ":previous_msg_hash" := prevMsgHash - ] + (connId, internalSndId, internalId, Binary internalHash, Binary prevMsgHash) updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () updateSndMsgHash db connId internalSndId internalHash = - DB.executeNamed + DB.execute db -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved [sql| UPDATE connections - SET last_snd_msg_hash = :last_snd_msg_hash - WHERE conn_id = :conn_id - AND last_internal_snd_msg_id = :last_internal_snd_msg_id; + SET last_snd_msg_hash = ? + WHERE conn_id = ? + AND last_internal_snd_msg_id = ?; |] - [ ":last_snd_msg_hash" := internalHash, - ":conn_id" := connId, - ":last_internal_snd_msg_id" := internalSndId - ] + (Binary internalHash, connId, internalSndId) -- create record with a random ID createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString) @@ -2189,9 +2211,16 @@ createWithRandomId' gVar create = tryCreate 3 id' <- randomId gVar 12 E.try (create id') >>= \case Right r -> pure $ Right (id', r) - Left e - | SQL.sqlError e == SQL.ErrorConstraint -> tryCreate (n - 1) - | otherwise -> pure . Left . SEInternal $ bshow e + Left e -> handleErr n e +#if defined(dbPostgres) + handleErr n e = case constraintViolation e of + Just _ -> tryCreate (n - 1) + Nothing -> pure . Left . SEInternal $ bshow e +#else + handleErr n e + | SQL.sqlError e == SQL.ErrorConstraint = tryCreate (n - 1) + | otherwise = pure . Left . SEInternal $ bshow e +#endif randomId :: TVar ChaChaDRG -> Int -> IO ByteString randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar @@ -2258,7 +2287,7 @@ insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSiz DB.execute db "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" - ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_, approvedRelays)) + ((Binary rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, Binary <$> redirectEntityId_, redirectDigest_, redirectSize_, BI approvedRelays)) rcvFileId <- liftIO $ insertedRowId db pure (rcvFileEntityId, rcvFileId) @@ -2286,7 +2315,7 @@ getRcvFileByEntityId db rcvFileEntityId = runExceptT $ do getRcvFileIdByEntityId_ :: DB.Connection -> RcvFileId -> IO (Either StoreError DBRcvFileId) getRcvFileIdByEntityId_ db rcvFileEntityId = firstRow fromOnly SEFileNotFound $ - DB.query db "SELECT rcv_file_id FROM rcv_files WHERE rcv_file_entity_id = ?" (Only rcvFileEntityId) + DB.query db "SELECT rcv_file_id FROM rcv_files WHERE rcv_file_entity_id = ?" (Only (Binary rcvFileEntityId)) getRcvFileRedirects :: DB.Connection -> DBRcvFileId -> IO [RcvFile] getRcvFileRedirects db rcvFileId = do @@ -2311,8 +2340,8 @@ getRcvFile db rcvFileId = runExceptT $ do |] (Only rcvFileId) where - toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath) :. (FilePath, Maybe C.SbKey, Maybe C.CbNonce, RcvFileStatus, Bool, Maybe DBRcvFileId, Maybe RcvFileId, Maybe (FileSize Int64), Maybe FileDigest) -> RcvFile - toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, deleted, redirectDbId, redirectEntityId, redirectSize_, redirectDigest_)) = + toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath) :. (FilePath, Maybe C.SbKey, Maybe C.CbNonce, RcvFileStatus, BoolInt, Maybe DBRcvFileId, Maybe RcvFileId, Maybe (FileSize Int64), Maybe FileDigest) -> RcvFile + toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, BI deleted, redirectDbId, redirectEntityId, redirectSize_, redirectDigest_)) = let cfArgs = CFArgs <$> saveKey_ <*> saveNonce_ saveFile = CryptoFile savePath cfArgs redirect = @@ -2355,8 +2384,8 @@ getRcvFile db rcvFileId = runExceptT $ do |] (Only chunkId) where - toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica - toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) = + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, BoolInt, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica + toReplica (rcvChunkReplicaId, replicaId, replicaKey, BI received, delay, retries, host, port, keyHash) = let server = XFTPServer host port keyHash in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries} @@ -2450,8 +2479,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d |] (Only rcvFileChunkReplicaId) where - toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. (Bool, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId) - toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (approvedRelays, redirectEntityId_)) = + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, BoolInt, Maybe Int64, Int) :. (BoolInt, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId) + toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, BI received, delay, retries) :. (BI approvedRelays, redirectEntityId_)) = ( RcvFileChunk { rcvFileId, rcvFileEntityId, @@ -2551,7 +2580,7 @@ createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath k DB.execute db "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" - ((sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_)) + ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_)) where (redirectSize_, redirectDigest_) = case redirect_ of @@ -2566,7 +2595,7 @@ getSndFileByEntityId db sndFileEntityId = runExceptT $ do getSndFileIdByEntityId_ :: DB.Connection -> SndFileId -> IO (Either StoreError DBSndFileId) getSndFileIdByEntityId_ db sndFileEntityId = firstRow fromOnly SEFileNotFound $ - DB.query db "SELECT snd_file_id FROM snd_files WHERE snd_file_entity_id = ?" (Only sndFileEntityId) + DB.query db "SELECT snd_file_id FROM snd_files WHERE snd_file_entity_id = ?" (Only (Binary sndFileEntityId)) getSndFile :: DB.Connection -> DBSndFileId -> IO (Either StoreError SndFile) getSndFile db sndFileId = runExceptT $ do @@ -2586,8 +2615,8 @@ getSndFile db sndFileId = runExceptT $ do |] (Only sndFileId) where - toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, Bool, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile - toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, deleted, redirectSize_, redirectDigest_)) = + toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ @@ -2709,7 +2738,7 @@ deleteSndFile' db sndFileId = getSndFileDeleted :: DB.Connection -> DBSndFileId -> IO Bool getSndFileDeleted db sndFileId = fromMaybe True - <$> maybeFirstRow fromOnly (DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)) + <$> maybeFirstRow fromOnlyBI (DB.query db "SELECT deleted FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)) createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> IO () createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 037ac6bb9..a4c8a52bb 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -1,42 +1,94 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Simplex.Messaging.Agent.Store.Postgres ( createDBStore, + defaultSimplexConnectInfo, closeDBStore, - execSQL, + execSQL ) where +import Control.Exception (throwIO) +import Control.Monad (unless, void) +import Data.Functor (($>)) +import Data.String (fromString) import Data.Text (Text) +import Database.PostgreSQL.Simple (ConnectInfo (..), Only (..), defaultConnectInfo) import qualified Database.PostgreSQL.Simple as PSQL +import Database.PostgreSQL.Simple.SqlQQ (sql) +import Simplex.Messaging.Agent.Store.Migrations (migrateSchema) import Simplex.Messaging.Agent.Store.Postgres.Common +import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB +import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists) import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) +import Simplex.Messaging.Util (ifM) +import UnliftIO.Exception (onException) +import UnliftIO.MVar +import UnliftIO.STM --- TODO [postgres] pass db name / ConnectInfo? -createDBStore :: [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createDBStore = undefined +defaultSimplexConnectInfo :: ConnectInfo +defaultSimplexConnectInfo = + defaultConnectInfo + { connectUser = "simplex", + connectDatabase = "simplex_v6_3_client_db" + } +-- | Create a new Postgres DBStore with the given connection info, schema name and migrations. +-- This function creates the user and/or database passed in connectInfo if they do not exist +-- (expects the default 'postgres' user and 'postgres' db to exist). +-- If passed schema does not exist in connectInfo database, it will be created. +-- Applies necessary migrations to schema. +-- TODO [postgres] authentication / user password, db encryption (?) +createDBStore :: ConnectInfo -> String -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createDBStore connectInfo schema migrations confirmMigrations = do + createDBAndUserIfNotExists connectInfo + st <- connectPostgresStore connectInfo schema + r <- migrateSchema st migrations confirmMigrations `onException` closeDBStore st + case r of + Right () -> pure $ Right st + Left e -> closeDBStore st $> Left e + +connectPostgresStore :: ConnectInfo -> String -> IO DBStore +connectPostgresStore dbConnectInfo schema = do + (dbConn, dbNew) <- connectDB dbConnectInfo schema -- TODO [postgres] analogue for dbBusyLoop? + dbConnection <- newMVar dbConn + dbClosed <- newTVarIO False + pure DBStore {dbConnectInfo, dbConnection, dbNew, dbClosed} + +connectDB :: ConnectInfo -> String -> IO (DB.Connection, Bool) +connectDB dbConnectInfo schema = do + db <- PSQL.connect dbConnectInfo + schemaExists <- prepare db `onException` PSQL.close db + let dbNew = not schemaExists + pure (db, dbNew) + where + prepare db = do + void $ PSQL.execute_ db "SET client_min_messages TO WARNING" + [Only schemaExists] <- + PSQL.query + db + [sql| + SELECT EXISTS ( + SELECT 1 FROM pg_catalog.pg_namespace + WHERE nspname = ? + ) + |] + (Only schema) + unless schemaExists $ void $ PSQL.execute_ db (fromString $ "CREATE SCHEMA " <> schema) + void $ PSQL.execute_ db (fromString $ "SET search_path TO " <> schema) + pure schemaExists + +-- can share with SQLite closeDBStore :: DBStore -> IO () -closeDBStore = undefined +closeDBStore st@DBStore {dbClosed} = + ifM (readTVarIO dbClosed) (putStrLn "closeDBStore: already closed") $ + withConnection st $ \conn -> do + DB.close conn + atomically $ writeTVar dbClosed True +-- TODO [postgres] not necessary for postgres (used for ExecAgentStoreSQL, ExecChatStoreSQL) execSQL :: PSQL.Connection -> Text -> IO [Text] -execSQL = undefined - --- createDatabaseIfNotExists :: ConnectInfo -> String -> IO () --- createDatabaseIfNotExists defaultConnectInfo targetDbName = do --- -- Connect to the default maintenance database (e.g., postgres) --- bracket (connect defaultConnectInfo) close $ \conn -> do --- -- Check if the database already exists --- [Only dbExists] <- query conn --- [sql| --- SELECT EXISTS ( --- SELECT 1 FROM pg_catalog.pg_database --- WHERE datname = ? --- ) --- |] (Only targetDbName) - --- -- If it doesn't exist, create the database --- if not dbExists --- then do --- putStrLn $ "Creating database: " ++ targetDbName --- execute_ conn (Query $ "CREATE DATABASE " <> targetDbName) --- putStrLn "Database created." --- else putStrLn "Database already exists." +execSQL _db _query = throwIO (userError "not implemented") diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs index bdcb63bbd..b23dcf9c8 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -22,7 +22,7 @@ data DBStore = DBStore dbNew :: Bool } --- TODO [postgres] semaphore / connection pool? +-- TODO [postgres] connection pool withConnectionPriority :: DBStore -> Bool -> (PSQL.Connection -> IO a) -> IO a withConnectionPriority DBStore {dbConnection} _priority action = withMVar dbConnection action diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs index 3fb8f593e..9e597aef7 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Simplex.Messaging.Agent.Store.Postgres.DB - ( PSQL.Connection, + ( BoolInt (..), + PSQL.Binary (..), + PSQL.Connection, PSQL.connect, PSQL.close, execute, @@ -11,7 +15,22 @@ module Simplex.Messaging.Agent.Store.Postgres.DB where import Control.Monad (void) +import Data.Int (Int32, Int64) +import Data.Word (Word16, Word32) +import Database.PostgreSQL.Simple (ResultError (..)) import qualified Database.PostgreSQL.Simple as PSQL +import Database.PostgreSQL.Simple.FromField (FromField (..), returnError) +import Database.PostgreSQL.Simple.ToField (ToField (..)) + +newtype BoolInt = BI {unBI :: Bool} + +instance FromField BoolInt where + fromField field dat = BI . (/= (0 :: Int)) <$> fromField field dat + {-# INLINE fromField #-} + +instance ToField BoolInt where + toField (BI b) = toField ((if b then 1 else 0) :: Int) + {-# INLINE toField #-} execute :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> q -> IO () execute db q qs = void $ PSQL.execute db q qs @@ -24,3 +43,21 @@ execute_ db q = void $ PSQL.execute_ db q executeMany :: PSQL.ToRow q => PSQL.Connection -> PSQL.Query -> [q] -> IO () executeMany db q qs = void $ PSQL.executeMany db q qs {-# INLINE executeMany #-} + +-- orphan instances + +-- used in FileSize +instance FromField Word32 where + fromField field dat = do + i <- fromField field dat + if i >= (0 :: Int64) + then pure (fromIntegral i :: Word32) + else returnError ConversionFailed field "Negative value can't be converted to Word32" + +-- used in Version +instance FromField Word16 where + fromField field dat = do + i <- fromField field dat + if i >= (0 :: Int32) + then pure (fromIntegral i :: Word16) + else returnError ConversionFailed field "Negative value can't be converted to Word16" diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs index ed44c09b6..bf8d56caa 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.Postgres.Migrations ( app, @@ -9,13 +12,21 @@ module Simplex.Messaging.Agent.Store.Postgres.Migrations ) where +import Control.Monad (void) import Data.List (sortOn) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time.Clock (getCurrentTime) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import Database.PostgreSQL.Simple (Only (..)) import qualified Database.PostgreSQL.Simple as PSQL +import Database.PostgreSQL.Simple.Internal (Connection (..)) +import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Store.Postgres.Common import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial import Simplex.Messaging.Agent.Store.Shared +import UnliftIO.MVar schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = @@ -28,13 +39,38 @@ app = sortOn name $ map migration schemaMigrations where migration (name, up, down) = Migration {name, up, down = down} --- TODO [postgres] initialize initialize :: DBStore -> IO () -initialize st = undefined +initialize st = withTransaction' st $ \db -> + void $ + PSQL.execute_ + db + [sql| + CREATE TABLE IF NOT EXISTS migrations ( + name TEXT NOT NULL, + ts TIMESTAMP NOT NULL, + down TEXT, + PRIMARY KEY (name) + ) + |] --- TODO [postgres] run run :: DBStore -> MigrationsToRun -> IO () -run st = undefined +run st = \case + MTRUp [] -> pure () + MTRUp ms -> mapM_ runUp ms + MTRDown ms -> mapM_ runDown $ reverse ms + MTRNone -> pure () + where + runUp Migration {name, up, down} = withTransaction' st $ \db -> do + insert db + execSQL db up + where + insert db = void $ PSQL.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime + runDown DownMigration {downName, downQuery} = withTransaction' st $ \db -> do + execSQL db downQuery + void $ PSQL.execute db "DELETE FROM migrations WHERE name = ?" (Only downName) + execSQL db query = + withMVar (connectionHandle db) $ \pqConn -> + void $ LibPQ.exec pqConn (TE.encodeUtf8 query) getCurrent :: PSQL.Connection -> IO [Migration] getCurrent db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;" diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs index 3fab63768..a68144f1f 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs @@ -10,19 +10,10 @@ m20241210_initial :: Text m20241210_initial = T.pack [r| -REVOKE CREATE ON SCHEMA public FROM PUBLIC; - --- TODO [postgres] remove -DROP SCHEMA IF EXISTS agent_schema CASCADE; -CREATE SCHEMA agent_schema; - -SET search_path TO agent_schema; - CREATE TABLE users( - user_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, - deleted INTEGER NOT NULL DEFAULT 0 + user_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + deleted SMALLINT NOT NULL DEFAULT 0 ); -INSERT INTO users (user_id) OVERRIDING SYSTEM VALUE VALUES (1); CREATE TABLE servers( host TEXT NOT NULL, port TEXT NOT NULL, @@ -32,21 +23,20 @@ CREATE TABLE servers( CREATE TABLE connections( conn_id BYTEA NOT NULL PRIMARY KEY, conn_mode TEXT NOT NULL, - last_internal_msg_id INTEGER NOT NULL DEFAULT 0, - last_internal_rcv_msg_id INTEGER NOT NULL DEFAULT 0, - last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0, - last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0, - last_rcv_msg_hash BYTEA NOT NULL DEFAULT E'\\x', - last_snd_msg_hash BYTEA NOT NULL DEFAULT E'\\x', + last_internal_msg_id BIGINT NOT NULL DEFAULT 0, + last_internal_rcv_msg_id BIGINT NOT NULL DEFAULT 0, + last_internal_snd_msg_id BIGINT NOT NULL DEFAULT 0, + last_external_snd_msg_id BIGINT NOT NULL DEFAULT 0, + last_rcv_msg_hash BYTEA NOT NULL DEFAULT ''::BYTEA, + last_snd_msg_hash BYTEA NOT NULL DEFAULT ''::BYTEA, smp_agent_version INTEGER NOT NULL DEFAULT 1, - duplex_handshake INTEGER NULL DEFAULT 0, - enable_ntfs INTEGER, - deleted INTEGER NOT NULL DEFAULT 0, - user_id INTEGER NOT NULL DEFAULT 1 - REFERENCES users ON DELETE CASCADE, + duplex_handshake SMALLINT NULL DEFAULT 0, + enable_ntfs SMALLINT, + deleted SMALLINT NOT NULL DEFAULT 0, + user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE, ratchet_sync_state TEXT NOT NULL DEFAULT 'ok', - deleted_at_wait_delivery TIMESTAMP, - pq_support INTEGER NOT NULL DEFAULT 0 + deleted_at_wait_delivery TIMESTAMPTZ, + pq_support SMALLINT NOT NULL DEFAULT 0 ); CREATE TABLE rcv_queues( host TEXT NOT NULL, @@ -66,15 +56,15 @@ CREATE TABLE rcv_queues( ntf_private_key BYTEA, ntf_id BYTEA, rcv_ntf_dh_secret BYTEA, - rcv_queue_id INTEGER NOT NULL, - rcv_primary INTEGER NOT NULL, - replace_rcv_queue_id INTEGER NULL, - delete_errors INTEGER NOT NULL DEFAULT 0, + rcv_queue_id BIGINT NOT NULL, + rcv_primary SMALLINT NOT NULL, + replace_rcv_queue_id BIGINT NULL, + delete_errors BIGINT NOT NULL DEFAULT 0, server_key_hash BYTEA, switch_status TEXT, - deleted INTEGER NOT NULL DEFAULT 0, - snd_secure INTEGER NOT NULL DEFAULT 0, - last_broker_ts TIMESTAMP, + deleted SMALLINT NOT NULL DEFAULT 0, + snd_secure SMALLINT NOT NULL DEFAULT 0, + last_broker_ts TIMESTAMPTZ, PRIMARY KEY(host, port, rcv_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -92,12 +82,12 @@ CREATE TABLE snd_queues( smp_client_version INTEGER NOT NULL DEFAULT 1, snd_public_key BYTEA, e2e_pub_key BYTEA, - snd_queue_id INTEGER NOT NULL, - snd_primary INTEGER NOT NULL, - replace_snd_queue_id INTEGER NULL, + snd_queue_id BIGINT NOT NULL, + snd_primary SMALLINT NOT NULL, + replace_snd_queue_id BIGINT NULL, server_key_hash BYTEA, switch_status TEXT, - snd_secure INTEGER NOT NULL DEFAULT 0, + snd_secure SMALLINT NOT NULL DEFAULT 0, PRIMARY KEY(host, port, snd_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE @@ -105,28 +95,28 @@ CREATE TABLE snd_queues( CREATE TABLE messages( conn_id BYTEA NOT NULL REFERENCES connections(conn_id) ON DELETE CASCADE, - internal_id INTEGER NOT NULL, - internal_ts TIMESTAMP NOT NULL, - internal_rcv_id INTEGER, - internal_snd_id INTEGER, + internal_id BIGINT NOT NULL, + internal_ts TIMESTAMPTZ NOT NULL, + internal_rcv_id BIGINT, + internal_snd_id BIGINT, msg_type BYTEA NOT NULL, - msg_body BYTEA NOT NULL DEFAULT E'\\x', + msg_body BYTEA NOT NULL DEFAULT ''::BYTEA, msg_flags TEXT NULL, - pq_encryption INTEGER NOT NULL DEFAULT 0, + pq_encryption SMALLINT NOT NULL DEFAULT 0, PRIMARY KEY(conn_id, internal_id) ); CREATE TABLE rcv_messages( conn_id BYTEA NOT NULL, - internal_rcv_id INTEGER NOT NULL, - internal_id INTEGER NOT NULL, - external_snd_id INTEGER NOT NULL, + internal_rcv_id BIGINT NOT NULL, + internal_id BIGINT NOT NULL, + external_snd_id BIGINT NOT NULL, broker_id BYTEA NOT NULL, - broker_ts TIMESTAMP NOT NULL, + broker_ts TIMESTAMPTZ NOT NULL, internal_hash BYTEA NOT NULL, external_prev_snd_hash BYTEA NOT NULL, integrity BYTEA NOT NULL, - user_ack INTEGER NULL DEFAULT 0, - rcv_queue_id INTEGER NOT NULL, + user_ack SMALLINT NULL DEFAULT 0, + rcv_queue_id BIGINT NOT NULL, PRIMARY KEY(conn_id, internal_rcv_id), FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE @@ -137,13 +127,13 @@ ADD CONSTRAINT fk_messages_rcv_messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED; CREATE TABLE snd_messages( conn_id BYTEA NOT NULL, - internal_snd_id INTEGER NOT NULL, - internal_id INTEGER NOT NULL, + internal_snd_id BIGINT NOT NULL, + internal_id BIGINT NOT NULL, internal_hash BYTEA NOT NULL, - previous_msg_hash BYTEA NOT NULL DEFAULT E'\\x', - retry_int_slow INTEGER, - retry_int_fast INTEGER, - rcpt_internal_id INTEGER, + previous_msg_hash BYTEA NOT NULL DEFAULT ''::BYTEA, + retry_int_slow BIGINT, + retry_int_fast BIGINT, + rcpt_internal_id BIGINT, rcpt_status TEXT, PRIMARY KEY(conn_id, internal_snd_id), FOREIGN KEY(conn_id, internal_id) REFERENCES messages @@ -160,9 +150,9 @@ CREATE TABLE conn_confirmations( sender_key BYTEA, ratchet_state BYTEA NOT NULL, sender_conn_info BYTEA NOT NULL, - accepted INTEGER NOT NULL, + accepted SMALLINT NOT NULL, own_conn_info BYTEA, - created_at TIMESTAMP NOT NULL DEFAULT (now()), + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), smp_reply_queues BYTEA NULL, smp_client_version INTEGER ); @@ -171,9 +161,9 @@ CREATE TABLE conn_invitations( contact_conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, cr_invitation BYTEA NOT NULL, recipient_conn_info BYTEA NOT NULL, - accepted INTEGER NOT NULL DEFAULT 0, + accepted SMALLINT NOT NULL DEFAULT 0, own_conn_info BYTEA, - created_at TIMESTAMP NOT NULL DEFAULT (now()) + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE ratchets( conn_id BYTEA NOT NULL PRIMARY KEY REFERENCES connections @@ -187,19 +177,19 @@ CREATE TABLE ratchets( pq_priv_kem BYTEA ); CREATE TABLE skipped_messages( - skipped_message_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + skipped_message_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, conn_id BYTEA NOT NULL REFERENCES ratchets ON DELETE CASCADE, header_key BYTEA NOT NULL, - msg_n INTEGER NOT NULL, + msg_n BIGINT NOT NULL, msg_key BYTEA NOT NULL ); CREATE TABLE ntf_servers( ntf_host TEXT NOT NULL, ntf_port TEXT NOT NULL, ntf_key_hash BYTEA NOT NULL, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()), + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), PRIMARY KEY(ntf_host, ntf_port) ); CREATE TABLE ntf_tokens( @@ -209,14 +199,14 @@ CREATE TABLE ntf_tokens( ntf_port TEXT NOT NULL, tkn_id BYTEA, tkn_pub_key BYTEA NOT NULL, -tkn_priv_key BYTEA NOT NULL, -tkn_pub_dh_key BYTEA NOT NULL, -tkn_priv_dh_key BYTEA NOT NULL, -tkn_dh_secret BYTEA, + tkn_priv_key BYTEA NOT NULL, + tkn_pub_dh_key BYTEA NOT NULL, + tkn_priv_dh_key BYTEA NOT NULL, + tkn_dh_secret BYTEA, tkn_status TEXT NOT NULL, tkn_action BYTEA, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()), + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), ntf_mode TEXT NULL, PRIMARY KEY(provider, device_token, ntf_host, ntf_port), FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers @@ -233,13 +223,13 @@ CREATE TABLE ntf_subscriptions( ntf_sub_status TEXT NOT NULL, ntf_sub_action TEXT, ntf_sub_smp_action TEXT, - ntf_sub_action_ts TIMESTAMP, - updated_by_supervisor INTEGER NOT NULL DEFAULT 0, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()), + ntf_sub_action_ts TIMESTAMPTZ, + updated_by_supervisor SMALLINT NOT NULL DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), smp_server_key_hash BYTEA, - ntf_failed INTEGER DEFAULT 0, - smp_failed INTEGER DEFAULT 0, + ntf_failed SMALLINT DEFAULT 0, + smp_failed SMALLINT DEFAULT 0, PRIMARY KEY(conn_id), FOREIGN KEY(smp_host, smp_port) REFERENCES servers(host, port) ON DELETE SET NULL ON UPDATE CASCADE, @@ -247,7 +237,7 @@ CREATE TABLE ntf_subscriptions( ON DELETE RESTRICT ON UPDATE CASCADE ); CREATE TABLE commands( - command_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + command_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, host TEXT, port TEXT, @@ -256,173 +246,174 @@ CREATE TABLE commands( command BYTEA NOT NULL, agent_version INTEGER NOT NULL DEFAULT 1, server_key_hash BYTEA, - created_at TIMESTAMP NOT NULL DEFAULT '1970-01-01 00:00:00', - failed INTEGER DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT '1970-01-01 00:00:00', + failed SMALLINT DEFAULT 0, FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE ); CREATE TABLE snd_message_deliveries( - snd_message_delivery_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_message_delivery_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, - snd_queue_id INTEGER NOT NULL, - internal_id INTEGER NOT NULL, - failed INTEGER DEFAULT 0, + snd_queue_id BIGINT NOT NULL, + internal_id BIGINT NOT NULL, + failed SMALLINT DEFAULT 0, FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED ); CREATE TABLE xftp_servers( - xftp_server_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + xftp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, xftp_host TEXT NOT NULL, xftp_port TEXT NOT NULL, xftp_key_hash BYTEA NOT NULL, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()), + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), UNIQUE(xftp_host, xftp_port, xftp_key_hash) ); CREATE TABLE rcv_files( - rcv_file_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + rcv_file_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, rcv_file_entity_id BYTEA NOT NULL, - user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, - size INTEGER NOT NULL, + user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE, + size BIGINT NOT NULL, digest BYTEA NOT NULL, key BYTEA NOT NULL, nonce BYTEA NOT NULL, - chunk_size INTEGER NOT NULL, + chunk_size BIGINT NOT NULL, prefix_path TEXT NOT NULL, tmp_path TEXT, save_path TEXT NOT NULL, status TEXT NOT NULL, - deleted INTEGER NOT NULL DEFAULT 0, + deleted SMALLINT NOT NULL DEFAULT 0, error TEXT, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()), + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), save_file_key BYTEA, save_file_nonce BYTEA, - failed INTEGER DEFAULT 0, - redirect_id INTEGER REFERENCES rcv_files ON DELETE SET NULL, + failed SMALLINT DEFAULT 0, + redirect_id BIGINT REFERENCES rcv_files ON DELETE SET NULL, redirect_entity_id BYTEA, - redirect_size INTEGER, + redirect_size BIGINT, redirect_digest BYTEA, - approved_relays INTEGER NOT NULL DEFAULT 0, + approved_relays SMALLINT NOT NULL DEFAULT 0, UNIQUE(rcv_file_entity_id) ); CREATE TABLE rcv_file_chunks( - rcv_file_chunk_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, - rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE, - chunk_no INTEGER NOT NULL, - chunk_size INTEGER NOT NULL, + rcv_file_chunk_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + rcv_file_id BIGINT NOT NULL REFERENCES rcv_files ON DELETE CASCADE, + chunk_no BIGINT NOT NULL, + chunk_size BIGINT NOT NULL, digest BYTEA NOT NULL, tmp_path TEXT, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE rcv_file_chunk_replicas( - rcv_file_chunk_replica_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, - rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE, - replica_number INTEGER NOT NULL, - xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + rcv_file_chunk_replica_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + rcv_file_chunk_id BIGINT NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE, + replica_number BIGINT NOT NULL, + xftp_server_id BIGINT NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, replica_id BYTEA NOT NULL, replica_key BYTEA NOT NULL, - received INTEGER NOT NULL DEFAULT 0, - delay INTEGER, - retries INTEGER NOT NULL DEFAULT 0, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + received SMALLINT NOT NULL DEFAULT 0, + delay BIGINT, + retries BIGINT NOT NULL DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE snd_files( - snd_file_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, snd_file_entity_id BYTEA NOT NULL, - user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, - num_recipients INTEGER NOT NULL, + user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE, + num_recipients BIGINT NOT NULL, digest BYTEA, key BYTEA NOT NUll, nonce BYTEA NOT NUll, path TEXT NOT NULL, prefix_path TEXT, status TEXT NOT NULL, - deleted INTEGER NOT NULL DEFAULT 0, + deleted SMALLINT NOT NULL DEFAULT 0, error TEXT, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()), + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), src_file_key BYTEA, src_file_nonce BYTEA, - failed INTEGER DEFAULT 0, - redirect_size INTEGER, + failed SMALLINT DEFAULT 0, + redirect_size BIGINT, redirect_digest BYTEA ); CREATE TABLE snd_file_chunks( - snd_file_chunk_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, - snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE, - chunk_no INTEGER NOT NULL, - chunk_offset INTEGER NOT NULL, - chunk_size INTEGER NOT NULL, + snd_file_chunk_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_id BIGINT NOT NULL REFERENCES snd_files ON DELETE CASCADE, + chunk_no BIGINT NOT NULL, + chunk_offset BIGINT NOT NULL, + chunk_size BIGINT NOT NULL, digest BYTEA NOT NULL, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE snd_file_chunk_replicas( - snd_file_chunk_replica_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, - snd_file_chunk_id INTEGER NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE, - replica_number INTEGER NOT NULL, - xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + snd_file_chunk_replica_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_chunk_id BIGINT NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE, + replica_number BIGINT NOT NULL, + xftp_server_id BIGINT NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, replica_id BYTEA NOT NULL, replica_key BYTEA NOT NULL, replica_status TEXT NOT NULL, - delay INTEGER, - retries INTEGER NOT NULL DEFAULT 0, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + delay BIGINT, + retries BIGINT NOT NULL DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE snd_file_chunk_replica_recipients( - snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, - snd_file_chunk_replica_id INTEGER NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE, + snd_file_chunk_replica_recipient_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + snd_file_chunk_replica_id BIGINT NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE, rcv_replica_id BYTEA NOT NULL, rcv_replica_key BYTEA NOT NULL, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE deleted_snd_chunk_replicas( - deleted_snd_chunk_replica_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, - user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, - xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + deleted_snd_chunk_replica_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE, + xftp_server_id BIGINT NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, replica_id BYTEA NOT NULL, replica_key BYTEA NOT NULL, chunk_digest BYTEA NOT NULL, - delay INTEGER, - retries INTEGER NOT NULL DEFAULT 0, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()), - failed INTEGER DEFAULT 0 + delay BIGINT, + retries BIGINT NOT NULL DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + failed SMALLINT DEFAULT 0 ); CREATE TABLE encrypted_rcv_message_hashes( - encrypted_rcv_message_hash_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + encrypted_rcv_message_hash_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, hash BYTEA NOT NULL, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE processed_ratchet_key_hashes( - processed_ratchet_key_hash_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + processed_ratchet_key_hash_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, hash BYTEA NOT NULL, - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE TABLE servers_stats( - servers_stats_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + servers_stats_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, servers_stats TEXT, - started_at TIMESTAMP NOT NULL DEFAULT (now()), - created_at TIMESTAMP NOT NULL DEFAULT (now()), - updated_at TIMESTAMP NOT NULL DEFAULT (now()) + started_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); +INSERT INTO servers_stats DEFAULT VALUES; CREATE TABLE ntf_tokens_to_delete( - ntf_token_to_delete_id INTEGER PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + ntf_token_to_delete_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, ntf_host TEXT NOT NULL, ntf_port TEXT NOT NULL, ntf_key_hash BYTEA NOT NULL, tkn_id BYTEA NOT NULL, tkn_priv_key BYTEA NOT NULL, -del_failed INTEGER DEFAULT 0, -created_at TIMESTAMP NOT NULL DEFAULT (now()) + del_failed SMALLINT DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()) ); CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id); diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Util.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Util.hs new file mode 100644 index 000000000..35aa84d86 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Util.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.Messaging.Agent.Store.Postgres.Util + ( createDBAndUserIfNotExists, + -- for tests + dropSchema, + dropAllSchemasExceptSystem, + dropDatabaseAndUser, + ) +where + +import Control.Exception (bracket, throwIO) +import Control.Monad (forM_, unless, void, when) +import Data.Functor (($>)) +import Data.String (fromString) +import Data.Text (Text) +import Database.PostgreSQL.Simple (ConnectInfo (..), Only (..), defaultConnectInfo) +import qualified Database.PostgreSQL.Simple as PSQL +import Database.PostgreSQL.Simple.SqlQQ (sql) +import Simplex.Messaging.Agent.Store.Migrations (migrateSchema) +import Simplex.Messaging.Agent.Store.Postgres.Common +import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) +import Simplex.Messaging.Util (ifM) +import UnliftIO.Exception (onException) +import UnliftIO.MVar +import UnliftIO.STM + +createDBAndUserIfNotExists :: ConnectInfo -> IO () +createDBAndUserIfNotExists ConnectInfo {connectUser = user, connectDatabase = dbName} = do + -- connect to the default "postgres" maintenance database + bracket (PSQL.connect defaultConnectInfo {connectUser = "postgres", connectDatabase = "postgres"}) PSQL.close $ + \postgresDB -> do + void $ PSQL.execute_ postgresDB "SET client_min_messages TO WARNING" + -- check if the user exists, create if not + [Only userExists] <- + PSQL.query + postgresDB + [sql| + SELECT EXISTS ( + SELECT 1 FROM pg_catalog.pg_roles + WHERE rolname = ? + ) + |] + (Only user) + unless userExists $ void $ PSQL.execute_ postgresDB (fromString $ "CREATE USER " <> user) + -- check if the database exists, create if not + dbExists <- checkDBExists postgresDB dbName + unless dbExists $ void $ PSQL.execute_ postgresDB (fromString $ "CREATE DATABASE " <> dbName <> " OWNER " <> user) + +checkDBExists :: PSQL.Connection -> String -> IO Bool +checkDBExists postgresDB dbName = do + [Only dbExists] <- + PSQL.query + postgresDB + [sql| + SELECT EXISTS ( + SELECT 1 FROM pg_catalog.pg_database + WHERE datname = ? + ) + |] + (Only dbName) + pure dbExists + +dropSchema :: ConnectInfo -> String -> IO () +dropSchema connectInfo schema = + bracket (PSQL.connect connectInfo) PSQL.close $ + \db -> do + void $ PSQL.execute_ db "SET client_min_messages TO WARNING" + void $ PSQL.execute_ db (fromString $ "DROP SCHEMA IF EXISTS " <> schema <> " CASCADE") + +dropAllSchemasExceptSystem :: ConnectInfo -> IO () +dropAllSchemasExceptSystem connectInfo = + bracket (PSQL.connect connectInfo) PSQL.close $ + \db -> do + void $ PSQL.execute_ db "SET client_min_messages TO WARNING" + schemaNames :: [Only String] <- + PSQL.query_ + db + [sql| + SELECT schema_name + FROM information_schema.schemata + WHERE schema_name NOT IN ('public', 'pg_catalog', 'information_schema') + |] + forM_ schemaNames $ \(Only schema) -> + PSQL.execute_ db (fromString $ "DROP SCHEMA " <> schema <> " CASCADE") + +dropDatabaseAndUser :: ConnectInfo -> IO () +dropDatabaseAndUser ConnectInfo {connectUser = user, connectDatabase = dbName} = + bracket (PSQL.connect defaultConnectInfo {connectUser = "postgres", connectDatabase = "postgres"}) PSQL.close $ + \postgresDB -> do + void $ PSQL.execute_ postgresDB "SET client_min_messages TO WARNING" + dbExists <- checkDBExists postgresDB dbName + when dbExists $ do + void $ PSQL.execute_ postgresDB (fromString $ "ALTER DATABASE " <> dbName <> " WITH ALLOW_CONNECTIONS false") + -- terminate all connections to the database + _r :: [Only Bool] <- + PSQL.query + postgresDB + [sql| + SELECT pg_terminate_backend(pg_stat_activity.pid) + FROM pg_stat_activity + WHERE datname = ? + AND pid <> pg_backend_pid() + |] + (Only dbName) + void $ PSQL.execute_ postgresDB (fromString $ "DROP DATABASE " <> dbName) + void $ PSQL.execute_ postgresDB (fromString $ "DROP USER IF EXISTS " <> user) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index b0c53dee2..816968208 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -26,14 +26,17 @@ module Simplex.Messaging.Agent.Store.SQLite ( createDBStore, - connectSQLiteStore, closeDBStore, - openSQLiteStore, - reopenSQLiteStore, + execSQL, + -- used in Simplex.Chat.Archive sqlString, keyString, storeKey, - execSQL, + -- used in Simplex.Chat.Mobile and tests + reopenSQLiteStore, + -- used in tests + connectSQLiteStore, + openSQLiteStore, ) where diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index a5d5189d0..7e8406d5c 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -1,21 +1,23 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} module Simplex.Messaging.Agent.Store.SQLite.DB - ( Connection (..), + ( BoolInt (..), + Binary (..), + Connection (..), SlowQueryStats (..), open, close, execute, execute_, - executeNamed, executeMany, query, query_, - queryNamed, ) where @@ -23,18 +25,27 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad (when) import qualified Data.Aeson.TH as J +import Data.ByteString (ByteString) import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) import Data.Time (diffUTCTime, getCurrentTime) -import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow) +import Database.SQLite.Simple (FromRow, Query, ToRow) import qualified Database.SQLite.Simple as SQL +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (diffToMilliseconds, tshow) +newtype BoolInt = BI {unBI :: Bool} + deriving newtype (FromField, ToField) + +newtype Binary = Binary {fromBinary :: ByteString} + deriving newtype (FromField, ToField) + data Connection = Connection { conn :: SQL.Connection, slow :: TMap Query SlowQueryStats @@ -92,11 +103,6 @@ execute_ :: Connection -> Query -> IO () execute_ Connection {conn, slow} sql = timeIt slow sql $ SQL.execute_ conn sql {-# INLINE execute_ #-} --- TODO [postgres] remove -executeNamed :: Connection -> Query -> [NamedParam] -> IO () -executeNamed Connection {conn, slow} sql = timeIt slow sql . SQL.executeNamed conn sql -{-# INLINE executeNamed #-} - executeMany :: ToRow q => Connection -> Query -> [q] -> IO () executeMany Connection {conn, slow} sql = timeIt slow sql . SQL.executeMany conn sql {-# INLINE executeMany #-} @@ -109,9 +115,4 @@ query_ :: FromRow r => Connection -> Query -> IO [r] query_ Connection {conn, slow} sql = timeIt slow sql $ SQL.query_ conn sql {-# INLINE query_ #-} --- TODO [postgres] remove -queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r] -queryNamed Connection {conn, slow} sql = timeIt slow sql . SQL.queryNamed conn sql -{-# INLINE queryNamed #-} - $(J.deriveJSON defaultJSON ''SlowQueryStats) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 05ba861bc..a955d0d8a 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -1,11 +1,14 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -233,14 +236,20 @@ import Data.Typeable (Proxy (Proxy), Typeable) import Data.Word (Word32) import Data.X509 import Data.X509.Validation (Fingerprint (..), getFingerprint) -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+)) import Network.Transport.Internal (decodeWord16, encodeWord16) +import Simplex.Messaging.Agent.Store.DB (Binary (..)) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString) import Simplex.Messaging.Util ((<$?>)) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif -- | Cryptographic algorithms. data Algorithm = Ed25519 | Ed448 | X25519 | X448 @@ -721,23 +730,23 @@ generateKeyPair_ = case sAlgorithm @a of let k = X448.toPublic pk in pure (PublicKeyX448 k, PrivateKeyX448 pk k) -instance ToField APrivateSignKey where toField = toField . encodePrivKey +instance ToField APrivateSignKey where toField = toField . Binary . encodePrivKey -instance ToField APublicVerifyKey where toField = toField . encodePubKey +instance ToField APublicVerifyKey where toField = toField . Binary . encodePubKey -instance ToField APrivateAuthKey where toField = toField . encodePrivKey +instance ToField APrivateAuthKey where toField = toField . Binary . encodePrivKey -instance ToField APublicAuthKey where toField = toField . encodePubKey +instance ToField APublicAuthKey where toField = toField . Binary . encodePubKey -instance ToField APrivateDhKey where toField = toField . encodePrivKey +instance ToField APrivateDhKey where toField = toField . Binary . encodePrivKey -instance ToField APublicDhKey where toField = toField . encodePubKey +instance ToField APublicDhKey where toField = toField . Binary . encodePubKey -instance AlgorithmI a => ToField (PrivateKey a) where toField = toField . encodePrivKey +instance AlgorithmI a => ToField (PrivateKey a) where toField = toField . Binary . encodePrivKey -instance AlgorithmI a => ToField (PublicKey a) where toField = toField . encodePubKey +instance AlgorithmI a => ToField (PublicKey a) where toField = toField . Binary . encodePubKey -instance ToField (DhSecret a) where toField = toField . dhBytes' +instance ToField (DhSecret a) where toField = toField . Binary . dhBytes' instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePrivKey @@ -888,10 +897,9 @@ validSignatureSize n = -- | AES key newtype. newtype Key = Key {unKey :: ByteString} deriving (Eq, Ord, Show) + deriving newtype (FromField) -instance ToField Key where toField = toField . unKey - -instance FromField Key where fromField f = Key <$> fromField f +instance ToField Key where toField (Key s) = toField $ Binary s instance ToJSON Key where toJSON = strToJSON . unKey @@ -952,7 +960,7 @@ instance FromJSON KeyHash where instance IsString KeyHash where fromString = parseString $ parseAll strP -instance ToField KeyHash where toField = toField . strEncode +instance ToField KeyHash where toField = toField . Binary . strEncode instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP @@ -1162,10 +1170,14 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a} instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where +#if defined(dbPostgres) + fromField f dat = SignedObject <$> blobFieldDecoder decodeSignedObject f dat +#else fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject +#endif instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where - toField (SignedObject s) = toField $ encodeSignedObject s + toField (SignedObject s) = toField . Binary $ encodeSignedObject s instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact @@ -1265,6 +1277,9 @@ cbVerify k pk nonce (CbAuthenticator s) authorized = cbDecryptNoPad (dh' k pk) n newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString} deriving (Eq, Show) + deriving newtype (FromField) + +instance ToField CbNonce where toField (CryptoBoxNonce s) = toField $ Binary s pattern CbNonce :: ByteString -> CbNonce pattern CbNonce s <- CryptoBoxNonce s @@ -1282,10 +1297,6 @@ instance ToJSON CbNonce where instance FromJSON CbNonce where parseJSON = strParseJSON "CbNonce" -instance FromField CbNonce where fromField f = CryptoBoxNonce <$> fromField f - -instance ToField CbNonce where toField (CryptoBoxNonce s) = toField s - cbNonce :: ByteString -> CbNonce cbNonce s | len == 24 = CryptoBoxNonce s @@ -1309,6 +1320,9 @@ instance Encoding CbNonce where newtype SbKey = SecretBoxKey {unSbKey :: ByteString} deriving (Eq, Show) + deriving newtype (FromField) + +instance ToField SbKey where toField (SecretBoxKey s) = toField $ Binary s pattern SbKey :: ByteString -> SbKey pattern SbKey s <- SecretBoxKey s @@ -1326,10 +1340,6 @@ instance ToJSON SbKey where instance FromJSON SbKey where parseJSON = strParseJSON "SbKey" -instance FromField SbKey where fromField f = SecretBoxKey <$> fromField f - -instance ToField SbKey where toField (SecretBoxKey s) = toField s - sbKey :: ByteString -> Either String SbKey sbKey s | B.length s == 32 = Right $ SecretBoxKey s diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 148d931a9..c7ead660a 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -109,9 +110,8 @@ import Data.Maybe (fromMaybe, isJust) import Data.Type.Equality import Data.Typeable (Typeable) import Data.Word (Word16, Word32) -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Messaging.Agent.QueryString +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import Simplex.Messaging.Crypto import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding @@ -121,6 +121,13 @@ import Simplex.Messaging.Util (($>>=), (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import UnliftIO.STM +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif -- e2e encryption headers version history: -- 1 - binary protocol encoding (1/1/2022) @@ -359,7 +366,7 @@ instance Encoding APrivRKEMParams where 'A' -> APRKP SRKSAccepted .:. PrivateRKParamsAccepted <$> smpP <*> smpP <*> smpP _ -> fail "bad APrivRKEMParams" -instance RatchetKEMStateI s => ToField (PrivRKEMParams s) where toField = toField . smpEncode +instance RatchetKEMStateI s => ToField (PrivRKEMParams s) where toField = toField . Binary . smpEncode instance (Typeable s, RatchetKEMStateI s) => FromField (PrivRKEMParams s) where fromField = blobFieldDecoder smpDecode @@ -576,7 +583,7 @@ instance ToJSON RatchetKey where instance FromJSON RatchetKey where parseJSON = fmap RatchetKey . strParseJSON "Key" -instance ToField MessageKey where toField = toField . smpEncode +instance ToField MessageKey where toField = toField . Binary . smpEncode instance FromField MessageKey where fromField = blobFieldDecoder smpDecode @@ -1120,14 +1127,24 @@ instance AlgorithmI a => ToJSON (Ratchet a) where instance AlgorithmI a => FromJSON (Ratchet a) where parseJSON = $(JQ.mkParseJSON defaultJSON ''Ratchet) -instance AlgorithmI a => ToField (Ratchet a) where toField = toField . LB.toStrict . J.encode +instance AlgorithmI a => ToField (Ratchet a) where toField = toField . Binary . LB.toStrict . J.encode instance (AlgorithmI a, Typeable a) => FromField (Ratchet a) where fromField = blobFieldDecoder J.eitherDecodeStrict' -instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField pqEnc +instance ToField PQEncryption where toField (PQEncryption pqEnc) = toField (BI pqEnc) -instance FromField PQEncryption where fromField f = PQEncryption <$> fromField f +instance FromField PQEncryption where +#if defined(dbPostgres) + fromField f dat = PQEncryption . unBI <$> fromField f dat +#else + fromField f = PQEncryption . unBI <$> fromField f +#endif -instance ToField PQSupport where toField (PQSupport pqEnc) = toField pqEnc +instance ToField PQSupport where toField (PQSupport pqEnc) = toField (BI pqEnc) -instance FromField PQSupport where fromField f = PQSupport <$> fromField f +instance FromField PQSupport where +#if defined(dbPostgres) + fromField f dat = PQSupport . unBI <$> fromField f dat +#else + fromField f = PQSupport . unBI <$> fromField f +#endif diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs index 3b2238086..35e46e3de 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} module Simplex.Messaging.Crypto.SNTRUP761.Bindings where @@ -9,14 +10,19 @@ import Data.Bifunctor (bimap) import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) -import Database.SQLite.Simple.FromField -import Database.SQLite.Simple.ToField import Foreign (nullPtr) import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField +#else +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField +#endif newtype KEMPublicKey = KEMPublicKey ByteString deriving (Eq, Show) @@ -121,7 +127,11 @@ instance ToField KEMSharedKey where toField (KEMSharedKey k) = toField (BA.convert k :: ByteString) instance FromField KEMSharedKey where +#if defined(dbPostgres) + fromField f dat = KEMSharedKey . BA.convert @ByteString <$> fromField f dat +#else fromField f = KEMSharedKey . BA.convert @ByteString <$> fromField f +#endif instance ToJSON KEMSharedKey where toJSON = strToJSON diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index af8987dcc..96f8b337e 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -27,8 +28,6 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System import Data.Type.Equality import Data.Word (Word16) -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -37,6 +36,13 @@ import Simplex.Messaging.Notifications.Transport (NTFVersion, ntfClientHandshake import Simplex.Messaging.Parsers (fromTextField_) import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..)) import Simplex.Messaging.Util (eitherToMaybe, (<$?>)) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif data NtfEntity = Token | Subscription deriving (Show) diff --git a/src/Simplex/Messaging/Notifications/Types.hs b/src/Simplex/Messaging/Notifications/Types.hs index 774f354bb..dd6e99733 100644 --- a/src/Simplex/Messaging/Notifications/Types.hs +++ b/src/Simplex/Messaging/Notifications/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} @@ -9,14 +10,20 @@ module Simplex.Messaging.Notifications.Types where import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time (UTCTime) -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..), UserId) +import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_) import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +#else +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +#endif data NtfTknAction = NTARegister @@ -41,7 +48,7 @@ instance Encoding NtfTknAction where instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode -instance ToField NtfTknAction where toField = toField . smpEncode +instance ToField NtfTknAction where toField = toField . Binary . smpEncode data NtfToken = NtfToken { deviceToken :: DeviceToken, @@ -119,7 +126,7 @@ instance Encoding NtfSubNTFAction where instance FromField NtfSubNTFAction where fromField = blobFieldDecoder smpDecode -instance ToField NtfSubNTFAction where toField = toField . smpEncode +instance ToField NtfSubNTFAction where toField = toField . Binary . smpEncode data NtfSubSMPAction = NSASmpKey @@ -138,7 +145,7 @@ instance Encoding NtfSubSMPAction where instance FromField NtfSubSMPAction where fromField = blobFieldDecoder smpDecode -instance ToField NtfSubSMPAction where toField = toField . smpEncode +instance ToField NtfSubSMPAction where toField = toField . Binary . smpEncode data NtfAgentSubStatus = -- | subscription started diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index 6ad9f867d..a75efe0ee 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -20,12 +21,19 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Data.Time.ISO8601 (parseISO8601) import Data.Typeable (Typeable) +import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) +import Text.Read (readMaybe) +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (ResultError (..)) +import Database.PostgreSQL.Simple.FromField (FromField(..), FieldParser, returnError, Field (..)) +import Database.PostgreSQL.Simple.TypeInfo.Static (textOid, varcharOid) +import qualified Data.Text.Encoding as TE +#else 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 (safeDecodeUtf8, (<$?>)) -import Text.Read (readMaybe) +#endif base64P :: Parser ByteString base64P = decode <$?> paddedBase64 rawBase64P @@ -77,6 +85,14 @@ parseString p = either error id . p . B.pack blobFieldParser :: Typeable k => Parser k -> FieldParser k blobFieldParser = blobFieldDecoder . parseAll +#if defined(dbPostgres) +blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k +blobFieldDecoder dec f val = do + x <- fromField f val + case dec x of + Right k -> pure k + Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) +#else blobFieldDecoder :: Typeable k => (ByteString -> Either String k) -> FieldParser k blobFieldDecoder dec = \case f@(Field (SQLBlob b) _) -> @@ -84,7 +100,20 @@ blobFieldDecoder dec = \case Right k -> Ok k Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) f -> returnError ConversionFailed f "expecting SQLBlob column type" +#endif +-- TODO [postgres] review +#if defined(dbPostgres) +fromTextField_ :: Typeable a => (Text -> Maybe a) -> FieldParser a +fromTextField_ fromText f val = + if typeOid f `elem` [textOid, varcharOid] + then case val of + Just t -> case fromText (TE.decodeUtf8 t) of + Just x -> pure x + _ -> returnError ConversionFailed f "invalid text value" + Nothing -> returnError UnexpectedNull f "NULL value found for non-NULL field" + else returnError Incompatible f "expecting TEXT or VARCHAR column type" +#else fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a fromTextField_ fromText = \case f@(Field (SQLText t) _) -> @@ -92,6 +121,7 @@ fromTextField_ fromText = \case Just x -> Ok x _ -> returnError ConversionFailed f ("invalid text: " <> T.unpack t) f -> returnError ConversionFailed f "expecting SQLText column type" +#endif fstToLower :: String -> String fstToLower "" = "" diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 56a7fef1f..dff6cd4b0 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -1,12 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PostfixOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module AgentTests (agentTests) where @@ -14,18 +12,30 @@ import AgentTests.ConnectionRequestTests import AgentTests.DoubleRatchetTests (doubleRatchetTests) import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) -import AgentTests.NotificationTests (notificationTests) -import AgentTests.SQLiteTests (storeTests) import AgentTests.ServerChoice (serverChoiceTests) import Simplex.Messaging.Transport (ATransport (..)) import Test.Hspec +#if defined(dbPostgres) +import Fixtures +import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) +#else +import AgentTests.NotificationTests (notificationTests) +import AgentTests.SQLiteTests (storeTests) +#endif agentTests :: ATransport -> Spec agentTests (ATransport t) = do + describe "Migration tests" migrationTests describe "Connection request" connectionRequestTests describe "Double ratchet tests" doubleRatchetTests +#if defined(dbPostgres) + after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do + describe "Functional API" $ functionalAPITests (ATransport t) + describe "Chosen servers" serverChoiceTests +#else describe "Functional API" $ functionalAPITests (ATransport t) + describe "Chosen servers" serverChoiceTests + -- notifications aren't tested with postgres, as we don't plan to use iOS client with it describe "Notification tests" $ notificationTests (ATransport t) describe "SQLite store" storeTests - describe "Chosen servers" serverChoiceTests - describe "Migration tests" migrationTests +#endif diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 71000b60a..9c3c5a972 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -75,7 +75,6 @@ import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) -import qualified Database.SQLite.Simple as SQL import GHC.Stack (withFrozenCallStack) import SMPAgentClient import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) @@ -85,8 +84,9 @@ import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestSte import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT) import qualified Simplex.Messaging.Agent.Protocol as A -import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction') -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (..), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) @@ -109,6 +109,9 @@ import Test.Hspec import UnliftIO import Util import XFTPClient (testXFTPServer) +#if defined(dbPostgres) +import Fixtures +#endif type AEntityTransmission e = (ACorrId, ConnId, AEvent e) @@ -259,7 +262,6 @@ sendMessage c connId msgFlags msgBody = do liftIO $ pqEnc `shouldBe` PQEncOn pure msgId --- TODO [postgres] run with postgres functionalAPITests :: ATransport -> Spec functionalAPITests t = do describe "Establishing duplex connection" $ do @@ -327,6 +329,8 @@ functionalAPITests t = do it "should expire multiple messages" $ testExpireManyMessages t it "should expire one message if quota is exceeded" $ testExpireMessageQuota t it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota t +#if !defined(dbPostgres) + -- TODO [postgres] restore from outdated db backup (we use copyFile/renameFile for sqlite) describe "Ratchet synchronization" $ do it "should report ratchet de-synchronization, synchronize ratchets" $ testRatchetSync t @@ -338,6 +342,7 @@ functionalAPITests t = do testRatchetSyncSuspendForeground t it "should synchronize ratchets when clients start synchronization simultaneously" $ testRatchetSyncSimultaneous t +#endif describe "Subscription mode OnlyCreate" $ do it "messages delivered only when polled (v8 - slow handshake)" $ withSmpServer t testOnlyCreatePullSlowHandshake @@ -2563,7 +2568,7 @@ testSwitchAsync servers = do withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfg servers testDB2 -withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> FilePath -> (HasCallStack => AgentClient -> IO a) -> IO a +withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> String -> (HasCallStack => AgentClient -> IO a) -> IO a withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) (\a -> disposeAgentClient a >> threadDelay 100000) sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO () @@ -3093,13 +3098,27 @@ testTwoUsers = withAgentClients2 $ \a b -> do hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO () hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n -getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient +getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> String -> IO AgentClient getSMPAgentClient' clientId cfg' initServers dbPath = do - Right st <- liftIO $ createAgentStore dbPath "" False MCError + Right st <- liftIO $ createStore dbPath c <- getSMPAgentClient_ clientId cfg' initServers st False - when (dbNew st) $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)") + when (dbNew st) $ insertUser st pure c +#if defined(dbPostgres) +createStore :: String -> IO (Either MigrationError DBStore) +createStore schema = createAgentStore testDBConnectInfo schema MCError + +insertUser :: DBStore -> IO () +insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") +#else +createStore :: String -> IO (Either MigrationError DBStore) +createStore dbPath = createAgentStore dbPath "" False MCError + +insertUser :: DBStore -> IO () +insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)") +#endif + testServerMultipleIdentities :: HasCallStack => IO () testServerMultipleIdentities = withAgentClients2 $ \alice bob -> runRight_ $ do diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index 31ec79bf9..fb8550a7d 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/tests/AgentTests/MigrationTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module AgentTests.MigrationTests (migrationTests) where @@ -5,17 +6,24 @@ module AgentTests.MigrationTests (migrationTests) where import Control.Monad import Data.Maybe (fromJust) import Data.Word (Word32) -import Database.SQLite.Simple (fromOnly) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) import Simplex.Messaging.Agent.Store.Migrations (migrationsToRun) -import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, createDBStore) -import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import Simplex.Messaging.Agent.Store.Shared -import System.Directory (removeFile) import System.Random (randomIO) import Test.Hspec +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (fromOnly) +import Fixtures +import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) +import Simplex.Messaging.Agent.Store.Postgres.Util (dropSchema) +import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB +#else +import Database.SQLite.Simple (fromOnly) +import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, createDBStore) +import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import System.Directory (removeFile) +#endif --- TODO [postgres] run with postgres migrationTests :: Spec migrationTests = do it "should determine migrations to run" testMigrationsToRun @@ -98,9 +106,6 @@ migrationTests = do ([m1, m2, m3, m4], [t1, t2, t3, t4]) ([m1, m2, m4], [MCYesUp, MCYesUpDown, MCError], Left . MigrationError $ MTREDifferent (name m4) (name m3)) -testDB :: FilePath -testDB = "tests/tmp/test_migrations.db" - m1 :: Migration m1 = Migration "20230301-migration1" "create table test1 (id1 integer primary key);" Nothing @@ -180,21 +185,46 @@ testMigration :: IO () testMigration (initMs, initTables) (finalMs, confirmModes, tablesOrError) = forM_ confirmModes $ \confirmMode -> do r <- randomIO :: IO Word32 - let dpPath = testDB <> show r - Right st <- createDBStore dpPath "" False initMs MCError + Right st <- createStore r initMs MCError st `shouldHaveTables` initTables closeDBStore st case tablesOrError of Right tables -> do - Right st' <- createDBStore dpPath "" False finalMs confirmMode + Right st' <- createStore r finalMs confirmMode st' `shouldHaveTables` tables closeDBStore st' Left e -> do - Left e' <- createDBStore dpPath "" False finalMs confirmMode + Left e' <- createStore r finalMs confirmMode e `shouldBe` e' - removeFile dpPath - where - shouldHaveTables :: DBStore -> [String] -> IO () - st `shouldHaveTables` expected = do - tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT name FROM sqlite_schema WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY 1;") - tables `shouldBe` "migrations" : expected + cleanup r + +#if defined(dbPostgres) +testSchema :: Word32 -> String +testSchema randSuffix = "test_migrations_schema" <> show randSuffix + +createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createStore randSuffix migrations confirmMigrations = + createDBStore testDBConnectInfo (testSchema randSuffix) migrations confirmMigrations + +cleanup :: Word32 -> IO () +cleanup randSuffix = dropSchema testDBConnectInfo (testSchema randSuffix) + +shouldHaveTables :: DBStore -> [String] -> IO () +st `shouldHaveTables` expected = do + tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT table_name FROM information_schema.tables WHERE table_schema = current_schema() AND table_type = 'BASE TABLE' ORDER BY 1") + tables `shouldBe` "migrations" : expected +#else +testDB :: Word32 -> FilePath +testDB randSuffix = "tests/tmp/test_migrations.db" <> show randSuffix + +createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createStore randSuffix = createDBStore (testDB randSuffix) "" False + +cleanup :: Word32 -> IO () +cleanup randSuffix = removeFile (testDB randSuffix) + +shouldHaveTables :: DBStore -> [String] -> IO () +st `shouldHaveTables` expected = do + tables <- map fromOnly <$> withTransaction st (`DB.query_` "SELECT name FROM sqlite_schema WHERE type = 'table' AND name NOT LIKE 'sqlite_%' ORDER BY 1") + tables `shouldBe` "migrations" : expected +#endif diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index ce07d580a..33e15792e 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -76,15 +76,9 @@ import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfSer import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) -import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO -removeFileIfExists :: FilePath -> IO () -removeFileIfExists filePath = do - fileExists <- doesFileExist filePath - when fileExists $ removeFile filePath - notificationTests :: ATransport -> Spec notificationTests t = do describe "Managing notification tokens" $ do diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index ba344a4b1..b7fcce8ee 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -37,7 +37,6 @@ appLint = "src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_lint.sql" testSchema :: FilePath testSchema = "tests/tmp/test_agent_schema.sql" --- TODO [postgres] run with postgres schemaDumpTest :: Spec schemaDumpTest = do it "verify and overwrite schema dump" testVerifySchemaDump diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index e24f9f1ea..90bea0192 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -10,13 +10,12 @@ module CoreTests.StoreLogTests where import Control.Concurrent.STM import Control.Monad +import CoreTests.MsgStoreTests import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Char8 as B import Data.Either (partitionEithers) import qualified Data.Map.Strict as M import SMPClient -import AgentTests.SQLiteTests -import CoreTests.MsgStoreTests import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol @@ -27,6 +26,9 @@ import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.StoreLog import Test.Hspec +testPublicAuthKey :: C.APublicAuthKey +testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe") + testNtfCreds :: TVar ChaChaDRG -> IO NtfCreds testNtfCreds g = do (notifierKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g @@ -54,7 +56,8 @@ storeLogTests = ((rId, qr), ntfCreds, date) <- runIO $ do g <- C.newRandom (,,) <$> testNewQueueRec g sndSecure <*> testNtfCreds g <*> getSystemDate - testSMPStoreLog ("SMP server store log, sndSecure = " <> show sndSecure) + testSMPStoreLog + ("SMP server store log, sndSecure = " <> show sndSecure) [ SLTC { name = "create new queue", saved = [CreateQueue qr], @@ -66,7 +69,7 @@ storeLogTests = saved = [CreateQueue qr, SecureQueue rId testPublicAuthKey], compacted = [CreateQueue qr {senderKey = Just testPublicAuthKey}], state = M.fromList [(rId, qr {senderKey = Just testPublicAuthKey})] - }, + }, SLTC { name = "create and delete queue", saved = [CreateQueue qr, DeleteQueue rId], @@ -90,7 +93,7 @@ storeLogTests = saved = [CreateQueue qr, UpdateTime rId date], compacted = [CreateQueue qr {updatedAt = Just date}], state = M.fromList [(rId, qr {updatedAt = Just date})] - } + } ] testSMPStoreLog :: String -> [SMPStoreLogTestCase] -> Spec diff --git a/tests/Fixtures.hs b/tests/Fixtures.hs new file mode 100644 index 000000000..a8e2542ec --- /dev/null +++ b/tests/Fixtures.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} + +module Fixtures where + +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) +#endif + +#if defined(dbPostgres) +testDBConnectInfo :: ConnectInfo +testDBConnectInfo = + defaultConnectInfo { + connectUser = "test_user", + connectDatabase = "test_agent_db" + } +#endif diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 5e5f91b09..fc66f2ab1 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -25,6 +26,17 @@ import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), Protocol import Simplex.Messaging.Transport import XFTPClient (testXFTPServer) +-- name fixtures are reused, but they are used as schema name instead of database file path +#if defined(dbPostgres) +testDB :: String +testDB = "smp_agent_test_protocol_schema" + +testDB2 :: String +testDB2 = "smp_agent2_test_protocol_schema" + +testDB3 :: String +testDB3 = "smp_agent3_test_protocol_schema" +#else testDB :: FilePath testDB = "tests/tmp/smp-agent.test.protocol.db" @@ -33,6 +45,7 @@ testDB2 = "tests/tmp/smp-agent2.test.protocol.db" testDB3 :: FilePath testDB3 = "tests/tmp/smp-agent3.test.protocol.db" +#endif testSMPServer :: SMPServer testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001" diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index b827edda2..cbdc7a3f5 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -46,6 +47,10 @@ import System.Random (randomRIO) import Test.Hspec import UnliftIO import Util +#if defined(dbPostgres) +import Fixtures +import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) +#endif smpProxyTests :: Spec smpProxyTests = do @@ -101,7 +106,11 @@ smpProxyTests = do it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100 it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20 +#if defined(dbPostgres) + after_ (dropAllSchemasExceptSystem testDBConnectInfo) . describe "agent API" $ do +#else describe "agent API" $ do +#endif describe "one server" $ do it "always via proxy" . oneServer $ agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 744ceb437..f9c9dcce1 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -15,13 +15,12 @@ module ServerTests where -import AgentTests.NotificationTests (removeFileIfExists) -import CoreTests.MsgStoreTests (testJournalStoreCfg) import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Concurrent.STM import Control.Exception (SomeException, try) import Control.Monad import Control.Monad.IO.Class +import CoreTests.MsgStoreTests (testJournalStoreCfg) import Data.Bifunctor (first) import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) @@ -51,9 +50,10 @@ import System.TimeIt (timeItT) import System.Timeout import Test.HUnit import Test.Hspec +import Util (removeFileIfExists) serverTests :: SpecWith (ATransport, AMSType) -serverTests = do +serverTests = do describe "SMP queues" $ do describe "NEW and KEY commands, SEND messages" testCreateSecure describe "NEW and SKEY commands" $ do diff --git a/tests/Test.hs b/tests/Test.hs index f8505b133..09fb856fd 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} import AgentTests (agentTests) -import AgentTests.SchemaDump (schemaDumpTest) import CLITests import Control.Concurrent (threadDelay) import qualified Control.Exception as E @@ -34,6 +34,12 @@ import Test.Hspec import XFTPAgent import XFTPCLI import XFTPServerTests (xftpServerTests) +#if defined(dbPostgres) +import Fixtures +import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) +#else +import AgentTests.SchemaDump (schemaDumpTest) +#endif logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} @@ -45,10 +51,17 @@ main = do setEnv "APNS_KEY_ID" "H82WD9K9AQ" setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" hspec +#if defined(dbPostgres) + . beforeAll_ (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo) + . afterAll_ (dropDatabaseAndUser testDBConnectInfo) +#endif . before_ (createDirectoryIfMissing False "tests/tmp") . after_ (eventuallyRemove "tests/tmp" 3) $ do +-- TODO [postgres] schema dump for postgres +#if !defined(dbPostgres) describe "Agent SQLite schema dump" schemaDumpTest +#endif describe "Core tests" $ do describe "Batching tests" batchingTests describe "Encoding tests" encodingTests diff --git a/tests/Util.hs b/tests/Util.hs index 6ad6d054f..0ad371b69 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,9 +1,10 @@ module Util where -import Control.Monad (replicateM) +import Control.Monad (replicateM, when) import Data.Either (partitionEithers) import Data.List (tails) import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) +import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO @@ -26,3 +27,8 @@ inParrallel n action = do combinations :: Int -> [a] -> [[a]] combinations 0 _ = [[]] combinations k xs = [y : ys | y : xs' <- tails xs, ys <- combinations (k - 1) xs'] + +removeFileIfExists :: FilePath -> IO () +removeFileIfExists filePath = do + fileExists <- doesFileExist filePath + when fileExists $ removeFile filePath diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 6d6446959..f7e880083 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -46,40 +47,49 @@ import UnliftIO import UnliftIO.Concurrent import XFTPCLI import XFTPClient +#if defined(dbPostgres) +import Fixtures +import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) +#endif xftpAgentTests :: Spec -xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do - it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive - -- uncomment CPP option slow_servers and run hpack to run this test - xit "should send and receive file with slow server responses" $ - withXFTPServerCfg testXFTPServerConfig {responseDelay = 500000} $ - \_ -> testXFTPAgentSendReceive - it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted - it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect - it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect - describe "sending and receiving with version negotiation" testXFTPAgentSendReceiveMatrix - it "should resume receiving file after restart" testXFTPAgentReceiveRestore - it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup - it "should resume sending file after restart" testXFTPAgentSendRestore - xit'' "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup - it "should delete sent file on server" testXFTPAgentDelete - it "should resume deleting file after restart" testXFTPAgentDeleteRestore - -- TODO when server is fixed to correctly send AUTH error, this test has to be modified to expect AUTH error - it "if file is deleted on server, should limit retries and continue receiving next file" testXFTPAgentDeleteOnServer - it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer - it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs - describe "XFTP server test via agent API" $ do - it "should pass without basic auth" $ testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing - let srv1 = testXFTPServer2 {keyHash = "1234"} - it "should fail with incorrect fingerprint" $ do - testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) - describe "server with password" $ do - let auth = Just "abcd" - srv = ProtoServerWithAuth testXFTPServer2 - authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH) - it "should pass with correct password" $ testXFTPServerTest auth (srv auth) `shouldReturn` Nothing - it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr - it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr +xftpAgentTests = + around_ testBracket +#if defined(dbPostgres) + . after_ (dropAllSchemasExceptSystem testDBConnectInfo) +#endif + . describe "agent XFTP API" $ do + it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive + -- uncomment CPP option slow_servers and run hpack to run this test + xit "should send and receive file with slow server responses" $ + withXFTPServerCfg testXFTPServerConfig {responseDelay = 500000} $ + \_ -> testXFTPAgentSendReceive + it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted + it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect + it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect + describe "sending and receiving with version negotiation" testXFTPAgentSendReceiveMatrix + it "should resume receiving file after restart" testXFTPAgentReceiveRestore + it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup + it "should resume sending file after restart" testXFTPAgentSendRestore + xit'' "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup + it "should delete sent file on server" testXFTPAgentDelete + it "should resume deleting file after restart" testXFTPAgentDeleteRestore + -- TODO when server is fixed to correctly send AUTH error, this test has to be modified to expect AUTH error + it "if file is deleted on server, should limit retries and continue receiving next file" testXFTPAgentDeleteOnServer + it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer + it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs + describe "XFTP server test via agent API" $ do + it "should pass without basic auth" $ testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing + let srv1 = testXFTPServer2 {keyHash = "1234"} + it "should fail with incorrect fingerprint" $ do + testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK) + describe "server with password" $ do + let auth = Just "abcd" + srv = ProtoServerWithAuth testXFTPServer2 + authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH) + it "should pass with correct password" $ testXFTPServerTest auth (srv auth) `shouldReturn` Nothing + it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr + it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr rfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m () rfProgress c expected = loop 0 From bf289023273f2b94f8649b4c641e1cc9996b8a4b Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 25 Dec 2024 04:07:45 +0400 Subject: [PATCH 04/51] agent: reuse ratchet on repeat join (#1426) * agent: reuse ratchet on repeat join * check status * update --------- Co-authored-by: Evgeny Poberezkin --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 40 +++++++++++------ src/Simplex/Messaging/Agent/Store/SQLite.hs | 44 ++++++++++++++++--- .../Agent/Store/SQLite/Migrations.hs | 4 +- .../M20241224_ratchet_e2e_snd_params.hs | 18 ++++++++ .../Store/SQLite/Migrations/agent_schema.sql | 3 +- src/Simplex/Messaging/Crypto/Ratchet.hs | 4 ++ 7 files changed, 92 insertions(+), 22 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20241224_ratchet_e2e_snd_params.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index cee56ad5e..8e9245743 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -130,6 +130,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index f267baf28..1f839b297 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -834,26 +834,39 @@ joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448) startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = lift (compatibleInvitationUri cReqUri) >>= \case - Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do - g <- asks random + Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do + -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out + -- e2ePubKey is always present, it's Maybe historically let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) + (sq', e2eSndParams) <- case sq_ of + Just sq@SndQueue {e2ePubKey = Just _k} -> do + e2eSndParams <- + withStore' c (\db -> getSndRatchet db connId v) >>= \case + Right r -> pure $ snd r + Left e -> do + atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) + createRatchet_ pqSupport e2eRcvParams + pure (sq, e2eSndParams) + _ -> do + q <- lift $ fst <$> newSndQueue userId "" qInfo + e2eSndParams <- createRatchet_ pqSupport e2eRcvParams + withStore c $ \db -> runExceptT $ do + sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_ + pure (sq', e2eSndParams) + let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} + pure (cData, sq', e2eSndParams) + Nothing -> throwE $ AGENT A_VERSION + where + createRatchet_ pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do + g <- asks random (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) (_, rcDHRs) <- atomically $ C.generateKeyPair g rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let rcVs = CR.RatchetVersions {current = v, maxSupported} rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams - -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out - -- e2ePubKey is always present, it's Maybe historically - q <- case sq_ of - Just sq@SndQueue {e2ePubKey = Just _k} -> pure (sq :: SndQueue) {dbQueueId = DBNewQueue} - _ -> lift $ fst <$> newSndQueue userId "" qInfo - let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - sq' <- withStore c $ \db -> runExceptT $ do - liftIO $ createRatchet db connId rc - maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_ - pure (cData, sq', e2eSndParams) - Nothing -> throwE $ AGENT A_VERSION + withStore' c $ \db -> createSndRatchet db connId rc e2eSndParams + pure e2eSndParams connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport)) connRequestPQSupport c pqSup cReq = withAgentEnv' c $ case cReq of @@ -892,6 +905,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod case conn of NewConnection _ -> doJoin Nothing SndConnection _ sq -> doJoin $ Just sq + DuplexConnection _ (RcvQueue {status = New} :| _) (sq@SndQueue {status = New} :| _) -> doJoin $ Just sq _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType where doJoin :: Maybe SndQueue -> AM SndQueueSecured diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 7e60e4070..59b1d8687 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -131,6 +131,8 @@ module Simplex.Messaging.Agent.Store.SQLite -- Double ratchet persistence createRatchetX3dhKeys, getRatchetX3dhKeys, + createSndRatchet, + getSndRatchet, setRatchetX3dhKeys, createRatchet, deleteRatchet, @@ -245,7 +247,6 @@ where import Control.Logger.Simple import Control.Monad -import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) @@ -586,7 +587,6 @@ updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreEr updateNewConnSnd db connId sq = getConn db connId $>>= \case (SomeConn _ NewConnection {}) -> updateConn - (SomeConn _ SndConnection {}) -> updateConn -- to allow retries (SomeConn c _) -> pure . Left . SEBadConnType $ connType c where updateConn :: IO (Either StoreError SndQueue) @@ -1250,19 +1250,48 @@ getRatchetX3dhKeys db connId = (Just k1, Just k2, pKem) -> Right (k1, k2, pKem) _ -> Left SEX3dhKeysNotFound +createSndRatchet :: DB.Connection -> ConnId -> RatchetX448 -> CR.AE2ERatchetParams 'C.X448 -> IO () +createSndRatchet db connId ratchetState (CR.AE2ERatchetParams s (CR.E2ERatchetParams _ x3dhPubKey1 x3dhPubKey2 pqPubKem)) = + DB.execute + db + [sql| + INSERT INTO ratchets + (conn_id, ratchet_state, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem) VALUES (?, ?, ?, ?, ?) + ON CONFLICT (conn_id) DO UPDATE SET + ratchet_state = EXCLUDED.ratchet_state, + x3dh_priv_key_1 = NULL, + x3dh_priv_key_2 = NULL, + x3dh_pub_key_1 = EXCLUDED.x3dh_pub_key_1, + x3dh_pub_key_2 = EXCLUDED.x3dh_pub_key_2, + pq_priv_kem = NULL, + pq_pub_kem = EXCLUDED.pq_pub_kem + |] + (connId, ratchetState, x3dhPubKey1, x3dhPubKey2, CR.ARKP s <$> pqPubKem) + +getSndRatchet :: DB.Connection -> ConnId -> CR.VersionE2E -> IO (Either StoreError (RatchetX448, CR.AE2ERatchetParams 'C.X448)) +getSndRatchet db connId v = + firstRow' result SEX3dhKeysNotFound $ + DB.query db "SELECT ratchet_state, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem FROM ratchets WHERE conn_id = ?" (Only connId) + where + result = \case + (Just ratchetState, Just k1, Just k2, pKem_) -> + let params = case pKem_ of + Nothing -> CR.AE2ERatchetParams CR.SRKSProposed (CR.E2ERatchetParams v k1 k2 Nothing) + Just (CR.ARKP s pKem) -> CR.AE2ERatchetParams s (CR.E2ERatchetParams v k1 k2 (Just pKem)) + in Right (ratchetState, params) + _ -> Left SEX3dhKeysNotFound + -- used to remember new keys when starting ratchet re-synchronization --- TODO remove the columns for public keys in v5.7. --- Currently, the keys are not used but still stored to support app downgrade to the previous version. setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO () setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = DB.execute db [sql| UPDATE ratchets - SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? + SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, pq_priv_kem = ? WHERE conn_id = ? |] - (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId) + (x3dhPrivKey1, x3dhPrivKey2, pqPrivKem, connId) -- TODO remove the columns for public keys in v5.7. createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO () @@ -1278,7 +1307,8 @@ createRatchet db connId rc = x3dh_priv_key_2 = NULL, x3dh_pub_key_1 = NULL, x3dh_pub_key_2 = NULL, - pq_priv_kem = NULL + pq_priv_kem = NULL, + pq_pub_kem = NULL |] [":conn_id" := connId, ":ratchet_state" := rc] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 7e58ceec5..ca78dbf42 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -76,6 +76,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Transport.Client (TransportHost) @@ -120,7 +121,8 @@ schemaMigrations = ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure), ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats), ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete), - ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts) + ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts), + ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20241224_ratchet_e2e_snd_params.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20241224_ratchet_e2e_snd_params.hs new file mode 100644 index 000000000..36e8ddedd --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20241224_ratchet_e2e_snd_params.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20241224_ratchet_e2e_snd_params :: Query +m20241224_ratchet_e2e_snd_params = + [sql| +ALTER TABLE ratchets ADD COLUMN pq_pub_kem BLOB; +|] + +down_m20241224_ratchet_e2e_snd_params :: Query +down_m20241224_ratchet_e2e_snd_params = + [sql| +ALTER TABLE ratchets DROP COLUMN pq_pub_kem; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 11e944e6b..5b9339b4f 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -166,7 +166,8 @@ CREATE TABLE ratchets( , x3dh_pub_key_1 BLOB, x3dh_pub_key_2 BLOB, - pq_priv_kem BLOB + pq_priv_kem BLOB, + pq_pub_kem BLOB ) WITHOUT ROWID; CREATE TABLE skipped_messages( skipped_message_id INTEGER PRIMARY KEY, diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 148d931a9..1d22843ff 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -206,6 +206,10 @@ instance Encoding ARKEMParams where 'A' -> ARKP SRKSAccepted .: RKParamsAccepted <$> smpP <*> smpP _ -> fail "bad ratchet KEM params" +instance ToField ARKEMParams where toField = toField . smpEncode + +instance FromField ARKEMParams where fromField = blobFieldDecoder smpDecode + data E2ERatchetParams (s :: RatchetKEMState) (a :: Algorithm) = E2ERatchetParams VersionE2E (PublicKey a) (PublicKey a) (Maybe (RKEMParams s)) deriving (Show) From 184a95cd2a2806fb3d318508ca1f6528201a8114 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 26 Dec 2024 13:54:38 +0000 Subject: [PATCH 05/51] 6.3.0.0 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 8e9245743..97ada9f55 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.2.2.0 +version: 6.3.0.0 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 0b986c11580ca1cea988521598c5f8ae215f7e07 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Thu, 26 Dec 2024 20:13:27 +0400 Subject: [PATCH 06/51] postgres: export fromOnlyBI --- src/Simplex/Messaging/Agent/Store/AgentStore.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 610aa68b0..5dcda9c79 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -227,6 +227,7 @@ module Simplex.Messaging.Agent.Store.AgentStore firstRow, firstRow', maybeFirstRow, + fromOnlyBI, ) where From cfde5932fd275c2fc329fab336f0f7809c9e2d00 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 28 Dec 2024 10:33:22 +0000 Subject: [PATCH 07/51] agent: restore methods for backwards compatibility with simplex-chat --- src/Simplex/Messaging/Agent/Store/SQLite/DB.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 7e8406d5c..46c0847d1 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -16,8 +16,10 @@ module Simplex.Messaging.Agent.Store.SQLite.DB execute, execute_, executeMany, + executeNamed, query, query_, + queryNamed, ) where @@ -31,7 +33,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) import Data.Time (diffUTCTime, getCurrentTime) -import Database.SQLite.Simple (FromRow, Query, ToRow) +import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow) import qualified Database.SQLite.Simple as SQL import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) @@ -103,6 +105,11 @@ execute_ :: Connection -> Query -> IO () execute_ Connection {conn, slow} sql = timeIt slow sql $ SQL.execute_ conn sql {-# INLINE execute_ #-} +-- TODO [postgres] remove +executeNamed :: Connection -> Query -> [NamedParam] -> IO () +executeNamed Connection {conn, slow} sql = timeIt slow sql . SQL.executeNamed conn sql +{-# INLINE executeNamed #-} + executeMany :: ToRow q => Connection -> Query -> [q] -> IO () executeMany Connection {conn, slow} sql = timeIt slow sql . SQL.executeMany conn sql {-# INLINE executeMany #-} @@ -115,4 +122,9 @@ query_ :: FromRow r => Connection -> Query -> IO [r] query_ Connection {conn, slow} sql = timeIt slow sql $ SQL.query_ conn sql {-# INLINE query_ #-} +-- TODO [postgres] remove +queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r] +queryNamed Connection {conn, slow} sql = timeIt slow sql . SQL.queryNamed conn sql +{-# INLINE queryNamed #-} + $(J.deriveJSON defaultJSON ''SlowQueryStats) From 992b42e92224ec663684923aaa40ed1f9a683f61 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 28 Dec 2024 21:06:42 +0000 Subject: [PATCH 08/51] agent: option to enable/disable vacuum after SQLite migration (#1429) --- src/Simplex/Messaging/Agent/Env/SQLite.hs | 2 +- src/Simplex/Messaging/Agent/Store.hs | 14 +++++------ .../Messaging/Agent/Store/Migrations.hs | 24 +++++++++---------- src/Simplex/Messaging/Agent/Store/Postgres.hs | 2 +- .../Agent/Store/Postgres/Migrations.hs | 4 ++-- src/Simplex/Messaging/Agent/Store/SQLite.hs | 6 ++--- .../Agent/Store/SQLite/Migrations.hs | 8 ++++--- tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/AgentTests/MigrationTests.hs | 2 +- tests/AgentTests/SQLiteTests.hs | 2 +- tests/AgentTests/SchemaDump.hs | 18 +++++++------- 11 files changed, 43 insertions(+), 41 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 80a307efa..f1e0aaf15 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -281,7 +281,7 @@ newSMPAgentEnv config store = do createAgentStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore) createAgentStore = createStore #else -createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore) createAgentStore = createStore #endif diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index c199e480b..ff8c29b6c 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -56,25 +56,25 @@ import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP #if defined(dbPostgres) import Database.PostgreSQL.Simple (ConnectInfo (..)) -import qualified Simplex.Messaging.Agent.Store.Postgres as StoreFunctions +import qualified Simplex.Messaging.Agent.Store.Postgres as Store #else import Data.ByteArray (ScrubbedBytes) -import qualified Simplex.Messaging.Agent.Store.SQLite as StoreFunctions +import qualified Simplex.Messaging.Agent.Store.SQLite as Store #endif #if defined(dbPostgres) createStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore connectInfo schema = StoreFunctions.createDBStore connectInfo schema Migrations.app +createStore connectInfo schema = Store.createDBStore connectInfo schema Migrations.app #else -createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore dbFilePath dbKey keepKey = StoreFunctions.createDBStore dbFilePath dbKey keepKey Migrations.app +createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore) +createStore dbFilePath dbKey keepKey = Store.createDBStore dbFilePath dbKey keepKey Migrations.app #endif closeStore :: DBStore -> IO () -closeStore = StoreFunctions.closeDBStore +closeStore = Store.closeDBStore execSQL :: DB.Connection -> Text -> IO [Text] -execSQL = StoreFunctions.execSQL +execSQL = Store.execSQL -- * Queue types diff --git a/src/Simplex/Messaging/Agent/Store/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Migrations.hs index 35015f634..7dc1528f1 100644 --- a/src/Simplex/Messaging/Agent/Store/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Migrations.hs @@ -48,8 +48,8 @@ migrationsToRun (a : as) (d : ds) | name a == name d = migrationsToRun as ds | otherwise = Left $ MTREDifferent (name a) (name d) -migrateSchema :: DBStore -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ()) -migrateSchema st migrations confirmMigrations = do +migrateSchema :: DBStore -> [Migration] -> MigrationConfirmation -> Bool -> IO (Either MigrationError ()) +migrateSchema st migrations confirmMigrations vacuum = do Migrations.initialize st get st migrations >>= \case Left e -> do @@ -57,17 +57,17 @@ migrateSchema st migrations confirmMigrations = do pure . Left $ MigrationError e Right MTRNone -> pure $ Right () Right ms@(MTRUp ums) - | dbNew st -> Migrations.run st ms $> Right () + | dbNew st -> Migrations.run st vacuum ms $> Right () | otherwise -> case confirmMigrations of - MCYesUp -> runWithBackup st ms - MCYesUpDown -> runWithBackup st ms - MCConsole -> confirm err >> runWithBackup st ms + MCYesUp -> runWithBackup st vacuum ms + MCYesUpDown -> runWithBackup st vacuum ms + MCConsole -> confirm err >> runWithBackup st vacuum ms MCError -> pure $ Left err where err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums) Right ms@(MTRDown dms) -> case confirmMigrations of - MCYesUpDown -> runWithBackup st ms - MCConsole -> confirm err >> runWithBackup st ms + MCYesUpDown -> runWithBackup st vacuum ms + MCConsole -> confirm err >> runWithBackup st vacuum ms MCYesUp -> pure $ Left err MCError -> pure $ Left err where @@ -75,14 +75,14 @@ migrateSchema st migrations confirmMigrations = do where confirm err = confirmOrExit $ migrationErrorDescription err -runWithBackup :: DBStore -> MigrationsToRun -> IO (Either a ()) +runWithBackup :: DBStore -> Bool -> MigrationsToRun -> IO (Either a ()) #if defined(dbPostgres) -runWithBackup st ms = Migrations.run st ms $> Right () +runWithBackup st vacuum ms = Migrations.run st vacuum ms $> Right () #else -runWithBackup st ms = do +runWithBackup st vacuum ms = do let f = dbFilePath st copyFile f (f <> ".bak") - Migrations.run st ms + Migrations.run st vacuum ms pure $ Right () #endif diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index a4c8a52bb..897c31965 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -46,7 +46,7 @@ createDBStore :: ConnectInfo -> String -> [Migration] -> MigrationConfirmation - createDBStore connectInfo schema migrations confirmMigrations = do createDBAndUserIfNotExists connectInfo st <- connectPostgresStore connectInfo schema - r <- migrateSchema st migrations confirmMigrations `onException` closeDBStore st + r <- migrateSchema st migrations confirmMigrations True `onException` closeDBStore st case r of Right () -> pure $ Right st Left e -> closeDBStore st $> Left e diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs index bf8d56caa..9f8d5744d 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs @@ -53,8 +53,8 @@ initialize st = withTransaction' st $ \db -> ) |] -run :: DBStore -> MigrationsToRun -> IO () -run st = \case +run :: DBStore -> Bool -> MigrationsToRun -> IO () +run st _vacuum = \case MTRUp [] -> pure () MTRUp ms -> mapM_ runUp ms MTRDown ms -> mapM_ runDown $ reverse ms diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 816968208..4e03bb6f3 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -65,12 +65,12 @@ import UnliftIO.STM -- * SQLite Store implementation -createDBStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createDBStore dbFilePath dbKey keepKey migrations confirmMigrations = do +createDBStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore) +createDBStore dbFilePath dbKey keepKey migrations confirmMigrations vacuum = do let dbDir = takeDirectory dbFilePath createDirectoryIfMissing True dbDir st <- connectSQLiteStore dbFilePath dbKey keepKey - r <- migrateSchema st migrations confirmMigrations `onException` closeDBStore st + r <- migrateSchema st migrations confirmMigrations vacuum `onException` closeDBStore st case r of Right () -> pure $ Right st Left e -> closeDBStore st $> Left e diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 2f3c6010e..73ab17e5a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -122,10 +122,12 @@ getCurrent DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT where toMigration (name, down) = Migration {name, up = "", down} -run :: DBStore -> MigrationsToRun -> IO () -run st = \case +run :: DBStore -> Bool -> MigrationsToRun -> IO () +run st vacuum = \case MTRUp [] -> pure () - MTRUp ms -> mapM_ runUp ms >> withConnection' st (`execSQL` "VACUUM;") + MTRUp ms -> do + mapM_ runUp ms + when vacuum $ withConnection' st (`execSQL` "VACUUM;") MTRDown ms -> mapM_ runDown $ reverse ms MTRNone -> pure () where diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 9c3c5a972..f569cc3d5 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -3113,7 +3113,7 @@ insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") #else createStore :: String -> IO (Either MigrationError DBStore) -createStore dbPath = createAgentStore dbPath "" False MCError +createStore dbPath = createAgentStore dbPath "" False MCError True insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)") diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index fb8550a7d..9bbb41be1 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/tests/AgentTests/MigrationTests.hs @@ -218,7 +218,7 @@ testDB :: Word32 -> FilePath testDB randSuffix = "tests/tmp/test_migrations.db" <> show randSuffix createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore randSuffix = createDBStore (testDB randSuffix) "" False +createStore randSuffix migrations migrationConf = createDBStore (testDB randSuffix) "" False migrations migrationConf True cleanup :: Word32 -> IO () cleanup randSuffix = removeFile (testDB randSuffix) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 3fb791af6..51112c426 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -81,7 +81,7 @@ createEncryptedStore key keepKey = 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 - Right st <- createDBStore (testDB <> show r) key keepKey Migrations.app MCError + Right st <- createDBStore (testDB <> show r) key keepKey Migrations.app MCError True withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);") pure st diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index b7fcce8ee..ba81bc79c 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -49,7 +49,7 @@ testVerifySchemaDump :: IO () testVerifySchemaDump = do savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "") savedSchema `deepseq` pure () - void $ createDBStore testDB "" False Migrations.app MCConsole + void $ createDBStore testDB "" False Migrations.app MCConsole True getSchema testDB appSchema `shouldReturn` savedSchema removeFile testDB @@ -57,7 +57,7 @@ testVerifyLintFKeyIndexes :: IO () testVerifyLintFKeyIndexes = do savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "") savedLint `deepseq` pure () - void $ createDBStore testDB "" False Migrations.app MCConsole + void $ createDBStore testDB "" False Migrations.app MCConsole True getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint removeFile testDB @@ -70,7 +70,7 @@ withTmpFiles = testSchemaMigrations :: IO () testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app - Right st <- createDBStore testDB "" False noDownMigrations MCError + Right st <- createDBStore testDB "" False noDownMigrations MCError True mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app closeDBStore st removeFile testDB @@ -80,20 +80,20 @@ testSchemaMigrations = do putStrLn $ "down migration " <> name m let downMigr = fromJust $ toDownMigration m schema <- getSchema testDB testSchema - Migrations.run st $ MTRUp [m] + Migrations.run st True $ MTRUp [m] schema' <- getSchema testDB testSchema schema' `shouldNotBe` schema - Migrations.run st $ MTRDown [downMigr] + Migrations.run st True $ MTRDown [downMigr] unless (name m `elem` skipComparisonForDownMigrations) $ do schema'' <- getSchema testDB testSchema schema'' `shouldBe` schema - Migrations.run st $ MTRUp [m] + Migrations.run st True $ MTRUp [m] schema''' <- getSchema testDB testSchema schema''' `shouldBe` schema' testUsersMigrationNew :: IO () testUsersMigrationNew = do - Right st <- createDBStore testDB "" False Migrations.app MCError + Right st <- createDBStore testDB "" False Migrations.app MCError True withTransaction' st (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([] :: [Only Int]) closeDBStore st @@ -101,11 +101,11 @@ testUsersMigrationNew = do testUsersMigrationOld :: IO () testUsersMigrationOld = do let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app - Right st <- createDBStore testDB "" False beforeUsers MCError + Right st <- createDBStore testDB "" False beforeUsers MCError True withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';") `shouldReturn` ([] :: [Only String]) closeDBStore st - Right st' <- createDBStore testDB "" False Migrations.app MCYesUp + Right st' <- createDBStore testDB "" False Migrations.app MCYesUp True withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([Only (1 :: Int)]) closeDBStore st' From 9d9ec8cd0b171b2058c59c4e7292ccafa96b6e2b Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 10 Jan 2025 11:59:17 +0400 Subject: [PATCH 09/51] agent: remove unused functions (#1432) * agent: remove unused functions * cleanup imports --- src/Simplex/Messaging/Agent/Store/Postgres.hs | 8 -------- src/Simplex/Messaging/Agent/Store/SQLite/DB.hs | 14 +------------- tests/Fixtures.hs | 2 +- 3 files changed, 2 insertions(+), 22 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 897c31965..ad66c7763 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -5,7 +5,6 @@ module Simplex.Messaging.Agent.Store.Postgres ( createDBStore, - defaultSimplexConnectInfo, closeDBStore, execSQL ) @@ -29,13 +28,6 @@ import UnliftIO.Exception (onException) import UnliftIO.MVar import UnliftIO.STM -defaultSimplexConnectInfo :: ConnectInfo -defaultSimplexConnectInfo = - defaultConnectInfo - { connectUser = "simplex", - connectDatabase = "simplex_v6_3_client_db" - } - -- | Create a new Postgres DBStore with the given connection info, schema name and migrations. -- This function creates the user and/or database passed in connectInfo if they do not exist -- (expects the default 'postgres' user and 'postgres' db to exist). diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 46c0847d1..7e8406d5c 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -16,10 +16,8 @@ module Simplex.Messaging.Agent.Store.SQLite.DB execute, execute_, executeMany, - executeNamed, query, query_, - queryNamed, ) where @@ -33,7 +31,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) import Data.Time (diffUTCTime, getCurrentTime) -import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow) +import Database.SQLite.Simple (FromRow, Query, ToRow) import qualified Database.SQLite.Simple as SQL import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) @@ -105,11 +103,6 @@ execute_ :: Connection -> Query -> IO () execute_ Connection {conn, slow} sql = timeIt slow sql $ SQL.execute_ conn sql {-# INLINE execute_ #-} --- TODO [postgres] remove -executeNamed :: Connection -> Query -> [NamedParam] -> IO () -executeNamed Connection {conn, slow} sql = timeIt slow sql . SQL.executeNamed conn sql -{-# INLINE executeNamed #-} - executeMany :: ToRow q => Connection -> Query -> [q] -> IO () executeMany Connection {conn, slow} sql = timeIt slow sql . SQL.executeMany conn sql {-# INLINE executeMany #-} @@ -122,9 +115,4 @@ query_ :: FromRow r => Connection -> Query -> IO [r] query_ Connection {conn, slow} sql = timeIt slow sql $ SQL.query_ conn sql {-# INLINE query_ #-} --- TODO [postgres] remove -queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r] -queryNamed Connection {conn, slow} sql = timeIt slow sql . SQL.queryNamed conn sql -{-# INLINE queryNamed #-} - $(J.deriveJSON defaultJSON ''SlowQueryStats) diff --git a/tests/Fixtures.hs b/tests/Fixtures.hs index a8e2542ec..54065d121 100644 --- a/tests/Fixtures.hs +++ b/tests/Fixtures.hs @@ -10,7 +10,7 @@ import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) testDBConnectInfo :: ConnectInfo testDBConnectInfo = defaultConnectInfo { - connectUser = "test_user", + connectUser = "test_agent_user", connectDatabase = "test_agent_db" } #endif From 3d4e0b06c04a13555c55c2e0efde56f9f78e7ea1 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 12 Jan 2025 19:34:00 +0000 Subject: [PATCH 10/51] servers: blocking records for content moderation (#1430) * servers: blocking records for content moderation * update * encode BLOCKED as AUTH in old versions * update * unblock queue command * test, status command --- src/Simplex/FileTransfer/Protocol.hs | 8 +- src/Simplex/FileTransfer/Server.hs | 51 ++++++++---- src/Simplex/FileTransfer/Server/Control.hs | 5 +- src/Simplex/FileTransfer/Server/Stats.hs | 15 +++- src/Simplex/FileTransfer/Server/Store.hs | 20 ++++- src/Simplex/FileTransfer/Server/StoreLog.hs | 12 ++- src/Simplex/FileTransfer/Transport.hs | 52 ++++++++++-- src/Simplex/Messaging/Parsers.hs | 1 + src/Simplex/Messaging/Protocol.hs | 83 +++++++++++++++++-- src/Simplex/Messaging/Server.hs | 61 ++++++++++---- src/Simplex/Messaging/Server/Control.hs | 17 +++- src/Simplex/Messaging/Server/Prometheus.hs | 7 ++ src/Simplex/Messaging/Server/QueueStore.hs | 22 ++++- .../Messaging/Server/QueueStore/STM.hs | 26 +++++- src/Simplex/Messaging/Server/Stats.hs | 20 +++++ src/Simplex/Messaging/Server/StoreLog.hs | 52 ++++++++---- src/Simplex/Messaging/Transport.hs | 11 ++- tests/CoreTests/MsgStoreTests.hs | 2 +- tests/ServerTests.hs | 36 ++++++-- tests/XFTPServerTests.hs | 8 +- 20 files changed, 415 insertions(+), 94 deletions(-) diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 5899f9c3e..9bf552732 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -25,7 +25,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) -import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, xftpClientHandshakeStub) +import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub) import Simplex.Messaging.Client (authTransmission) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -276,12 +276,14 @@ data FileResponse instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where type Tag FileResponse = FileResponseTag - encodeProtocol _v = \case + encodeProtocol v = \case FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds) FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds) FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce) FROk -> e FROk_ - FRErr err -> e (FRErr_, ' ', err) + FRErr err -> case err of + BLOCKED _ | v < blockedFilesXFTPVersion -> e (FRErr_, ' ', AUTH) + _ -> e (FRErr_, ' ', err) FRPong -> e FRPong_ where e :: Encoding a => a -> ByteString diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 29cc5bf6a..935afe2f9 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -53,11 +53,11 @@ import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity) +import Simplex.Messaging.Protocol (CorrId (..), BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization) import Simplex.Messaging.Server.Control (CPClientRole (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..), getRoundedSystemTime) import Simplex.Messaging.Server.Stats import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -287,11 +287,15 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira CPDelete fileId -> withUserRole $ unliftIO u $ do fs <- asks store r <- runExceptT $ do - let asSender = ExceptT . atomically $ getFile fs SFSender fileId - let asRecipient = ExceptT . atomically $ getFile fs SFRecipient fileId - (fr, _) <- asSender `catchError` const asRecipient + (fr, _) <- ExceptT $ atomically $ getFile fs SFSender fileId ExceptT $ deleteServerFile_ fr liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r + CPBlock fileId info -> withUserRole $ unliftIO u $ do + fs <- asks store + r <- runExceptT $ do + (fr, _) <- ExceptT $ atomically $ getFile fs SFSender fileId + ExceptT $ blockServerFile fr info + liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit" CPQuit -> pure () CPSkip -> pure () @@ -321,7 +325,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea let THandleParams {thAuth} = thParams verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case VRVerified req -> uncurry send =<< processXFTPRequest body req - VRFailed -> send (FRErr AUTH) Nothing + VRFailed e -> send (FRErr e) Nothing Left e -> send (FRErr e) Nothing where send resp = sendXFTPResponse (corrId, fId, resp) @@ -355,7 +359,7 @@ randomDelay = do threadDelay $ (d * (1000 + pc)) `div` 1000 #endif -data VerificationResult = VRVerified XFTPRequest | VRFailed +data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult verifyXFTPTransmission auth_ tAuth authorized fId cmd = @@ -367,13 +371,19 @@ verifyXFTPTransmission auth_ tAuth authorized fId cmd = verifyCmd :: SFileParty p -> M VerificationResult verifyCmd party = do st <- asks store - atomically $ verify <$> getFile st party fId + atomically $ verify =<< getFile st party fId where verify = \case - Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k - _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed + Right (fr, k) -> result <$> readTVar (fileStatus fr) + where + result = \case + EntityActive -> XFTPReqCmd fId fr cmd `verifyWith` k + EntityBlocked info -> VRFailed $ BLOCKED info + EntityOff -> noFileAuth + Left _ -> pure noFileAuth + noFileAuth = maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed AUTH -- TODO verify with DH authorization - req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed + req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed AUTH processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile) processXFTPRequest HTTP2Body {bodyPart} = \case @@ -390,7 +400,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case FACK -> noFile =<< ackFileReception fId fr -- it should never get to the commands below, they are passed in other constructors of XFTPRequest FNEW {} -> noFile $ FRErr INTERNAL - PING -> noFile FRPong + PING -> noFile $ FRErr INTERNAL XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) @@ -518,15 +528,24 @@ processXFTPRequest HTTP2Body {bodyPart} = \case pure FROk deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ()) -deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do +deleteServerFile_ fr@FileRec {senderId} = do withFileLog (`logDeleteFile` senderId) - runExceptT $ do + deleteOrBlockServerFile_ fr filesDeleted (`deleteFile` senderId) + +-- this also deletes the file from storage, but doesn't include it in delete statistics +blockServerFile :: FileRec -> BlockingInfo -> M (Either XFTPErrorType ()) +blockServerFile fr@FileRec {senderId} info = do + withFileLog $ \sl -> logBlockFile sl senderId info + deleteOrBlockServerFile_ fr filesBlocked $ \st -> blockFile st senderId info True + +deleteOrBlockServerFile_ :: FileRec -> (FileServerStats -> IORef Int) -> (FileStore -> STM (Either XFTPErrorType ())) -> M (Either XFTPErrorType ()) +deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExceptT $ do path <- readTVarIO filePath stats <- asks serverStats ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats)) st <- asks store - void $ atomically $ deleteFile st senderId - lift $ incFileStat filesDeleted + void $ atomically $ storeAction st + lift $ incFileStat stat where deletedStats stats = do liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1) diff --git a/src/Simplex/FileTransfer/Server/Control.hs b/src/Simplex/FileTransfer/Server/Control.hs index 3a84ace49..2be8113db 100644 --- a/src/Simplex/FileTransfer/Server/Control.hs +++ b/src/Simplex/FileTransfer/Server/Control.hs @@ -6,12 +6,13 @@ module Simplex.FileTransfer.Server.Control where import qualified Data.Attoparsec.ByteString.Char8 as A import Simplex.FileTransfer.Protocol (XFTPFileId) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (BasicAuth) +import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo) data ControlProtocol = CPAuth BasicAuth | CPStatsRTS | CPDelete XFTPFileId + | CPBlock XFTPFileId BlockingInfo | CPHelp | CPQuit | CPSkip @@ -21,6 +22,7 @@ instance StrEncoding ControlProtocol where CPAuth tok -> "auth " <> strEncode tok CPStatsRTS -> "stats-rts" CPDelete fId -> strEncode (Str "delete", fId) + CPBlock fId info -> strEncode (Str "block", fId, info) CPHelp -> "help" CPQuit -> "quit" CPSkip -> "" @@ -29,6 +31,7 @@ instance StrEncoding ControlProtocol where "auth" -> CPAuth <$> _strP "stats-rts" -> pure CPStatsRTS "delete" -> CPDelete <$> _strP + "block" -> CPBlock <$> _strP <*> _strP "help" -> pure CPHelp "quit" -> pure CPQuit "" -> pure CPSkip diff --git a/src/Simplex/FileTransfer/Server/Stats.hs b/src/Simplex/FileTransfer/Server/Stats.hs index a7951a65a..2f38c7447 100644 --- a/src/Simplex/FileTransfer/Server/Stats.hs +++ b/src/Simplex/FileTransfer/Server/Stats.hs @@ -20,6 +20,7 @@ data FileServerStats = FileServerStats filesUploaded :: IORef Int, filesExpired :: IORef Int, filesDeleted :: IORef Int, + filesBlocked :: IORef Int, filesDownloaded :: PeriodStats, fileDownloads :: IORef Int, fileDownloadAcks :: IORef Int, @@ -34,6 +35,7 @@ data FileServerStatsData = FileServerStatsData _filesUploaded :: Int, _filesExpired :: Int, _filesDeleted :: Int, + _filesBlocked :: Int, _filesDownloaded :: PeriodStatsData, _fileDownloads :: Int, _fileDownloadAcks :: Int, @@ -50,12 +52,13 @@ newFileServerStats ts = do filesUploaded <- newIORef 0 filesExpired <- newIORef 0 filesDeleted <- newIORef 0 + filesBlocked <- newIORef 0 filesDownloaded <- newPeriodStats fileDownloads <- newIORef 0 fileDownloadAcks <- newIORef 0 filesCount <- newIORef 0 filesSize <- newIORef 0 - pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} + pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesBlocked, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} getFileServerStatsData :: FileServerStats -> IO FileServerStatsData getFileServerStatsData s = do @@ -65,12 +68,13 @@ getFileServerStatsData s = do _filesUploaded <- readIORef $ filesUploaded s _filesExpired <- readIORef $ filesExpired s _filesDeleted <- readIORef $ filesDeleted s + _filesBlocked <- readIORef $ filesBlocked s _filesDownloaded <- getPeriodStatsData $ filesDownloaded s _fileDownloads <- readIORef $ fileDownloads s _fileDownloadAcks <- readIORef $ fileDownloadAcks s _filesCount <- readIORef $ filesCount s _filesSize <- readIORef $ filesSize s - pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} + pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesBlocked, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} -- this function is not thread safe, it is used on server start only setFileServerStats :: FileServerStats -> FileServerStatsData -> IO () @@ -81,6 +85,7 @@ setFileServerStats s d = do writeIORef (filesUploaded s) $! _filesUploaded d writeIORef (filesExpired s) $! _filesExpired d writeIORef (filesDeleted s) $! _filesDeleted d + writeIORef (filesBlocked s) $! _filesBlocked d setPeriodStats (filesDownloaded s) $! _filesDownloaded d writeIORef (fileDownloads s) $! _fileDownloads d writeIORef (fileDownloadAcks s) $! _fileDownloadAcks d @@ -88,7 +93,7 @@ setFileServerStats s d = do writeIORef (filesSize s) $! _filesSize d instance StrEncoding FileServerStatsData where - strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} = + strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesBlocked, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} = B.unlines [ "fromTime=" <> strEncode _fromTime, "filesCreated=" <> strEncode _filesCreated, @@ -96,6 +101,7 @@ instance StrEncoding FileServerStatsData where "filesUploaded=" <> strEncode _filesUploaded, "filesExpired=" <> strEncode _filesExpired, "filesDeleted=" <> strEncode _filesDeleted, + "filesBlocked=" <> strEncode _filesBlocked, "filesCount=" <> strEncode _filesCount, "filesSize=" <> strEncode _filesSize, "filesDownloaded:", @@ -110,9 +116,10 @@ instance StrEncoding FileServerStatsData where _filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine _filesExpired <- "filesExpired=" *> strP <* A.endOfLine <|> pure 0 _filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine + _filesBlocked <- "filesBlocked=" *> strP <* A.endOfLine _filesCount <- "filesCount=" *> strP <* A.endOfLine <|> pure 0 _filesSize <- "filesSize=" *> strP <* A.endOfLine <|> pure 0 _filesDownloaded <- "filesDownloaded:" *> A.endOfLine *> strP <* A.endOfLine _fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine _fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine - pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} + pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesBlocked, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 46513ea96..c4536a2b5 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -13,6 +13,7 @@ module Simplex.FileTransfer.Server.Store setFilePath, addRecipient, deleteFile, + blockFile, deleteRecipient, expiredFilePath, getFile, @@ -22,6 +23,7 @@ module Simplex.FileTransfer.Server.Store where import Control.Concurrent.STM +import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Int (Int64) import Data.Set (Set) @@ -30,8 +32,8 @@ import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId import Simplex.FileTransfer.Transport (XFTPErrorType (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) -import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..)) +import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..), ServerEntityStatus (..)) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, ($>>=)) @@ -47,7 +49,8 @@ data FileRec = FileRec fileInfo :: FileInfo, filePath :: TVar (Maybe FilePath), recipientIds :: TVar (Set RecipientId), - createdAt :: RoundedSystemTime + createdAt :: RoundedSystemTime, + fileStatus :: TVar ServerEntityStatus } fileTimePrecision :: Int64 @@ -78,7 +81,8 @@ newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec newFileRec senderId fileInfo createdAt = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} + fileStatus <- newTVar EntityActive + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ()) setFilePath st sId fPath = @@ -109,6 +113,14 @@ deleteFile FileStore {files, recipients, usedStorage} senderId = do pure $ Right () _ -> pure $ Left AUTH +-- this function must be called after the file is deleted from the file system +blockFile :: FileStore -> SenderId -> BlockingInfo -> Bool -> STM (Either XFTPErrorType ()) +blockFile st@FileStore {usedStorage} senderId info deleted = + withFile st senderId $ \FileRec {fileInfo, fileStatus} -> do + when deleted $ modifyTVar' usedStorage $ subtract (fromIntegral $ size fileInfo) + writeTVar fileStatus $! EntityBlocked info + pure $ Right () + deleteRecipient :: FileStore -> RecipientId -> FileRec -> STM () deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do TM.delete rId recipients diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 4c485c170..a229f62e7 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -14,6 +14,7 @@ module Simplex.FileTransfer.Server.StoreLog logPutFile, logAddRecipients, logDeleteFile, + logBlockFile, logAckFile, ) where @@ -31,7 +32,7 @@ import qualified Data.Map.Strict as M import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.FileTransfer.Server.Store import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) +import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (bshow) @@ -42,7 +43,8 @@ data FileStoreLogRecord | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty FileRecipient) | DeleteFile SenderId - | AckFile RecipientId + | BlockFile SenderId BlockingInfo + | AckFile RecipientId -- TODO add senderId as well? deriving (Show) instance StrEncoding FileStoreLogRecord where @@ -51,6 +53,7 @@ instance StrEncoding FileStoreLogRecord where PutFile sId path -> strEncode (Str "FPUT", sId, path) AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps) DeleteFile sId -> strEncode (Str "FDEL", sId) + BlockFile sId info -> strEncode (Str "FBLK", sId, info) AckFile rId -> strEncode (Str "FACK", rId) strP = A.choice @@ -58,6 +61,7 @@ instance StrEncoding FileStoreLogRecord where "FPUT " *> (PutFile <$> strP_ <*> strP), "FADD " *> (AddRecipients <$> strP_ <*> strP), "FDEL " *> (DeleteFile <$> strP), + "FBLK " *> (BlockFile <$> strP_ <*> strP), "FACK " *> (AckFile <$> strP) ] @@ -76,6 +80,9 @@ logAddRecipients s = logFileStoreRecord s .: AddRecipients logDeleteFile :: StoreLog 'WriteMode -> SenderId -> IO () logDeleteFile s = logFileStoreRecord s . DeleteFile +logBlockFile :: StoreLog 'WriteMode -> SenderId -> BlockingInfo -> IO () +logBlockFile s fId = logFileStoreRecord s . BlockFile fId + logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO () logAckFile s = logFileStoreRecord s . AckFile @@ -96,6 +103,7 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re PutFile qId path -> setFilePath st qId path AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps DeleteFile sId -> deleteFile st sId + BlockFile sId info -> blockFile st sId info True AckFile rId -> ackFile st rId addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index a028a3773..7f90b2879 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -11,6 +11,7 @@ module Simplex.FileTransfer.Transport ( supportedFileServerVRange, authCmdsXFTPVersion, + blockedFilesXFTPVersion, xftpClientHandshakeStub, supportedXFTPhandshakes, XFTPClientHandshake (..), @@ -33,7 +34,6 @@ module Simplex.FileTransfer.Transport ) where -import Control.Applicative ((<|>)) import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad @@ -57,7 +57,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers -import Simplex.Messaging.Protocol (CommandError) +import Simplex.Messaging.Protocol (BlockingInfo, CommandError) import Simplex.Messaging.Transport (ALPN, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..)) import Simplex.Messaging.Transport.HTTP2.File import Simplex.Messaging.Util (bshow, tshow) @@ -92,8 +92,11 @@ initialXFTPVersion = VersionXFTP 1 authCmdsXFTPVersion :: VersionXFTP authCmdsXFTPVersion = VersionXFTP 2 +blockedFilesXFTPVersion :: VersionXFTP +blockedFilesXFTPVersion = VersionXFTP 3 + currentXFTPVersion :: VersionXFTP -currentXFTPVersion = VersionXFTP 2 +currentXFTPVersion = VersionXFTP 3 supportedFileServerVRange :: VersionRangeXFTP supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion @@ -211,6 +214,8 @@ data XFTPErrorType CMD {cmdErr :: CommandError} | -- | command authorization error - bad signature or non-existing SMP queue AUTH + | -- | command with the entity that was blocked + BLOCKED {blockInfo :: BlockingInfo} | -- | incorrent file size SIZE | -- | storage quota exceeded @@ -231,15 +236,46 @@ data XFTPErrorType INTERNAL | -- | used internally, never returned by the server (to be removed) DUPLICATE_ -- not part of SMP protocol, used internally - deriving (Eq, Read, Show) + deriving (Eq, Show) instance StrEncoding XFTPErrorType where strEncode = \case + BLOCK -> "BLOCK" + SESSION -> "SESSION" + HANDSHAKE -> "HANDSHAKE" CMD e -> "CMD " <> bshow e - e -> bshow e + AUTH -> "AUTH" + BLOCKED info -> "BLOCKED " <> strEncode info + SIZE -> "SIZE" + QUOTA -> "QUOTA" + DIGEST -> "DIGEST" + CRYPTO -> "CRYPTO" + NO_FILE -> "NO_FILE" + HAS_FILE -> "HAS_FILE" + FILE_IO -> "FILE_IO" + TIMEOUT -> "TIMEOUT" + INTERNAL -> "INTERNAL" + DUPLICATE_ -> "DUPLICATE_" + strP = - "CMD " *> (CMD <$> parseRead1) - <|> parseRead1 + A.takeTill (== ' ') >>= \case + "BLOCK" -> pure BLOCK + "SESSION" -> pure SESSION + "HANDSHAKE" -> pure HANDSHAKE + "CMD" -> CMD <$> parseRead1 + "AUTH" -> pure AUTH + "BLOCKED" -> BLOCKED <$> _strP + "SIZE" -> pure SIZE + "QUOTA" -> pure QUOTA + "DIGEST" -> pure DIGEST + "CRYPTO" -> pure CRYPTO + "NO_FILE" -> pure NO_FILE + "HAS_FILE" -> pure HAS_FILE + "FILE_IO" -> pure FILE_IO + "TIMEOUT" -> pure TIMEOUT + "INTERNAL" -> pure INTERNAL + "DUPLICATE_" -> pure DUPLICATE_ + _ -> fail "bad error type" instance Encoding XFTPErrorType where smpEncode = \case @@ -248,6 +284,7 @@ instance Encoding XFTPErrorType where HANDSHAKE -> "HANDSHAKE" CMD err -> "CMD " <> smpEncode err AUTH -> "AUTH" + BLOCKED info -> "BLOCKED " <> smpEncode info SIZE -> "SIZE" QUOTA -> "QUOTA" DIGEST -> "DIGEST" @@ -266,6 +303,7 @@ instance Encoding XFTPErrorType where "HANDSHAKE" -> pure HANDSHAKE "CMD" -> CMD <$> _smpP "AUTH" -> pure AUTH + "BLOCKED" -> BLOCKED <$> _smpP "SIZE" -> pure SIZE "QUOTA" -> pure QUOTA "DIGEST" -> pure DIGEST diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index a75efe0ee..008acd1d5 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -78,6 +78,7 @@ parseRead2 = parseRead $ do wordEnd :: Char -> Bool wordEnd c = c == ' ' || c == '\n' +{-# INLINE wordEnd #-} parseString :: (ByteString -> Either String a) -> (String -> a) parseString p = either error id . p . B.pack diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 03234aad4..2a76faa05 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -70,6 +70,8 @@ module Simplex.Messaging.Protocol CommandError (..), ProxyError (..), BrokerErrorType (..), + BlockingInfo (..), + BlockingReason (..), Transmission, TransmissionAuth (..), SignedTransmission, @@ -1194,6 +1196,8 @@ data ErrorType PROXY {proxyErr :: ProxyError} | -- | command authorization error - bad signature or non-existing SMP queue AUTH + | -- | command with the entity that was blocked + BLOCKED {blockInfo :: BlockingInfo} | -- | encryption/decryption error in proxy protocol CRYPTO | -- | SMP queue capacity is exceeded on the server @@ -1210,17 +1214,41 @@ data ErrorType INTERNAL | -- | used internally, never returned by the server (to be removed) DUPLICATE_ -- not part of SMP protocol, used internally - deriving (Eq, Read, Show) + deriving (Eq, Show) instance StrEncoding ErrorType where strEncode = \case + BLOCK -> "BLOCK" + SESSION -> "SESSION" CMD e -> "CMD " <> bshow e PROXY e -> "PROXY " <> strEncode e - e -> bshow e + AUTH -> "AUTH" + BLOCKED info -> "BLOCKED " <> strEncode info + CRYPTO -> "CRYPTO" + QUOTA -> "QUOTA" + STORE e -> "STORE " <> encodeUtf8 (T.pack e) + NO_MSG -> "NO_MSG" + LARGE_MSG -> "LARGE_MSG" + EXPIRED -> "EXPIRED" + INTERNAL -> "INTERNAL" + DUPLICATE_ -> "DUPLICATE_" strP = - "CMD " *> (CMD <$> parseRead1) - <|> "PROXY " *> (PROXY <$> strP) - <|> parseRead1 + A.choice + [ "BLOCK" $> BLOCK, + "SESSION" $> SESSION, + "CMD " *> (CMD <$> parseRead1), + "PROXY " *> (PROXY <$> strP), + "AUTH" $> AUTH, + "BLOCKED " *> strP, + "CRYPTO" $> CRYPTO, + "QUOTA" $> QUOTA, + "STORE " *> (STORE . T.unpack . safeDecodeUtf8 <$> A.takeByteString), + "NO_MSG" $> NO_MSG, + "LARGE_MSG" $> LARGE_MSG, + "EXPIRED" $> EXPIRED, + "INTERNAL" $> INTERNAL, + "DUPLICATE_" $> DUPLICATE_ + ] -- | SMP command error type. data CommandError @@ -1248,7 +1276,7 @@ data ProxyError BASIC_AUTH | -- no destination server error NO_SESSION - deriving (Eq, Read, Show) + deriving (Eq, Show) -- | SMP server errors. data BrokerErrorType @@ -1266,6 +1294,37 @@ data BrokerErrorType TIMEOUT deriving (Eq, Read, Show, Exception) +data BlockingInfo = BlockingInfo + { reason :: BlockingReason + } + deriving (Eq, Show) + +data BlockingReason = BRSpam | BRContent + deriving (Eq, Show) + +instance StrEncoding BlockingInfo where + strEncode BlockingInfo {reason} = "reason=" <> strEncode reason + strP = do + reason <- "reason=" *> strP + pure BlockingInfo {reason} + +instance Encoding BlockingInfo where + smpEncode = strEncode + smpP = strP + +instance StrEncoding BlockingReason where + strEncode = \case + BRSpam -> "spam" + BRContent -> "content" + strP = "spam" $> BRSpam <|> "content" $> BRContent + +instance ToJSON BlockingReason where + toJSON = strToJSON + toEncoding = strToJEncoding + +instance FromJSON BlockingReason where + parseJSON = strParseJSON "BlockingReason" + -- | SMP transmission parser. transmissionP :: THandleParams v p -> Parser RawTransmission transmissionP THandleParams {sessionId, implySessId} = do @@ -1435,7 +1494,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where | otherwise -> e END_ INFO info -> e (INFO_, ' ', info) OK -> e OK_ - ERR err -> e (ERR_, ' ', err) + ERR err -> case err of + BLOCKED _ | v < blockedEntityErrorSMPVersion -> e (ERR_, ' ', AUTH) + _ -> e (ERR_, ' ', err) PONG -> e PONG_ where e :: Encoding a => a -> ByteString @@ -1513,6 +1574,7 @@ instance Encoding ErrorType where CMD err -> "CMD " <> smpEncode err PROXY err -> "PROXY " <> smpEncode err AUTH -> "AUTH" + BLOCKED info -> "BLOCKED " <> smpEncode info CRYPTO -> "CRYPTO" QUOTA -> "QUOTA" STORE err -> "STORE " <> smpEncode err @@ -1529,6 +1591,7 @@ instance Encoding ErrorType where "CMD" -> CMD <$> _smpP "PROXY" -> PROXY <$> _smpP "AUTH" -> pure AUTH + "BLOCKED" -> BLOCKED <$> _smpP "CRYPTO" -> pure CRYPTO "QUOTA" -> pure QUOTA "STORE" -> STORE <$> _smpP @@ -1759,9 +1822,11 @@ tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \ca $(J.deriveJSON defaultJSON ''MsgFlags) -$(J.deriveJSON (sumTypeJSON id) ''CommandError) +$(J.deriveJSON (taggedObjectJSON id) ''CommandError) -$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType) +$(J.deriveJSON (taggedObjectJSON id) ''BrokerErrorType) + +$(J.deriveJSON defaultJSON ''BlockingInfo) -- run deriveJSON in one TH splice to allow mutual instance $(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType]) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index afec6e332..d31a50e34 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -849,16 +849,41 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT SubPending -> (c1, c2 + 1, c3, c4) SubThread _ -> (c1, c2, c3 + 1, c4) ProhibitSub -> pure (c1, c2, c3, c4 + 1) - CPDelete qId -> withUserRole $ unliftIO u $ do + CPDelete sId -> withUserRole $ unliftIO u $ do AMS _ st <- asks msgStore r <- liftIO $ runExceptT $ do - (q, qr) <- ExceptT (getQueueRec st SSender qId) `catchE` \_ -> ExceptT (getQueueRec st SRecipient qId) + (q, qr) <- ExceptT $ getQueueRec st SSender sId ExceptT $ deleteQueueSize st (recipientId qr) q case r of Left e -> liftIO $ hPutStrLn h $ "error: " <> show e Right (qr, numDeleted) -> do updateDeletedStats qr liftIO $ hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted" + CPStatus sId -> withUserRole $ unliftIO u $ do + AMS _ st <- asks msgStore + q <- liftIO $ getQueueRec st SSender sId + liftIO $ hPutStrLn h $ case q of + Left e -> "error: " <> show e + Right (_, QueueRec {sndSecure, status, updatedAt}) -> + "status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", sndSecure: " <> show sndSecure + CPBlock sId info -> withUserRole $ unliftIO u $ do + AMS _ st <- asks msgStore + r <- liftIO $ runExceptT $ do + q <- ExceptT $ getQueue st SSender sId + ExceptT $ blockQueue st q info + case r of + Left e -> liftIO $ hPutStrLn h $ "error: " <> show e + Right () -> do + incStat . qBlocked =<< asks serverStats + liftIO $ hPutStrLn h "ok" + CPUnblock sId -> withUserRole $ unliftIO u $ do + AMS _ st <- asks msgStore + r <- liftIO $ runExceptT $ do + q <- ExceptT $ getQueue st SSender sId + ExceptT $ unblockQueue st q + liftIO $ hPutStrLn h $ case r of + Left e -> "error: " <> show e + Right () -> "ok" CPSave -> withAdminRole $ withLock' (savingLock srv) "control" $ do hPutStrLn h "saving server state..." unliftIO u $ saveServer False @@ -1225,7 +1250,7 @@ client SKEY sKey -> withQueue $ \q QueueRec {sndSecure} -> (corrId,entId,) <$> if sndSecure then secureQueue_ q sKey else pure $ ERR AUTH - SEND flags msgBody -> withQueue $ sendMessage flags msgBody + SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody PING -> pure (corrId, NoEntity, PONG) RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock Cmd SNotifier NSUB -> Just <$> subscribeNotifications @@ -1247,7 +1272,7 @@ client NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_ - DEL -> maybe (pure $ err INTERNAL) delQueueAndMsgs q_ + DEL -> maybe (pure $ err INTERNAL) delQueueAndMsgs q_ QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr where createQueue :: RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) @@ -1264,7 +1289,7 @@ client rcvDhSecret, senderKey = Nothing, notifier = Nothing, - status = QueueActive, + status = EntityActive, sndSecure, updatedAt } @@ -1406,13 +1431,18 @@ client Nothing -> incStat (msgGetNoMsg stats) $> ok withQueue :: (StoreQueue s -> QueueRec -> M (Transmission BrokerMsg)) -> M (Transmission BrokerMsg) - withQueue action = case q_ of + withQueue = withQueue_ True + + withQueue_ :: Bool -> (StoreQueue s -> QueueRec -> M (Transmission BrokerMsg)) -> M (Transmission BrokerMsg) + withQueue_ queueNotBlocked action = case q_ of Nothing -> pure $ err INTERNAL - Just (q, qr@QueueRec {updatedAt}) -> do - t <- liftIO getSystemDate - if updatedAt == Just t - then action q qr - else liftIO (updateQueueTime ms q t) >>= either (pure . err) (action q) + Just (q, qr@QueueRec {status, updatedAt}) -> case status of + EntityBlocked info | queueNotBlocked -> pure $ err $ BLOCKED info + _ -> do + t <- liftIO getSystemDate + if updatedAt == Just t + then action q qr + else liftIO (updateQueueTime ms q t) >>= either (pure . err) (action q) subscribeNotifications :: M (Transmission BrokerMsg) subscribeNotifications = do @@ -1483,10 +1513,13 @@ client | otherwise = do stats <- asks serverStats case status qr of - QueueOff -> do + EntityOff -> do incStat $ msgSentAuth stats pure $ err AUTH - QueueActive -> + EntityBlocked info -> do + incStat $ msgSentBlock stats + pure $ err $ BLOCKED info + EntityActive -> case C.maxLenBS msgBody of Left _ -> pure $ err LARGE_MSG Right body -> do @@ -1734,7 +1767,7 @@ updateDeletedStats q = do let delSel = if isNothing (senderKey q) then qDeletedNew else qDeletedSecured incStat $ delSel stats incStat $ qDeletedAll stats - incStat $ qCount stats + liftIO $ atomicModifyIORef'_ (qCount stats) (subtract 1) incStat :: MonadIO m => IORef Int -> m () incStat r = liftIO $ atomicModifyIORef'_ r (+ 1) diff --git a/src/Simplex/Messaging/Server/Control.hs b/src/Simplex/Messaging/Server/Control.hs index e1d1b5d12..318bce1cc 100644 --- a/src/Simplex/Messaging/Server/Control.hs +++ b/src/Simplex/Messaging/Server/Control.hs @@ -5,7 +5,7 @@ module Simplex.Messaging.Server.Control where import qualified Data.Attoparsec.ByteString.Char8 as A import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (BasicAuth, SenderId) +import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo, SenderId) data CPClientRole = CPRNone | CPRUser | CPRAdmin deriving (Eq) @@ -22,6 +22,9 @@ data ControlProtocol | CPSocketThreads | CPServerInfo | CPDelete SenderId + | CPStatus SenderId + | CPBlock SenderId BlockingInfo + | CPUnblock SenderId | CPSave | CPHelp | CPQuit @@ -39,14 +42,17 @@ instance StrEncoding ControlProtocol where CPSockets -> "sockets" CPSocketThreads -> "socket-threads" CPServerInfo -> "server-info" - CPDelete bs -> "delete " <> strEncode bs + CPDelete sId -> "delete " <> strEncode sId + CPStatus sId -> "status " <> strEncode sId + CPBlock sId info -> "block " <> strEncode sId <> " " <> strEncode info + CPUnblock sId -> "unblock " <> strEncode sId CPSave -> "save" CPHelp -> "help" CPQuit -> "quit" CPSkip -> "" strP = A.takeTill (== ' ') >>= \case - "auth" -> CPAuth <$> (A.space *> strP) + "auth" -> CPAuth <$> _strP "suspend" -> pure CPSuspend "resume" -> pure CPResume "clients" -> pure CPClients @@ -56,7 +62,10 @@ instance StrEncoding ControlProtocol where "sockets" -> pure CPSockets "socket-threads" -> pure CPSocketThreads "server-info" -> pure CPServerInfo - "delete" -> CPDelete <$> (A.space *> strP) + "delete" -> CPDelete <$> _strP + "status" -> CPStatus <$> _strP + "block" -> CPBlock <$> _strP <*> _strP + "unblock" -> CPUnblock <$> _strP "save" -> pure CPSave "help" -> pure CPHelp "quit" -> pure CPQuit diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index 16bb02888..cb9c68d04 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -56,6 +56,7 @@ prometheusMetrics sm rtm ts = _qDeletedAllB, _qDeletedNew, _qDeletedSecured, + _qBlocked, _qSub, _qSubAllB, _qSubAuth, @@ -74,6 +75,7 @@ prometheusMetrics sm rtm ts = _msgSentAuth, _msgSentQuota, _msgSentLarge, + _msgSentBlock, _msgRecv, _msgRecvGet, _msgGet, @@ -122,6 +124,10 @@ prometheusMetrics sm rtm ts = \simplex_smp_queues_deleted{type=\"new\"} " <> mshow _qDeletedNew <> "\n# qDeletedNew\n\ \simplex_smp_queues_deleted{type=\"secured\"} " <> mshow _qDeletedSecured <> "\n# qDeletedSecured\n\ \\n\ + \# HELP simplex_smp_queues_deleted Deleted queues\n\ + \# TYPE simplex_smp_queues_deleted counter\n\ + \simplex_smp_queues_blocked " <> mshow _qBlocked <> "\n# qBlocked\n\ + \\n\ \# HELP simplex_smp_queues_deleted_batch Batched requests to delete queues\n\ \# TYPE simplex_smp_queues_deleted_batch counter\n\ \simplex_smp_queues_deleted_batch " <> mshow _qDeletedAllB <> "\n# qDeletedAllB\n\ @@ -197,6 +203,7 @@ prometheusMetrics sm rtm ts = \simplex_smp_messages_sent_errors{type=\"auth\"} " <> mshow _msgSentAuth <> "\n# msgSentAuth\n\ \simplex_smp_messages_sent_errors{type=\"quota\"} " <> mshow _msgSentQuota <> "\n# msgSentQuota\n\ \simplex_smp_messages_sent_errors{type=\"large\"} " <> mshow _msgSentLarge <> "\n# msgSentLarge\n\ + \simplex_smp_messages_sent_errors{type=\"block\"} " <> mshow _msgSentBlock <> "\n# msgSentBlock\n\ \\n\ \# HELP simplex_smp_messages_received Received messages.\n\ \# TYPE simplex_smp_messages_received counter\n\ diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index 3f7da8d29..a40875680 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -1,11 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Simplex.Messaging.Server.QueueStore where +import Control.Applicative ((<|>)) +import Data.Functor (($>)) import Data.Int (Int64) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Simplex.Messaging.Encoding.String @@ -19,7 +23,7 @@ data QueueRec = QueueRec senderKey :: !(Maybe SndPublicAuthKey), sndSecure :: !SenderCanSecure, notifier :: !(Maybe NtfCreds), - status :: !ServerQueueStatus, + status :: !ServerEntityStatus, updatedAt :: !(Maybe RoundedSystemTime) } deriving (Show) @@ -37,7 +41,21 @@ instance StrEncoding NtfCreds where (notifierId, notifierKey, rcvNtfDhSecret) <- strP pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} -data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show) +data ServerEntityStatus + = EntityActive + | EntityBlocked BlockingInfo + | EntityOff + deriving (Eq, Show) + +instance StrEncoding ServerEntityStatus where + strEncode = \case + EntityActive -> "active" + EntityBlocked info -> "blocked," <> strEncode info + EntityOff -> "off" + strP = + "active" $> EntityActive + <|> "blocked," *> (EntityBlocked <$> strP) + <|> "off" $> EntityOff newtype RoundedSystemTime = RoundedSystemTime Int64 deriving (Eq, Ord, Show) diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 7bf4f3a4a..a073b5500 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -21,6 +21,8 @@ module Simplex.Messaging.Server.QueueStore.STM addQueueNotifier, deleteQueueNotifier, suspendQueue, + blockQueue, + unblockQueue, updateQueueTime, deleteQueue', readQueueStore, @@ -118,7 +120,27 @@ suspendQueue st sq = where qr = queueRec' sq suspend q = do - writeTVar qr $! Just q {status = QueueOff} + writeTVar qr $! Just q {status = EntityOff} + pure $ recipientId q + +blockQueue :: STMQueueStore s => s -> StoreQueue s -> BlockingInfo -> IO (Either ErrorType ()) +blockQueue st sq info = + atomically (readQueueRec qr >>= mapM block) + $>>= \rId -> withLog "blockQueue" st (\sl -> logBlockQueue sl rId info) + where + qr = queueRec' sq + block q = do + writeTVar qr $ Just q {status = EntityBlocked info} + pure $ recipientId q + +unblockQueue :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ()) +unblockQueue st sq = + atomically (readQueueRec qr >>= mapM unblock) + $>>= \rId -> withLog "unblockQueue" st (`logUnblockQueue` rId) + where + qr = queueRec' sq + unblock q = do + writeTVar qr $ Just q {status = EntityActive} pure $ recipientId q updateQueueTime :: STMQueueStore s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) @@ -177,6 +199,8 @@ readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLin SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st + BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info + UnblockQueue qId -> withQueue qId "UnblockQueue" $ unblockQueue st DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st qId DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index b384ad9b9..bbab6d8d2 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -34,6 +34,7 @@ data ServerStats = ServerStats qDeletedAllB :: IORef Int, qDeletedNew :: IORef Int, qDeletedSecured :: IORef Int, + qBlocked :: IORef Int, qSub :: IORef Int, -- only includes subscriptions when there were pending messages -- qSubNoMsg :: IORef Int, -- this stat creates too many STM transactions qSubAllB :: IORef Int, -- count of all subscription batches (with and without pending messages) @@ -53,6 +54,7 @@ data ServerStats = ServerStats msgSentAuth :: IORef Int, msgSentQuota :: IORef Int, msgSentLarge :: IORef Int, + msgSentBlock :: IORef Int, msgRecv :: IORef Int, msgRecvGet :: IORef Int, msgGet :: IORef Int, @@ -89,6 +91,7 @@ data ServerStatsData = ServerStatsData _qDeletedAllB :: Int, _qDeletedNew :: Int, _qDeletedSecured :: Int, + _qBlocked :: Int, _qSub :: Int, _qSubAllB :: Int, _qSubAuth :: Int, @@ -107,6 +110,7 @@ data ServerStatsData = ServerStatsData _msgSentAuth :: Int, _msgSentQuota :: Int, _msgSentLarge :: Int, + _msgSentBlock :: Int, _msgRecv :: Int, _msgRecvGet :: Int, _msgGet :: Int, @@ -144,6 +148,7 @@ newServerStats ts = do qDeletedAllB <- newIORef 0 qDeletedNew <- newIORef 0 qDeletedSecured <- newIORef 0 + qBlocked <- newIORef 0 qSub <- newIORef 0 qSubAllB <- newIORef 0 qSubAuth <- newIORef 0 @@ -162,6 +167,7 @@ newServerStats ts = do msgSentAuth <- newIORef 0 msgSentQuota <- newIORef 0 msgSentLarge <- newIORef 0 + msgSentBlock <- newIORef 0 msgRecv <- newIORef 0 msgRecvGet <- newIORef 0 msgGet <- newIORef 0 @@ -196,6 +202,7 @@ newServerStats ts = do qDeletedAllB, qDeletedNew, qDeletedSecured, + qBlocked, qSub, qSubAllB, qSubAuth, @@ -214,6 +221,7 @@ newServerStats ts = do msgSentAuth, msgSentQuota, msgSentLarge, + msgSentBlock, msgRecv, msgRecvGet, msgGet, @@ -250,6 +258,7 @@ getServerStatsData s = do _qDeletedAllB <- readIORef $ qDeletedAllB s _qDeletedNew <- readIORef $ qDeletedNew s _qDeletedSecured <- readIORef $ qDeletedSecured s + _qBlocked <- readIORef $ qBlocked s _qSub <- readIORef $ qSub s _qSubAllB <- readIORef $ qSubAllB s _qSubAuth <- readIORef $ qSubAuth s @@ -268,6 +277,7 @@ getServerStatsData s = do _msgSentAuth <- readIORef $ msgSentAuth s _msgSentQuota <- readIORef $ msgSentQuota s _msgSentLarge <- readIORef $ msgSentLarge s + _msgSentBlock <- readIORef $ msgSentBlock s _msgRecv <- readIORef $ msgRecv s _msgRecvGet <- readIORef $ msgRecvGet s _msgGet <- readIORef $ msgGet s @@ -302,6 +312,7 @@ getServerStatsData s = do _qDeletedAllB, _qDeletedNew, _qDeletedSecured, + _qBlocked, _qSub, _qSubAllB, _qSubAuth, @@ -320,6 +331,7 @@ getServerStatsData s = do _msgSentAuth, _msgSentQuota, _msgSentLarge, + _msgSentBlock, _msgRecv, _msgRecvGet, _msgGet, @@ -357,6 +369,7 @@ setServerStats s d = do writeIORef (qDeletedAllB s) $! _qDeletedAllB d writeIORef (qDeletedNew s) $! _qDeletedNew d writeIORef (qDeletedSecured s) $! _qDeletedSecured d + writeIORef (qBlocked s) $! _qBlocked d writeIORef (qSub s) $! _qSub d writeIORef (qSubAllB s) $! _qSubAllB d writeIORef (qSubAuth s) $! _qSubAuth d @@ -375,6 +388,7 @@ setServerStats s d = do writeIORef (msgSentAuth s) $! _msgSentAuth d writeIORef (msgSentQuota s) $! _msgSentQuota d writeIORef (msgSentLarge s) $! _msgSentLarge d + writeIORef (msgSentBlock s) $! _msgSentBlock d writeIORef (msgRecv s) $! _msgRecv d writeIORef (msgRecvGet s) $! _msgRecvGet d writeIORef (msgGet s) $! _msgGet d @@ -411,6 +425,7 @@ instance StrEncoding ServerStatsData where "qDeletedNew=" <> strEncode (_qDeletedNew d), "qDeletedSecured=" <> strEncode (_qDeletedSecured d), "qDeletedAllB=" <> strEncode (_qDeletedAllB d), + "qBlocked=" <> strEncode (_qBlocked d), "qCount=" <> strEncode (_qCount d), "qSub=" <> strEncode (_qSub d), "qSubAllB=" <> strEncode (_qSubAllB d), @@ -430,6 +445,7 @@ instance StrEncoding ServerStatsData where "msgSentAuth=" <> strEncode (_msgSentAuth d), "msgSentQuota=" <> strEncode (_msgSentQuota d), "msgSentLarge=" <> strEncode (_msgSentLarge d), + "msgSentBlock=" <> strEncode (_msgSentBlock d), "msgRecv=" <> strEncode (_msgRecv d), "msgRecvGet=" <> strEncode (_msgRecvGet d), "msgGet=" <> strEncode (_msgGet d), @@ -467,6 +483,7 @@ instance StrEncoding ServerStatsData where (,0,0) <$> ("qDeleted=" *> strP <* A.endOfLine) <|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine)) _qDeletedAllB <- opt "qDeletedAllB=" + _qBlocked <- opt "qBlocked=" _qCount <- opt "qCount=" _qSub <- opt "qSub=" _qSubNoMsg <- skipInt "qSubNoMsg=" -- skipping it for backward compatibility @@ -487,6 +504,7 @@ instance StrEncoding ServerStatsData where _msgSentAuth <- opt "msgSentAuth=" _msgSentQuota <- opt "msgSentQuota=" _msgSentLarge <- opt "msgSentLarge=" + _msgSentBlock <- opt "msgSentBlock=" _msgRecv <- "msgRecv=" *> strP <* A.endOfLine _msgRecvGet <- opt "msgRecvGet=" _msgGet <- opt "msgGet=" @@ -532,6 +550,7 @@ instance StrEncoding ServerStatsData where _qDeletedAllB, _qDeletedNew, _qDeletedSecured, + _qBlocked, _qSub, _qSubAllB, _qSubAuth, @@ -550,6 +569,7 @@ instance StrEncoding ServerStatsData where _msgSentAuth, _msgSentQuota, _msgSentLarge, + _msgSentBlock, _msgRecv, _msgRecvGet, _msgGet, diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 2da3398f2..8dee31940 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -21,6 +21,8 @@ module Simplex.Messaging.Server.StoreLog logSecureQueue, logAddNotifier, logSuspendQueue, + logBlockQueue, + logUnblockQueue, logDeleteQueue, logDeleteNotifier, logUpdateQueueTime, @@ -33,9 +35,9 @@ import Control.Applicative (optional, (<|>)) import Control.Concurrent.STM import qualified Control.Exception as E import Control.Logger.Simple -import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -56,6 +58,8 @@ data StoreLogRecord | SecureQueue QueueId SndPublicAuthKey | AddNotifier QueueId NtfCreds | SuspendQueue QueueId + | BlockQueue QueueId BlockingInfo + | UnblockQueue QueueId | DeleteQueue QueueId | DeleteNotifier QueueId | UpdateTime QueueId RoundedSystemTime @@ -66,12 +70,14 @@ data SLRTag | SecureQueue_ | AddNotifier_ | SuspendQueue_ + | BlockQueue_ + | UnblockQueue_ | DeleteQueue_ | DeleteNotifier_ | UpdateTime_ instance StrEncoding QueueRec where - strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, updatedAt} = + strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = B.unwords [ "rid=" <> strEncode recipientId, "rk=" <> strEncode recipientKey, @@ -82,10 +88,14 @@ instance StrEncoding QueueRec where <> sndSecureStr <> maybe "" notifierStr notifier <> maybe "" updatedAtStr updatedAt + <> statusStr where sndSecureStr = if sndSecure then " sndSecure=" <> strEncode sndSecure else "" notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds updatedAtStr t = " updated_at=" <> strEncode t + statusStr = case status of + EntityActive -> "" + _ -> " status=" <> strEncode status strP = do recipientId <- "rid=" *> strP_ @@ -96,7 +106,8 @@ instance StrEncoding QueueRec where sndSecure <- (" sndSecure=" *> strP) <|> pure False notifier <- optional $ " notifier=" *> strP updatedAt <- optional $ " updated_at=" *> strP - pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive, updatedAt} + status <- (" status=" *> strP) <|> pure EntityActive + pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} instance StrEncoding SLRTag where strEncode = \case @@ -104,20 +115,24 @@ instance StrEncoding SLRTag where SecureQueue_ -> "SECURE" AddNotifier_ -> "NOTIFIER" SuspendQueue_ -> "SUSPEND" + BlockQueue_ -> "BLOCK" + UnblockQueue_ -> "UNBLOCK" DeleteQueue_ -> "DELETE" DeleteNotifier_ -> "NDELETE" UpdateTime_ -> "TIME" strP = - A.takeTill (== ' ') >>= \case - "CREATE" -> pure CreateQueue_ - "SECURE" -> pure SecureQueue_ - "NOTIFIER" -> pure AddNotifier_ - "SUSPEND" -> pure SuspendQueue_ - "DELETE" -> pure DeleteQueue_ - "NDELETE" -> pure DeleteNotifier_ - "TIME" -> pure UpdateTime_ - s -> fail $ "invalid log record tag: " <> B.unpack s + A.choice + [ "CREATE" $> CreateQueue_, + "SECURE" $> SecureQueue_, + "NOTIFIER" $> AddNotifier_, + "SUSPEND" $> SuspendQueue_, + "BLOCK" $> BlockQueue_, + "UNBLOCK" $> UnblockQueue_, + "DELETE" $> DeleteQueue_, + "NDELETE" $> DeleteNotifier_, + "TIME" $> UpdateTime_ + ] instance StrEncoding StoreLogRecord where strEncode = \case @@ -125,6 +140,8 @@ instance StrEncoding StoreLogRecord where SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey) AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds) SuspendQueue rId -> strEncode (SuspendQueue_, rId) + BlockQueue rId info -> strEncode (BlockQueue_, rId, info) + UnblockQueue rId -> strEncode (UnblockQueue_, rId) DeleteQueue rId -> strEncode (DeleteQueue_, rId) DeleteNotifier rId -> strEncode (DeleteNotifier_, rId) UpdateTime rId t -> strEncode (UpdateTime_, rId, t) @@ -135,6 +152,8 @@ instance StrEncoding StoreLogRecord where SecureQueue_ -> SecureQueue <$> strP_ <*> strP AddNotifier_ -> AddNotifier <$> strP_ <*> strP SuspendQueue_ -> SuspendQueue <$> strP + BlockQueue_ -> BlockQueue <$> strP_ <*> strP + UnblockQueue_ -> UnblockQueue <$> strP DeleteQueue_ -> DeleteQueue <$> strP DeleteNotifier_ -> DeleteNotifier <$> strP UpdateTime_ -> UpdateTime <$> strP_ <*> strP @@ -179,6 +198,12 @@ logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds logSuspendQueue :: StoreLog 'WriteMode -> QueueId -> IO () logSuspendQueue s = writeStoreLogRecord s . SuspendQueue +logBlockQueue :: StoreLog 'WriteMode -> QueueId -> BlockingInfo -> IO () +logBlockQueue s qId info = writeStoreLogRecord s $ BlockQueue qId info + +logUnblockQueue :: StoreLog 'WriteMode -> QueueId -> IO () +logUnblockQueue s = writeStoreLogRecord s . UnblockQueue + logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO () logDeleteQueue s = writeStoreLogRecord s . DeleteQueue @@ -228,6 +253,5 @@ writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M. where writeQueue (rId, q) = readTVarIO (queueRec' q) >>= \case - Just q' -> when (active q') $ logCreateQueue s q' -- TODO we should log suspended queues when we use them + Just q' -> logCreateQueue s q' Nothing -> atomically $ TM.delete rId $ activeMsgQueues st - active QueueRec {status} = status == QueueActive diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index e64485964..1bb4cff58 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -49,6 +49,7 @@ module Simplex.Messaging.Transport sndAuthKeySMPVersion, deletedEventSMPVersion, encryptedBlockSMPVersion, + blockedEntityErrorSMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -142,6 +143,7 @@ smpBlockSize = 16384 -- 9 - faster handshake: SKEY command for sender to secure queue -- 10 - DELD event to subscriber when queue is deleted via another connnection -- 11 - additional encryption of transport blocks with forward secrecy (9/14/2024) +-- 12 - BLOCKED error for blocked queues (1/11/2025) data SMPVersion @@ -178,14 +180,17 @@ deletedEventSMPVersion = VersionSMP 10 encryptedBlockSMPVersion :: VersionSMP encryptedBlockSMPVersion = VersionSMP 11 +blockedEntityErrorSMPVersion :: VersionSMP +blockedEntityErrorSMPVersion = VersionSMP 12 + currentClientSMPRelayVersion :: VersionSMP -currentClientSMPRelayVersion = VersionSMP 11 +currentClientSMPRelayVersion = VersionSMP 12 legacyServerSMPRelayVersion :: VersionSMP legacyServerSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 11 +currentServerSMPRelayVersion = VersionSMP 12 -- Max SMP protocol version to be used in e2e encrypted -- connection between client and server, as defined by SMP proxy. @@ -193,7 +198,7 @@ currentServerSMPRelayVersion = VersionSMP 11 -- to prevent client version fingerprinting by the -- destination relays when clients upgrade at different times. proxiedSMPRelayVersion :: VersionSMP -proxiedSMPRelayVersion = VersionSMP 9 +proxiedSMPRelayVersion = VersionSMP 11 -- minimal supported protocol version is 4 -- TODO remove code that supports sending commands without batching diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 35c27c22e..f9afecf5a 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -112,7 +112,7 @@ testNewQueueRec g sndSecure = do senderKey = Nothing, sndSecure, notifier = Nothing, - status = QueueActive, + status = EntityActive, updatedAt = Nothing } pure (rId, qr) diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index b0bd17dff..9cde80286 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -41,11 +41,12 @@ import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) -import Simplex.Messaging.Server.StoreLog (closeStoreLog) +import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog) import Simplex.Messaging.Transport import Simplex.Messaging.Util (whenM) import Simplex.Messaging.Version (mkVersionRange) import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile) +import System.IO (IOMode (..), withFile) import System.TimeIt (timeItT) import System.Timeout import Test.HUnit @@ -78,6 +79,7 @@ serverTests = do testMsgExpireOnSend testMsgExpireOnInterval testMsgNOTExpireOnInterval + describe "Blocking queues" $ testBlockMessageQueue pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) @@ -688,7 +690,7 @@ testRestoreMessages = logSize testStoreLogFile `shouldReturn` 2 -- logSize testStoreMsgsFile `shouldReturn` 5 - logSize testServerStatsBackupFile `shouldReturn` 74 + logSize testServerStatsBackupFile `shouldReturn` 76 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 @@ -706,7 +708,7 @@ testRestoreMessages = logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd -- logSize testStoreMsgsFile `shouldReturn` 3 - logSize testServerStatsBackupFile `shouldReturn` 74 + logSize testServerStatsBackupFile `shouldReturn` 76 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 @@ -724,7 +726,7 @@ testRestoreMessages = pure () logSize testStoreLogFile `shouldReturn` 1 -- logSize testStoreMsgsFile `shouldReturn` 0 - logSize testServerStatsBackupFile `shouldReturn` 74 + logSize testServerStatsBackupFile `shouldReturn` 76 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 @@ -996,7 +998,7 @@ testMsgExpireOnInterval = testMsgNOTExpireOnInterval :: SpecWith (ATransport, AMSType) testMsgNOTExpireOnInterval = - it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ \(ATransport (t :: TProxy c), msType) -> do + it "should block and unblock message queues" $ \(ATransport (t :: TProxy c), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} @@ -1013,6 +1015,30 @@ testMsgNOTExpireOnInterval = Nothing -> return () Just _ -> error "nothing else should be delivered" +testBlockMessageQueue :: SpecWith (ATransport, AMSType) +testBlockMessageQueue = + it "should return BLOCKED error when queue is blocked" $ \(at@(ATransport (t :: TProxy c)), msType) -> do + g <- C.newRandom + (rId, sId) <- withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + Resp "abcd" rId1 (Ids rId sId _srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True) + (rId1, NoEntity) #== "creates queue" + pure (rId, sId) + + withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rId $ BlockingInfo BRContent + + withSmpServerStoreLogOnMS at msType testPort $ runTest t $ \h -> do + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g + Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub) + (sId2, sId) #== "same queue ID in response" + where + runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a + runTest _ test' server = do + a <- testSMPClient test' + killThread server + pure a + samplePubKey :: C.APublicVerifyKey samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY=" diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index cc40ee3f7..5193e56cf 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -289,7 +289,7 @@ testFileLog = do download g c rpKey1 rId1 digest bytes download g c rpKey2 rId2 digest bytes logSize testXFTPLogFile `shouldReturn` 3 - logSize testXFTPStatsBackupFile `shouldReturn` 14 + logSize testXFTPStatsBackupFile `shouldReturn` 15 threadDelay 100000 @@ -316,7 +316,7 @@ testFileLog = do -- recipient 2 can download download g c rpKey2 rId2 digest bytes logSize testXFTPLogFile `shouldReturn` 4 - logSize testXFTPStatsBackupFile `shouldReturn` 14 + logSize testXFTPStatsBackupFile `shouldReturn` 15 threadDelay 100000 @@ -337,13 +337,13 @@ testFileLog = do -- sender can delete - +1 to log deleteXFTPChunk c spKey sId logSize testXFTPLogFile `shouldReturn` 4 - logSize testXFTPStatsBackupFile `shouldReturn` 14 + logSize testXFTPStatsBackupFile `shouldReturn` 15 threadDelay 100000 withXFTPServerStoreLogOn $ \_ -> pure () -- compacts on start logSize testXFTPLogFile `shouldReturn` 0 - logSize testXFTPStatsBackupFile `shouldReturn` 14 + logSize testXFTPStatsBackupFile `shouldReturn` 15 threadDelay 100000 From c528ea4f319084752b0bd2e373c4f3946e8e51dc Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 12 Jan 2025 22:11:18 +0000 Subject: [PATCH 11/51] smp server: update versions (#1433) --- src/Simplex/Messaging/Server/Main.hs | 4 ++-- src/Simplex/Messaging/Transport.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 89b032661..0ecc5cf94 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -47,7 +47,7 @@ import Simplex.Messaging.Server.Information import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.QueueStore.STM (readQueueStore) -import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange) +import Simplex.Messaging.Transport (batchCmdsSMPVersion, currentServerSMPRelayVersion, simplexMQVersion, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow) @@ -447,7 +447,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = defaultSMPClientAgentConfig { smpCfg = (smpCfg defaultSMPClientAgentConfig) - { serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, + { serverVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion, agreeSecret = True, networkConfig = defaultNetworkConfig diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 1bb4cff58..d4601d569 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -198,7 +198,7 @@ currentServerSMPRelayVersion = VersionSMP 12 -- to prevent client version fingerprinting by the -- destination relays when clients upgrade at different times. proxiedSMPRelayVersion :: VersionSMP -proxiedSMPRelayVersion = VersionSMP 11 +proxiedSMPRelayVersion = VersionSMP 12 -- minimal supported protocol version is 4 -- TODO remove code that supports sending commands without batching From dadf6ec5b67ee49b0f18ac4aecdce0d0be26786d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 13 Jan 2025 08:39:22 +0000 Subject: [PATCH 12/51] 6.3.0.1 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 30b265592..cb4676bed 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.0 +version: 6.3.0.1 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 9404a3ab632689ff80d611d35d481a280b5788f4 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Tue, 14 Jan 2025 10:46:27 +0000 Subject: [PATCH 13/51] xftp server: block stats --- src/Simplex/FileTransfer/Server/Stats.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Simplex/FileTransfer/Server/Stats.hs b/src/Simplex/FileTransfer/Server/Stats.hs index 2f38c7447..77c408884 100644 --- a/src/Simplex/FileTransfer/Server/Stats.hs +++ b/src/Simplex/FileTransfer/Server/Stats.hs @@ -116,10 +116,12 @@ instance StrEncoding FileServerStatsData where _filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine _filesExpired <- "filesExpired=" *> strP <* A.endOfLine <|> pure 0 _filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine - _filesBlocked <- "filesBlocked=" *> strP <* A.endOfLine + _filesBlocked <- opt "filesBlocked=" _filesCount <- "filesCount=" *> strP <* A.endOfLine <|> pure 0 _filesSize <- "filesSize=" *> strP <* A.endOfLine <|> pure 0 _filesDownloaded <- "filesDownloaded:" *> A.endOfLine *> strP <* A.endOfLine _fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine _fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesBlocked, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} + where + opt s = A.string s *> strP <* A.endOfLine <|> pure 0 From fdde9863cdc87dc47609a3a5f51a4c2c4c038858 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 17 Jan 2025 16:27:37 +0400 Subject: [PATCH 14/51] agent: add reopenStore function for postgres; run notification tests with postgres (#1435) --- simplexmq.cabal | 2 +- src/Simplex/Messaging/Agent/Store.hs | 3 ++ src/Simplex/Messaging/Agent/Store/Postgres.hs | 30 +++++++++++++++---- .../Messaging/Agent/Store/Postgres/Common.hs | 1 + .../Postgres/Migrations/M20241210_initial.hs | 6 ++-- src/Simplex/Messaging/Agent/Store/SQLite.hs | 11 ++++--- tests/AgentTests.hs | 12 ++++---- tests/AgentTests/NotificationTests.hs | 17 +++++++---- tests/AgentTests/SQLiteTests.hs | 8 ++--- 9 files changed, 58 insertions(+), 32 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index cb4676bed..460d8deb5 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -414,6 +414,7 @@ test-suite simplexmq-test AgentTests.EqInstances AgentTests.FunctionalAPITests AgentTests.MigrationTests + AgentTests.NotificationTests AgentTests.ServerChoice CLITests CoreTests.BatchingTests @@ -446,7 +447,6 @@ test-suite simplexmq-test Paths_simplexmq if !flag(client_postgres) other-modules: - AgentTests.NotificationTests AgentTests.SchemaDump AgentTests.SQLiteTests hs-source-dirs: diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index ff8c29b6c..1582f5cc7 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -73,6 +73,9 @@ createStore dbFilePath dbKey keepKey = Store.createDBStore dbFilePath dbKey keep closeStore :: DBStore -> IO () closeStore = Store.closeDBStore +reopenStore :: DBStore -> IO () +reopenStore = Store.reopenDBStore + execSQL :: DB.Connection -> Text -> IO [Text] execSQL = Store.execSQL diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index ad66c7763..4d2f6c33c 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -6,7 +7,8 @@ module Simplex.Messaging.Agent.Store.Postgres ( createDBStore, closeDBStore, - execSQL + reopenDBStore, + execSQL, ) where @@ -15,7 +17,7 @@ import Control.Monad (unless, void) import Data.Functor (($>)) import Data.String (fromString) import Data.Text (Text) -import Database.PostgreSQL.Simple (ConnectInfo (..), Only (..), defaultConnectInfo) +import Database.PostgreSQL.Simple (ConnectInfo (..), Only (..)) import qualified Database.PostgreSQL.Simple as PSQL import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Store.Migrations (migrateSchema) @@ -24,7 +26,7 @@ import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists) import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Util (ifM) -import UnliftIO.Exception (onException) +import UnliftIO.Exception (bracketOnError, onException) import UnliftIO.MVar import UnliftIO.STM @@ -44,11 +46,11 @@ createDBStore connectInfo schema migrations confirmMigrations = do Left e -> closeDBStore st $> Left e connectPostgresStore :: ConnectInfo -> String -> IO DBStore -connectPostgresStore dbConnectInfo schema = do - (dbConn, dbNew) <- connectDB dbConnectInfo schema -- TODO [postgres] analogue for dbBusyLoop? +connectPostgresStore dbConnectInfo dbSchema = do + (dbConn, dbNew) <- connectDB dbConnectInfo dbSchema -- TODO [postgres] analogue for dbBusyLoop? dbConnection <- newMVar dbConn dbClosed <- newTVarIO False - pure DBStore {dbConnectInfo, dbConnection, dbNew, dbClosed} + pure DBStore {dbConnectInfo, dbSchema, dbConnection, dbNew, dbClosed} connectDB :: ConnectInfo -> String -> IO (DB.Connection, Bool) connectDB dbConnectInfo schema = do @@ -81,6 +83,22 @@ closeDBStore st@DBStore {dbClosed} = DB.close conn atomically $ writeTVar dbClosed True +openPostgresStore_ :: DBStore -> IO () +openPostgresStore_ DBStore {dbConnectInfo, dbSchema, dbConnection, dbClosed} = + bracketOnError + (takeMVar dbConnection) + (tryPutMVar dbConnection) + $ \_dbConn -> do + (dbConn, _dbNew) <- connectDB dbConnectInfo dbSchema + atomically $ writeTVar dbClosed False + putMVar dbConnection dbConn + +reopenDBStore :: DBStore -> IO () +reopenDBStore st@DBStore {dbClosed} = + ifM (readTVarIO dbClosed) open (putStrLn "reopenDBStore: already opened") + where + open = openPostgresStore_ st + -- TODO [postgres] not necessary for postgres (used for ExecAgentStoreSQL, ExecChatStoreSQL) execSQL :: PSQL.Connection -> Text -> IO [Text] execSQL _db _query = throwIO (userError "not implemented") diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs index b23dcf9c8..1aa73258b 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -17,6 +17,7 @@ import UnliftIO.STM -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type) data DBStore = DBStore { dbConnectInfo :: PSQL.ConnectInfo, + dbSchema :: String, dbConnection :: MVar PSQL.Connection, dbClosed :: TVar Bool, dbNew :: Bool diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs index 15574d313..6b760342f 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20241210_initial.hs @@ -208,7 +208,7 @@ CREATE TABLE ntf_tokens( tkn_action BYTEA, created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()), - ntf_mode TEXT NULL, + ntf_mode BYTEA NULL, PRIMARY KEY(provider, device_token, ntf_host, ntf_port), FOREIGN KEY(ntf_host, ntf_port) REFERENCES ntf_servers ON DELETE RESTRICT ON UPDATE CASCADE @@ -222,8 +222,8 @@ CREATE TABLE ntf_subscriptions( ntf_port TEXT NOT NULL, ntf_sub_id BYTEA, ntf_sub_status TEXT NOT NULL, - ntf_sub_action TEXT, - ntf_sub_smp_action TEXT, + ntf_sub_action BYTEA, + ntf_sub_smp_action BYTEA, ntf_sub_action_ts TIMESTAMPTZ, updated_by_supervisor SMALLINT NOT NULL DEFAULT 0, created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 4e03bb6f3..f023e481e 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -27,13 +27,12 @@ module Simplex.Messaging.Agent.Store.SQLite ( createDBStore, closeDBStore, + reopenDBStore, execSQL, -- used in Simplex.Chat.Archive sqlString, keyString, storeKey, - -- used in Simplex.Chat.Mobile and tests - reopenSQLiteStore, -- used in tests connectSQLiteStore, openSQLiteStore, @@ -127,14 +126,14 @@ openSQLiteStore_ DBStore {dbConnection, dbFilePath, dbKey, dbClosed} key keepKey writeTVar dbKey $! storeKey key keepKey putMVar dbConnection DB.Connection {conn, slow} -reopenSQLiteStore :: DBStore -> IO () -reopenSQLiteStore st@DBStore {dbKey, dbClosed} = - ifM (readTVarIO dbClosed) open (putStrLn "reopenSQLiteStore: already opened") +reopenDBStore :: DBStore -> IO () +reopenDBStore st@DBStore {dbKey, dbClosed} = + ifM (readTVarIO dbClosed) open (putStrLn "reopenDBStore: already opened") where open = readTVarIO dbKey >>= \case Just key -> openSQLiteStore_ st key True - Nothing -> fail "reopenSQLiteStore: no key" + Nothing -> fail "reopenDBStore: no key" keyString :: ScrubbedBytes -> Text keyString = sqlString . safeDecodeUtf8 . BA.convert diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index dff6cd4b0..1c0a69d8d 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -12,6 +12,7 @@ import AgentTests.ConnectionRequestTests import AgentTests.DoubleRatchetTests (doubleRatchetTests) import AgentTests.FunctionalAPITests (functionalAPITests) import AgentTests.MigrationTests (migrationTests) +import AgentTests.NotificationTests (notificationTests) import AgentTests.ServerChoice (serverChoiceTests) import Simplex.Messaging.Transport (ATransport (..)) import Test.Hspec @@ -19,7 +20,6 @@ import Test.Hspec import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #else -import AgentTests.NotificationTests (notificationTests) import AgentTests.SQLiteTests (storeTests) #endif @@ -30,12 +30,12 @@ agentTests (ATransport t) = do describe "Double ratchet tests" doubleRatchetTests #if defined(dbPostgres) after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do +#else + do +#endif describe "Functional API" $ functionalAPITests (ATransport t) describe "Chosen servers" serverChoiceTests -#else - describe "Functional API" $ functionalAPITests (ATransport t) - describe "Chosen servers" serverChoiceTests - -- notifications aren't tested with postgres, as we don't plan to use iOS client with it - describe "Notification tests" $ notificationTests (ATransport t) + describe "Notification tests" $ notificationTests (ATransport t) +#if !defined(dbPostgres) describe "SQLite store" storeTests #endif diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 33e15792e..3709c489b 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -53,7 +54,6 @@ import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Text.Encoding (encodeUtf8) -import Database.SQLite.Simple.QQ (sql) import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) @@ -62,9 +62,9 @@ import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestSte import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT) import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken) -import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, reopenSQLiteStore) -import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction) -import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import Simplex.Messaging.Agent.Store (closeStore, reopenStore) +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol @@ -78,6 +78,11 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) import Test.Hspec import UnliftIO +#if defined(dbPostgres) +import Database.PostgreSQL.Simple.SqlQQ (sql) +#else +import Database.SQLite.Simple.QQ (sql) +#endif notificationTests :: ATransport -> Spec notificationTests t = do @@ -496,7 +501,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 - closeDBStore store + closeStore store threadDelay 1000000 putStrLn "before opening the database from another agent" @@ -507,7 +512,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 1000000 putStrLn "after closing the database in another agent" - reopenSQLiteStore store + reopenStore store foregroundAgent alice threadDelay 500000 diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 51112c426..d076a2fbc 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -604,7 +604,7 @@ testCloseReopenStore = do hasMigrations st closeDBStore st errorGettingMigrations st - reopenSQLiteStore st + reopenDBStore st hasMigrations st testCloseReopenEncryptedStore :: IO () @@ -615,13 +615,13 @@ testCloseReopenEncryptedStore = do closeDBStore st closeDBStore st errorGettingMigrations st - reopenSQLiteStore st `shouldThrow` \(e :: SomeException) -> "reopenSQLiteStore: no key" `isInfixOf` show e + reopenDBStore st `shouldThrow` \(e :: SomeException) -> "reopenDBStore: no key" `isInfixOf` show e openSQLiteStore st key True openSQLiteStore st key True hasMigrations st closeDBStore st errorGettingMigrations st - reopenSQLiteStore st + reopenDBStore st hasMigrations st testReopenEncryptedStoreKeepKey :: IO () @@ -631,7 +631,7 @@ testReopenEncryptedStoreKeepKey = do hasMigrations st closeDBStore st errorGettingMigrations st - reopenSQLiteStore st + reopenDBStore st hasMigrations st getMigrations :: DBStore -> IO Bool From 488c7082f3b8cd1447e2e6f02bd913d2790f3c61 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 20 Jan 2025 17:02:39 +0400 Subject: [PATCH 15/51] agent: store interface (#1436) --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 3 +- src/Simplex/Messaging/Agent/Env/SQLite.hs | 14 +------ src/Simplex/Messaging/Agent/Store.hs | 29 ++----------- .../Messaging/Agent/Store/Interface.hs | 14 +++++++ src/Simplex/Messaging/Agent/Store/Postgres.hs | 41 ++++++++++--------- .../Messaging/Agent/Store/Postgres/Common.hs | 3 +- .../Messaging/Agent/Store/Postgres/Util.hs | 1 - src/Simplex/Messaging/Agent/Store/SQLite.hs | 14 +++++-- tests/AgentTests/FunctionalAPITests.hs | 5 ++- tests/AgentTests/MigrationTests.hs | 22 +++++++--- tests/AgentTests/NotificationTests.hs | 6 +-- tests/AgentTests/SQLiteTests.hs | 10 ++--- tests/AgentTests/SchemaDump.hs | 12 +++--- tests/Fixtures.hs | 5 +++ 15 files changed, 96 insertions(+), 84 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Interface.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 460d8deb5..82f9f3883 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -98,6 +98,7 @@ library Simplex.Messaging.Agent.Store.AgentStore Simplex.Messaging.Agent.Store.Common Simplex.Messaging.Agent.Store.DB + Simplex.Messaging.Agent.Store.Interface Simplex.Messaging.Agent.Store.Migrations Simplex.Messaging.Agent.Store.Shared Simplex.Messaging.Agent.TRcvQueues diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index a7371b935..709f129bd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -170,6 +170,7 @@ import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.AgentStore import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL) import qualified Simplex.Messaging.Agent.Store.Migrations as Migrations import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration) import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) @@ -279,7 +280,7 @@ disposeAgentClient c@AgentClient {acThread, agentEnv = Env {store}} = do t_ <- atomically (swapTVar acThread Nothing) $>>= (liftIO . deRefWeak) disconnectAgentClient c mapM_ killThread t_ - liftIO $ closeStore store + liftIO $ closeDBStore store resumeAgentClient :: AgentClient -> IO () resumeAgentClient c = atomically $ writeTVar (active c) True diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index f1e0aaf15..7b286d3d7 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -70,6 +69,7 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store (createStore) import Simplex.Messaging.Agent.Store.Common (DBStore) +import Simplex.Messaging.Agent.Store.Interface (DBOpts) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C @@ -87,11 +87,6 @@ import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryA import System.Mem.Weak (Weak) import System.Random (StdGen, newStdGen) import UnliftIO.STM -#if defined(dbPostgres) -import Database.PostgreSQL.Simple (ConnectInfo (..)) -#else -import Data.ByteArray (ScrubbedBytes) -#endif type AM' a = ReaderT Env IO a @@ -277,13 +272,8 @@ newSMPAgentEnv config store = do multicastSubscribers <- newTMVarIO 0 pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers} -#if defined(dbPostgres) -createAgentStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createAgentStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore) createAgentStore = createStore -#else -createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore) -createAgentStore = createStore -#endif data NtfSupervisor = NtfSupervisor { ntfTkn :: TVar (Maybe NtfToken), diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 1582f5cc7..ed48bc12b 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -26,13 +25,12 @@ import Data.List (find) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Maybe (isJust) -import Data.Text (Text) import Data.Time (UTCTime) import Data.Type.Equality import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State) import Simplex.Messaging.Agent.Store.Common -import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Store.Interface (DBOpts, createDBStore) import qualified Simplex.Messaging.Agent.Store.Migrations as Migrations import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import qualified Simplex.Messaging.Crypto as C @@ -54,30 +52,9 @@ import Simplex.Messaging.Protocol VersionSMPC, ) import qualified Simplex.Messaging.Protocol as SMP -#if defined(dbPostgres) -import Database.PostgreSQL.Simple (ConnectInfo (..)) -import qualified Simplex.Messaging.Agent.Store.Postgres as Store -#else -import Data.ByteArray (ScrubbedBytes) -import qualified Simplex.Messaging.Agent.Store.SQLite as Store -#endif -#if defined(dbPostgres) -createStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore connectInfo schema = Store.createDBStore connectInfo schema Migrations.app -#else -createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore) -createStore dbFilePath dbKey keepKey = Store.createDBStore dbFilePath dbKey keepKey Migrations.app -#endif - -closeStore :: DBStore -> IO () -closeStore = Store.closeDBStore - -reopenStore :: DBStore -> IO () -reopenStore = Store.reopenDBStore - -execSQL :: DB.Connection -> Text -> IO [Text] -execSQL = Store.execSQL +createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createStore dbOpts = createDBStore dbOpts Migrations.app -- * Queue types diff --git a/src/Simplex/Messaging/Agent/Store/Interface.hs b/src/Simplex/Messaging/Agent/Store/Interface.hs new file mode 100644 index 000000000..e31d28a25 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Interface.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} + +module Simplex.Messaging.Agent.Store.Interface +#if defined(dbPostgres) + ( module Simplex.Messaging.Agent.Store.Postgres, + ) + where +import Simplex.Messaging.Agent.Store.Postgres +#else + ( module Simplex.Messaging.Agent.Store.SQLite, + ) + where +import Simplex.Messaging.Agent.Store.SQLite +#endif diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 4d2f6c33c..803cbfb99 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -5,7 +5,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Simplex.Messaging.Agent.Store.Postgres - ( createDBStore, + ( DBOpts (..), + createDBStore, closeDBStore, reopenDBStore, execSQL, @@ -14,47 +15,49 @@ where import Control.Exception (throwIO) import Control.Monad (unless, void) +import Data.ByteString (ByteString) import Data.Functor (($>)) import Data.String (fromString) import Data.Text (Text) -import Database.PostgreSQL.Simple (ConnectInfo (..), Only (..)) +import Database.PostgreSQL.Simple (Only (..)) import qualified Database.PostgreSQL.Simple as PSQL import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Store.Migrations (migrateSchema) import Simplex.Messaging.Agent.Store.Postgres.Common import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB -import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists) import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Util (ifM) import UnliftIO.Exception (bracketOnError, onException) import UnliftIO.MVar import UnliftIO.STM --- | Create a new Postgres DBStore with the given connection info, schema name and migrations. --- This function creates the user and/or database passed in connectInfo if they do not exist --- (expects the default 'postgres' user and 'postgres' db to exist). +data DBOpts = DBOpts + { connstr :: ByteString, + schema :: String + } + +-- | Create a new Postgres DBStore with the given connection string, schema name and migrations. -- If passed schema does not exist in connectInfo database, it will be created. -- Applies necessary migrations to schema. -- TODO [postgres] authentication / user password, db encryption (?) -createDBStore :: ConnectInfo -> String -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createDBStore connectInfo schema migrations confirmMigrations = do - createDBAndUserIfNotExists connectInfo - st <- connectPostgresStore connectInfo schema +createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do + st <- connectPostgresStore connstr schema r <- migrateSchema st migrations confirmMigrations True `onException` closeDBStore st case r of Right () -> pure $ Right st Left e -> closeDBStore st $> Left e -connectPostgresStore :: ConnectInfo -> String -> IO DBStore -connectPostgresStore dbConnectInfo dbSchema = do - (dbConn, dbNew) <- connectDB dbConnectInfo dbSchema -- TODO [postgres] analogue for dbBusyLoop? +connectPostgresStore :: ByteString -> String -> IO DBStore +connectPostgresStore dbConnstr dbSchema = do + (dbConn, dbNew) <- connectDB dbConnstr dbSchema -- TODO [postgres] analogue for dbBusyLoop? dbConnection <- newMVar dbConn dbClosed <- newTVarIO False - pure DBStore {dbConnectInfo, dbSchema, dbConnection, dbNew, dbClosed} + pure DBStore {dbConnstr, dbSchema, dbConnection, dbNew, dbClosed} -connectDB :: ConnectInfo -> String -> IO (DB.Connection, Bool) -connectDB dbConnectInfo schema = do - db <- PSQL.connect dbConnectInfo +connectDB :: ByteString -> String -> IO (DB.Connection, Bool) +connectDB connstr schema = do + db <- PSQL.connectPostgreSQL connstr schemaExists <- prepare db `onException` PSQL.close db let dbNew = not schemaExists pure (db, dbNew) @@ -84,12 +87,12 @@ closeDBStore st@DBStore {dbClosed} = atomically $ writeTVar dbClosed True openPostgresStore_ :: DBStore -> IO () -openPostgresStore_ DBStore {dbConnectInfo, dbSchema, dbConnection, dbClosed} = +openPostgresStore_ DBStore {dbConnstr, dbSchema, dbConnection, dbClosed} = bracketOnError (takeMVar dbConnection) (tryPutMVar dbConnection) $ \_dbConn -> do - (dbConn, _dbNew) <- connectDB dbConnectInfo dbSchema + (dbConn, _dbNew) <- connectDB dbConnstr dbSchema atomically $ writeTVar dbClosed False putMVar dbConnection dbConn diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs index 1aa73258b..f130a1b5f 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Common.hs @@ -10,13 +10,14 @@ module Simplex.Messaging.Agent.Store.Postgres.Common ) where +import Data.ByteString (ByteString) import qualified Database.PostgreSQL.Simple as PSQL import UnliftIO.MVar import UnliftIO.STM -- TODO [postgres] use log_min_duration_statement instead of custom slow queries (SQLite's Connection type) data DBStore = DBStore - { dbConnectInfo :: PSQL.ConnectInfo, + { dbConnstr :: ByteString, dbSchema :: String, dbConnection :: MVar PSQL.Connection, dbClosed :: TVar Bool, diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Util.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Util.hs index 98c0024f3..0913c76e3 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Util.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Util.hs @@ -5,7 +5,6 @@ module Simplex.Messaging.Agent.Store.Postgres.Util ( createDBAndUserIfNotExists, - -- for tests dropSchema, dropAllSchemasExceptSystem, dropDatabaseAndUser, diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index f023e481e..585f40a0c 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -25,7 +25,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Simplex.Messaging.Agent.Store.SQLite - ( createDBStore, + ( DBOpts (..), + createDBStore, closeDBStore, reopenDBStore, execSQL, @@ -64,8 +65,15 @@ import UnliftIO.STM -- * SQLite Store implementation -createDBStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore) -createDBStore dbFilePath dbKey keepKey migrations confirmMigrations vacuum = do +data DBOpts = DBOpts + { dbFilePath :: FilePath, + dbKey :: ScrubbedBytes, + keepKey :: Bool, + vacuum :: Bool + } + +createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createDBStore DBOpts {dbFilePath, dbKey, keepKey, vacuum} migrations confirmMigrations = do let dbDir = takeDirectory dbFilePath createDirectoryIfMissing True dbDir st <- connectSQLiteStore dbFilePath dbKey keepKey diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index f569cc3d5..602b74edc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -85,6 +85,7 @@ import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT) import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) +import Simplex.Messaging.Agent.Store.Interface import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (..), defaultClientConfig) @@ -3107,13 +3108,13 @@ getSMPAgentClient' clientId cfg' initServers dbPath = do #if defined(dbPostgres) createStore :: String -> IO (Either MigrationError DBStore) -createStore schema = createAgentStore testDBConnectInfo schema MCError +createStore schema = createAgentStore (DBOpts testDBConnstr schema) MCError insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") #else createStore :: String -> IO (Either MigrationError DBStore) -createStore dbPath = createAgentStore dbPath "" False MCError True +createStore dbPath = createAgentStore (DBOpts dbPath "" False True) MCError insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)") diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index 9bbb41be1..5ad4f101d 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/tests/AgentTests/MigrationTests.hs @@ -7,6 +7,7 @@ import Control.Monad import Data.Maybe (fromJust) import Data.Word (Word32) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import Simplex.Messaging.Agent.Store.Interface import Simplex.Messaging.Agent.Store.Migrations (migrationsToRun) import Simplex.Messaging.Agent.Store.Shared import System.Random (randomIO) @@ -14,12 +15,10 @@ import Test.Hspec #if defined(dbPostgres) import Database.PostgreSQL.Simple (fromOnly) import Fixtures -import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) import Simplex.Messaging.Agent.Store.Postgres.Util (dropSchema) import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB #else import Database.SQLite.Simple (fromOnly) -import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, createDBStore) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import System.Directory (removeFile) #endif @@ -203,8 +202,13 @@ testSchema :: Word32 -> String testSchema randSuffix = "test_migrations_schema" <> show randSuffix createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore randSuffix migrations confirmMigrations = - createDBStore testDBConnectInfo (testSchema randSuffix) migrations confirmMigrations +createStore randSuffix migrations confirmMigrations = do + let dbOpts = + DBOpts { + connstr = testDBConnstr, + schema = testSchema randSuffix + } + createDBStore dbOpts migrations confirmMigrations cleanup :: Word32 -> IO () cleanup randSuffix = dropSchema testDBConnectInfo (testSchema randSuffix) @@ -218,7 +222,15 @@ testDB :: Word32 -> FilePath testDB randSuffix = "tests/tmp/test_migrations.db" <> show randSuffix createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore randSuffix migrations migrationConf = createDBStore (testDB randSuffix) "" False migrations migrationConf True +createStore randSuffix migrations confirmMigrations = do + let dbOpts = + DBOpts { + dbFilePath = testDB randSuffix, + dbKey = "", + keepKey = False, + vacuum = True + } + createDBStore dbOpts migrations confirmMigrations cleanup :: Word32 -> IO () cleanup randSuffix = removeFile (testDB randSuffix) diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 3709c489b..9ad97fe1f 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -62,8 +62,8 @@ import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestSte import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT) import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken) -import Simplex.Messaging.Agent.Store (closeStore, reopenStore) import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -501,7 +501,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 - closeStore store + closeDBStore store threadDelay 1000000 putStrLn "before opening the database from another agent" @@ -512,7 +512,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 1000000 putStrLn "after closing the database in another agent" - reopenStore store + reopenDBStore store foregroundAgent alice threadDelay 500000 diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index d076a2fbc..84f30ff96 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -69,8 +69,8 @@ withStore2 = before connect2 . after (removeStore . fst) where connect2 :: IO (DBStore, DBStore) connect2 = do - s1 <- createStore' - s2 <- connectSQLiteStore (dbFilePath s1) "" False + s1@DBStore {dbFilePath} <- createStore' + s2 <- connectSQLiteStore dbFilePath "" False pure (s1, s2) createStore' :: IO DBStore @@ -81,14 +81,14 @@ createEncryptedStore key keepKey = 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 - Right st <- createDBStore (testDB <> show r) key keepKey Migrations.app MCError True + Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True) Migrations.app MCError withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);") pure st removeStore :: DBStore -> IO () -removeStore db = do +removeStore db@DBStore {dbFilePath} = do close db - removeFile $ dbFilePath db + removeFile dbFilePath where close :: DBStore -> IO () close st = mapM_ DB.close =<< tryTakeMVar (dbConnection st) diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index ba81bc79c..75e89d00e 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -49,7 +49,7 @@ testVerifySchemaDump :: IO () testVerifySchemaDump = do savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "") savedSchema `deepseq` pure () - void $ createDBStore testDB "" False Migrations.app MCConsole True + void $ createDBStore (DBOpts testDB "" False True) Migrations.app MCConsole getSchema testDB appSchema `shouldReturn` savedSchema removeFile testDB @@ -57,7 +57,7 @@ testVerifyLintFKeyIndexes :: IO () testVerifyLintFKeyIndexes = do savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "") savedLint `deepseq` pure () - void $ createDBStore testDB "" False Migrations.app MCConsole True + void $ createDBStore (DBOpts testDB "" False True) Migrations.app MCConsole getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint removeFile testDB @@ -70,7 +70,7 @@ withTmpFiles = testSchemaMigrations :: IO () testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app - Right st <- createDBStore testDB "" False noDownMigrations MCError True + Right st <- createDBStore (DBOpts testDB "" False True) noDownMigrations MCError mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app closeDBStore st removeFile testDB @@ -93,7 +93,7 @@ testSchemaMigrations = do testUsersMigrationNew :: IO () testUsersMigrationNew = do - Right st <- createDBStore testDB "" False Migrations.app MCError True + Right st <- createDBStore (DBOpts testDB "" False True) Migrations.app MCError withTransaction' st (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([] :: [Only Int]) closeDBStore st @@ -101,11 +101,11 @@ testUsersMigrationNew = do testUsersMigrationOld :: IO () testUsersMigrationOld = do let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app - Right st <- createDBStore testDB "" False beforeUsers MCError True + Right st <- createDBStore (DBOpts testDB "" False True) beforeUsers MCError withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';") `shouldReturn` ([] :: [Only String]) closeDBStore st - Right st' <- createDBStore testDB "" False Migrations.app MCYesUp True + Right st' <- createDBStore (DBOpts testDB "" False True) Migrations.app MCYesUp withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([Only (1 :: Int)]) closeDBStore st' diff --git a/tests/Fixtures.hs b/tests/Fixtures.hs index 54065d121..d8c7c5cc1 100644 --- a/tests/Fixtures.hs +++ b/tests/Fixtures.hs @@ -1,12 +1,17 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Fixtures where #if defined(dbPostgres) +import Data.ByteString (ByteString) import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) #endif #if defined(dbPostgres) +testDBConnstr :: ByteString +testDBConnstr = "postgresql://test_agent_user@/test_agent_db" + testDBConnectInfo :: ConnectInfo testDBConnectInfo = defaultConnectInfo { From 6a9075141f5b802488c312052558e664e0709a9a Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 20 Jan 2025 13:45:49 +0000 Subject: [PATCH 16/51] xftp server: use recipient ID in control port to delete and block files, smp server: fix version negotiation (#1434) * xftp server: use recipient ID in control port to delete and block files * cap smp proxy agent version at 10 * version * fix prometheus * fix * remove old version support * log connection parameter on error * tests * log sent command tag * log error and client version * cap proxy version for previous destination server * comment, test * remove logging tag * remove logs * version * SMP version 14 * version * remove comments * version --- src/Simplex/FileTransfer/Server.hs | 16 +- src/Simplex/FileTransfer/Transport.hs | 4 +- src/Simplex/Messaging/Client.hs | 22 ++- .../Messaging/Notifications/Transport.hs | 4 +- src/Simplex/Messaging/Protocol.hs | 14 +- src/Simplex/Messaging/Server/Main.hs | 6 +- src/Simplex/Messaging/Server/Prometheus.hs | 4 +- src/Simplex/Messaging/Transport.hs | 162 +++++++++++------- tests/AgentTests/FunctionalAPITests.hs | 20 +-- tests/CLITests.hs | 2 +- tests/CoreTests/BatchingTests.hs | 6 +- tests/NtfClient.hs | 2 +- tests/SMPClient.hs | 10 +- tests/SMPProxyTests.hs | 6 +- tests/ServerTests.hs | 2 +- 15 files changed, 153 insertions(+), 127 deletions(-) diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 935afe2f9..407b65a70 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -287,13 +287,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira CPDelete fileId -> withUserRole $ unliftIO u $ do fs <- asks store r <- runExceptT $ do - (fr, _) <- ExceptT $ atomically $ getFile fs SFSender fileId + (fr, _) <- ExceptT $ atomically $ getFile fs SFRecipient fileId ExceptT $ deleteServerFile_ fr liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r CPBlock fileId info -> withUserRole $ unliftIO u $ do fs <- asks store r <- runExceptT $ do - (fr, _) <- ExceptT $ atomically $ getFile fs SFSender fileId + (fr, _) <- ExceptT $ atomically $ getFile fs SFRecipient fileId ExceptT $ blockServerFile fr info liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit" @@ -540,12 +540,12 @@ blockServerFile fr@FileRec {senderId} info = do deleteOrBlockServerFile_ :: FileRec -> (FileServerStats -> IORef Int) -> (FileStore -> STM (Either XFTPErrorType ())) -> M (Either XFTPErrorType ()) deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExceptT $ do - path <- readTVarIO filePath - stats <- asks serverStats - ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats)) - st <- asks store - void $ atomically $ storeAction st - lift $ incFileStat stat + path <- readTVarIO filePath + stats <- asks serverStats + ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats)) + st <- asks store + void $ atomically $ storeAction st + lift $ incFileStat stat where deletedStats stats = do liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1) diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 7f90b2879..3d80949d0 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -102,8 +102,8 @@ supportedFileServerVRange :: VersionRangeXFTP supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion -- XFTP protocol does not use this handshake method -xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient) -xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwE TEVersion +xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient) +xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion supportedXFTPhandshakes :: [ALPN] supportedXFTPhandshakes = ["xftp/1"] diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 9a030d4a5..bde663b32 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -171,7 +171,7 @@ data PClient v err msg = PClient timeoutErrorCount :: TVar Int, clientCorrId :: TVar ChaChaDRG, sentCommands :: TMap CorrId (Request err msg), - sndQ :: TBQueue (Maybe (TVar Bool), ByteString), + sndQ :: TBQueue (Maybe (Request err msg), ByteString), rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)), msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg)) } @@ -406,6 +406,8 @@ data ProtocolClientConfig v = ProtocolClientConfig serverVRange :: VersionRange v, -- | agree shared session secret (used in SMP proxy for additional encryption layer) agreeSecret :: Bool, + -- | Whether connecting client is a proxy server. See comment in ClientHandshake + proxyServer :: Bool, -- | send SNI to server, False for SMP useSNI :: Bool } @@ -420,6 +422,7 @@ defaultClientConfig clientALPN useSNI serverVRange = clientALPN, serverVRange, agreeSecret = False, + proxyServer = False, useSNI } {-# INLINE defaultClientConfig #-} @@ -489,7 +492,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString) -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) -getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, useSNI} msgQ proxySessTs disconnected = do +getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, proxyServer, useSNI} msgQ proxySessTs disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost) @@ -548,7 +551,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO () client _ c cVar h = do ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing - runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange) >>= \case + runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case Left e -> atomically . putTMVar cVar . Left $ PCETransportError e Right th@THandle {params} -> do sessionTs <- getCurrentTime @@ -563,9 +566,12 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= sendPending where - sendPending (Nothing, s) = send_ s - sendPending (Just pending, s) = whenM (readTVarIO pending) $ send_ s - send_ = void . tPutLog h + sendPending (r, s) = case r of + Nothing -> void $ tPutLog h s + Just Request {pending, responseVar} -> + whenM (readTVarIO pending) $ tPutLog h s >>= either responseErr pure + where + responseErr = atomically . putTMVar responseVar . Left . PCETransportError receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do @@ -1101,12 +1107,12 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan where -- two separate "atomically" needed to avoid blocking sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg) - sendRecv t_ r@Request {pending} = case t_ of + sendRecv t_ r = case t_ of Left e -> pure . Left $ PCETransportError e Right t | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg | otherwise -> do - atomically $ writeTBQueue sndQ (Just pending, s) + atomically $ writeTBQueue sndQ (Just r, s) response <$> getResponse c tOut r where s diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 836b6b1e7..fc928535d 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -123,8 +123,8 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do Nothing -> throwE TEVersion -- | Notifcations server client transport handshake. -ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient) -ntfClientHandshake c keyHash ntfVRange = do +ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient) +ntfClientHandshake c keyHash ntfVRange _proxyServer = do let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th if sessionId /= sessId diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 2a76faa05..679f077b7 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -260,7 +260,7 @@ supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClie -- TODO v6.0 remove dependency on version maxMessageLength :: VersionSMP -> Int maxMessageLength v - | v >= encryptedBlockSMPVersion = 16048 -- max 16051 + | v >= encryptedBlockSMPVersion = 16048 -- max 16048 | v >= sendingProxySMPVersion = 16064 -- max 16067 | otherwise = 16088 -- 16048 - always use this size to determine allowed ranges @@ -1343,7 +1343,7 @@ transmissionP THandleParams {sessionId, implySessId} = do class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where type ProtoCommand msg = cmd | cmd -> msg type ProtoType msg = (sch :: ProtocolType) | sch -> msg - protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient) + protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient) protocolPing :: ProtoCommand msg protocolError :: msg -> Maybe err @@ -1370,9 +1370,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where encodeProtocol v = \case NEW rKey dhKey auth_ subMode sndSecure | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure) - | v >= subModeSMPVersion -> new <> auth <> e subMode - | v == basicAuthSMPVersion -> new <> auth - | otherwise -> new + | otherwise -> new <> auth <> e subMode where new = e (NEW_, ' ', rKey, dhKey) auth = maybe "" (e . ('A',)) auth_ @@ -1441,9 +1439,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where Cmd SRecipient <$> case tag of NEW_ | v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP - | v >= subModeSMPVersion -> new <*> auth <*> smpP <*> pure False - | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe <*> pure False - | otherwise -> new <*> pure Nothing <*> pure SMSubscribe <*> pure False + | otherwise -> new <*> auth <*> smpP <*> pure False where new = NEW <$> _smpP <*> smpP auth = optional (A.char 'A' *> smpP) @@ -1495,7 +1491,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where INFO info -> e (INFO_, ' ', info) OK -> e OK_ ERR err -> case err of - BLOCKED _ | v < blockedEntityErrorSMPVersion -> e (ERR_, ' ', AUTH) + BLOCKED _ | v < blockedEntitySMPVersion -> e (ERR_, ' ', AUTH) _ -> e (ERR_, ' ', err) PONG -> e PONG_ where diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 0ecc5cf94..1d21ffa6a 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -47,11 +47,10 @@ import Simplex.Messaging.Server.Information import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.QueueStore.STM (readQueueStore) -import Simplex.Messaging.Transport (batchCmdsSMPVersion, currentServerSMPRelayVersion, simplexMQVersion, supportedServerSMPRelayVRange) +import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow) -import Simplex.Messaging.Version (mkVersionRange) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Exit (exitFailure) import System.FilePath (combine) @@ -447,8 +446,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = defaultSMPClientAgentConfig { smpCfg = (smpCfg defaultSMPClientAgentConfig) - { serverVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion, + { serverVRange = supportedProxyClientSMPRelayVRange, agreeSecret = True, + proxyServer = True, networkConfig = defaultNetworkConfig { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini, diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index cb9c68d04..3f5c3f87e 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -124,8 +124,8 @@ prometheusMetrics sm rtm ts = \simplex_smp_queues_deleted{type=\"new\"} " <> mshow _qDeletedNew <> "\n# qDeletedNew\n\ \simplex_smp_queues_deleted{type=\"secured\"} " <> mshow _qDeletedSecured <> "\n# qDeletedSecured\n\ \\n\ - \# HELP simplex_smp_queues_deleted Deleted queues\n\ - \# TYPE simplex_smp_queues_deleted counter\n\ + \# HELP simplex_smp_queues_blocked Deleted queues\n\ + \# TYPE simplex_smp_queues_blocked counter\n\ \simplex_smp_queues_blocked " <> mshow _qBlocked <> "\n# qBlocked\n\ \\n\ \# HELP simplex_smp_queues_deleted_batch Batched requests to delete queues\n\ diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index d4601d569..67cb83d01 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} @@ -14,6 +15,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Simplex.Messaging.Transport @@ -36,20 +38,20 @@ module Simplex.Messaging.Transport supportedSMPHandshakes, supportedClientSMPRelayVRange, supportedServerSMPRelayVRange, + supportedProxyClientSMPRelayVRange, proxiedSMPRelayVRange, + minClientSMPRelayVersion, + minServerSMPRelayVersion, legacyServerSMPRelayVRange, currentClientSMPRelayVersion, legacyServerSMPRelayVersion, currentServerSMPRelayVersion, - batchCmdsSMPVersion, - basicAuthSMPVersion, - subModeSMPVersion, authCmdsSMPVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, deletedEventSMPVersion, encryptedBlockSMPVersion, - blockedEntityErrorSMPVersion, + blockedEntitySMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -90,7 +92,7 @@ where import Control.Applicative (optional) import Control.Concurrent.STM -import Control.Monad (forM, (<$!>)) +import Control.Monad (forM, when, (<$!>)) import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Except (throwE) @@ -139,11 +141,12 @@ smpBlockSize = 16384 -- 5 - basic auth for SMP servers (11/12/2022) -- 6 - allow creating queues without subscribing (9/10/2023) -- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024) --- 8 - SMP proxy for sender commands --- 9 - faster handshake: SKEY command for sender to secure queue --- 10 - DELD event to subscriber when queue is deleted via another connnection --- 11 - additional encryption of transport blocks with forward secrecy (9/14/2024) +-- 8 - SMP proxy for sender commands (6/03/2024) +-- 9 - faster handshake: SKEY command for sender to secure queue (6/30/2024) +-- 10 - DELD event to subscriber when queue is deleted via another connnection (9/11/2024) +-- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024) -- 12 - BLOCKED error for blocked queues (1/11/2025) +-- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025) data SMPVersion @@ -156,14 +159,8 @@ type VersionRangeSMP = VersionRange SMPVersion pattern VersionSMP :: Word16 -> VersionSMP pattern VersionSMP v = Version v -batchCmdsSMPVersion :: VersionSMP -batchCmdsSMPVersion = VersionSMP 4 - -basicAuthSMPVersion :: VersionSMP -basicAuthSMPVersion = VersionSMP 5 - -subModeSMPVersion :: VersionSMP -subModeSMPVersion = VersionSMP 6 +_subModeSMPVersion :: VersionSMP +_subModeSMPVersion = VersionSMP 6 authCmdsSMPVersion :: VersionSMP authCmdsSMPVersion = VersionSMP 7 @@ -180,17 +177,26 @@ deletedEventSMPVersion = VersionSMP 10 encryptedBlockSMPVersion :: VersionSMP encryptedBlockSMPVersion = VersionSMP 11 -blockedEntityErrorSMPVersion :: VersionSMP -blockedEntityErrorSMPVersion = VersionSMP 12 +blockedEntitySMPVersion :: VersionSMP +blockedEntitySMPVersion = VersionSMP 12 + +proxyServerHandshakeSMPVersion :: VersionSMP +proxyServerHandshakeSMPVersion = VersionSMP 14 + +minClientSMPRelayVersion :: VersionSMP +minClientSMPRelayVersion = VersionSMP 6 + +minServerSMPRelayVersion :: VersionSMP +minServerSMPRelayVersion = VersionSMP 6 currentClientSMPRelayVersion :: VersionSMP -currentClientSMPRelayVersion = VersionSMP 12 +currentClientSMPRelayVersion = VersionSMP 14 legacyServerSMPRelayVersion :: VersionSMP legacyServerSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 12 +currentServerSMPRelayVersion = VersionSMP 14 -- Max SMP protocol version to be used in e2e encrypted -- connection between client and server, as defined by SMP proxy. @@ -198,20 +204,22 @@ currentServerSMPRelayVersion = VersionSMP 12 -- to prevent client version fingerprinting by the -- destination relays when clients upgrade at different times. proxiedSMPRelayVersion :: VersionSMP -proxiedSMPRelayVersion = VersionSMP 12 +proxiedSMPRelayVersion = VersionSMP 14 --- minimal supported protocol version is 4 +-- minimal supported protocol version is 6 -- TODO remove code that supports sending commands without batching supportedClientSMPRelayVRange :: VersionRangeSMP -supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion +supportedClientSMPRelayVRange = mkVersionRange minClientSMPRelayVersion currentClientSMPRelayVersion legacyServerSMPRelayVRange :: VersionRangeSMP -legacyServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion legacyServerSMPRelayVersion +legacyServerSMPRelayVRange = mkVersionRange minServerSMPRelayVersion legacyServerSMPRelayVersion supportedServerSMPRelayVRange :: VersionRangeSMP -supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion +supportedServerSMPRelayVRange = mkVersionRange minServerSMPRelayVersion currentServerSMPRelayVersion + +supportedProxyClientSMPRelayVRange :: VersionRangeSMP +supportedProxyClientSMPRelayVRange = mkVersionRange minServerSMPRelayVersion currentServerSMPRelayVersion --- This range initially allows only version 8 - see the comment above. proxiedSMPRelayVRange :: VersionRangeSMP proxiedSMPRelayVRange = mkVersionRange sendingProxySMPVersion proxiedSMPRelayVersion @@ -412,7 +420,7 @@ data THandleParams v p = THandleParams -- | do NOT send session ID in transmission, but include it into signed message -- based on protocol version implySessId :: Bool, - -- -- | additional block encryption + -- | keys for additional transport encryption encryptBlock :: Maybe TSbChainKeys, -- | send multiple transmissions in a single block -- based on protocol version @@ -453,18 +461,28 @@ data ClientHandshake = ClientHandshake smpVersion :: VersionSMP, -- | server identity - CA certificate fingerprint keyHash :: C.KeyHash, - -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys. - authPubKey :: Maybe C.PublicKeyX25519 + -- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys. + authPubKey :: Maybe C.PublicKeyX25519, + -- | Whether connecting client is a proxy server (send from SMP v12). + -- This property, if True, disables additional transport encrytion inside TLS. + -- (Proxy server connection already has additional encryption, so this layer is not needed there). + proxyServer :: Bool } instance Encoding ClientHandshake where - smpEncode ClientHandshake {smpVersion, keyHash, authPubKey} = - smpEncode (smpVersion, keyHash) <> encodeAuthEncryptCmds smpVersion authPubKey + smpEncode ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} = + smpEncode (v, keyHash) + <> encodeAuthEncryptCmds v authPubKey + <> ifHasProxy v (smpEncode proxyServer) "" smpP = do - (smpVersion, keyHash) <- smpP + (v, keyHash) <- smpP -- TODO drop SMP v6: remove special parser and make key non-optional - authPubKey <- authEncryptCmdsP smpVersion smpP - pure ClientHandshake {smpVersion, keyHash, authPubKey} + authPubKey <- authEncryptCmdsP v smpP + proxyServer <- ifHasProxy v smpP (pure False) + pure ClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer} + +ifHasProxy :: VersionSMP -> a -> a -> a +ifHasProxy v a b = if v >= proxyServerHandshakeSMPVersion then a else b instance Encoding ServerHandshake where smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} = @@ -572,54 +590,70 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)} getHandshake th >>= \case - ClientHandshake {smpVersion = v, keyHash, authPubKey = k'} + ClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer} | keyHash /= kh -> throwE $ TEHandshake IDENTITY | otherwise -> case compatibleVRange' smpVersionRange v of - Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k' + Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k' proxyServer Nothing -> throwE TEVersion -- | Client SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TClient) -smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do +smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> ExceptT TransportError IO (THandleSMP c 'TClient) +smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do let th@THandle {params = THandleParams {sessionId}} = smpTHandle c ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th - if sessionId /= sessId - then throwE TEBadSession - else case smpVersionRange `compatibleVRange` smpVRange of - Just (Compatible vr) -> do - ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) -> - liftEitherWith (const $ TEHandshake BAD_AUTH) $ do - case cert of - [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure () - _ -> throwError "bad certificate" - serverKey <- getServerVerifyKey c - pubKey <- C.verifyX509 serverKey exact - (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey) - let v = maxVersion vr - sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_} - liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ - Nothing -> throwE TEVersion + when (sessionId /= sessId) $ throwE TEBadSession + -- Below logic downgrades version range in case the "client" is SMP proxy server and it is + -- connected to the destination server of the version 11 or older. + -- It disables transport encryption between SMP proxy and destination relay. + -- + -- Prior to version v6.3 the version between proxy and destination was capped at 8, + -- by mistake, which also disables transport encryption and the latest features. + -- + -- Transport encryption between proxy and destination breaks clients with version 10 or earlier, + -- because of a larger message size (see maxMessageLength). + -- + -- To summarize: + -- - proxy and relay version 12: the agreed version is 12, transport encryption disabled (see blockEncryption with proxyServer == True). + -- - proxy is v 12, relay is 11: the agreed version is 10, because of this logic, transport encryption is disabled. + let smpVRange = + if proxyServer && maxVersion smpVersionRange < proxyServerHandshakeSMPVersion + then vRange {maxVersion = max (minVersion vRange) deletedEventSMPVersion} + else vRange + case smpVersionRange `compatibleVRange` smpVRange of + Just (Compatible vr) -> do + ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) -> + liftEitherWith (const $ TEHandshake BAD_AUTH) $ do + case cert of + [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure () + _ -> throwError "bad certificate" + serverKey <- getServerVerifyKey c + pubKey <- C.verifyX509 serverKey exact + (,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey) + let v = maxVersion vr + sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer} + liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer + Nothing -> throwE TEVersion -smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> IO (THandleSMP c 'TServer) -smpTHandleServer th v vr pk k_ = do +smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> IO (THandleSMP c 'TServer) +smpTHandleServer th v vr pk k_ proxyServer = do let thAuth = Just THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_} - be <- blockEncryption th v thAuth + be <- blockEncryption th v proxyServer thAuth pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be -smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> IO (THandleSMP c 'TClient) -smpTHandleClient th v vr pk_ ck_ = do +smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> Bool -> IO (THandleSMP c 'TClient) +smpTHandleClient th v vr pk_ ck_ proxyServer = do let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_ - be <- blockEncryption th v thAuth + be <- blockEncryption th v proxyServer thAuth -- swap is needed to use client's sndKey as server's rcvKey and vice versa pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be -blockEncryption :: THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey)) -blockEncryption THandle {params = THandleParams {sessionId}} v = \case - Just thAuth | v >= encryptedBlockSMPVersion -> case thAuth of +blockEncryption :: THandleSMP c p -> VersionSMP -> Bool -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey)) +blockEncryption THandle {params = THandleParams {sessionId}} v proxyServer = \case + Just thAuth | not proxyServer && v >= encryptedBlockSMPVersion -> case thAuth of THAuthClient {sessSecret} -> be sessSecret THAuthServer {sessSecret'} -> be sessSecret' _ -> pure Nothing diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 602b74edc..12bea5c90 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -100,7 +100,7 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -426,7 +426,6 @@ functionalAPITests t = do describe "should switch two connections simultaneously, abort one" $ testServerMatrix2 t testSwitch2ConnectionsAbort1 describe "SMP basic auth" $ do - let v4 = prevVersion basicAuthSMPVersion forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do let baseId = if v >= sndAuthKeySMPVersion then 1 else 3 sqSecured = if v >= sndAuthKeySMPVersion then True else False @@ -436,20 +435,12 @@ functionalAPITests t = do it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 - it "NEW fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1 it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1 - it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) sqSecured baseId `shouldReturn` 1 describe ("v" <> show v <> ": no server auth") $ do it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2 it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0 - it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) False 3 `shouldReturn` 2 - it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) False baseId `shouldReturn` 2 - it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) sqSecured 3 `shouldReturn` 2 - it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) False 3 `shouldReturn` 2 - it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) False 3 `shouldReturn` 2 it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2 - it "auth fst 2 " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) False 3 `shouldReturn` 2 it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 @@ -482,7 +473,7 @@ functionalAPITests t = do testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do - let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange batchCmdsSMPVersion srvVersion} + let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion} canCreate1 = canCreateQueue allowNewQueues srv clnt1 canCreate2 = canCreateQueue allowNewQueues srv clnt2 expected @@ -494,9 +485,8 @@ testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured b pure created canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> Bool -canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = - let v = basicAuthSMPVersion - in allowNew && (isNothing srvAuth || (srvVersion >= v && clntVersion >= v && srvAuth == clntAuth)) +canCreateQueue allowNew (srvAuth, _) (clntAuth, _) = + allowNew && (isNothing srvAuth || srvAuth == clntAuth) testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do @@ -2890,7 +2880,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do getClient clientId (clntAuth, clntVersion) db = let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]} alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing - smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion + smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange minClientSMPRelayVersion clntVersion sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 01b68653d..10ec33f4c 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -174,7 +174,7 @@ smpServerTestStatic = do X.Certificate {X.certPubKey = X.PubKeyEd25519 _k} : _ca -> print _ca -- pure () leaf : _ -> error $ "Unexpected leaf cert: " <> show leaf [] -> error "Empty chain" - runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange + runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False logDebug "Combined SMP works" where getCerts :: TLS -> [X.Certificate] diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 41b1a6a38..3e6a3fa40 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -296,7 +296,7 @@ testClientStubV6 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) testClientStubV6 = do g <- C.newRandom sessId <- atomically $ C.randomBytes 32 g - smpClientStub g sessId subModeSMPVersion Nothing + smpClientStub g sessId minServerSMPRelayVersion Nothing testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) testClientStub = do @@ -307,7 +307,7 @@ testClientStub = do smpClientStub g sessId currentClientSMPRelayVersion thAuth_ randomSUBv6 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) -randomSUBv6 = randomSUB_ C.SEd25519 subModeSMPVersion +randomSUBv6 = randomSUB_ C.SEd25519 minServerSMPRelayVersion randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSUB = randomSUB_ C.SEd25519 currentClientSMPRelayVersion @@ -354,7 +354,7 @@ randomNMSGCmd ts = do pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta) randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) -randomSENDv6 = randomSEND_ C.SEd25519 subModeSMPVersion +randomSENDv6 = randomSEND_ C.SEd25519 minServerSMPRelayVersion randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSEND = randomSEND_ C.SX25519 currentClientSMPRelayVersion diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index e8c263e89..190815832 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -82,7 +82,7 @@ testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a testNtfClient client = do Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> - runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange) >>= \case + runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange False) >>= \case Right th -> client th Left e -> error $ show e diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 5f7935cd9..5ce0eb7f6 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -105,7 +105,7 @@ testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP testSMPClient_ host port vr client = do let tcConfig = defaultTransportClientConfig {Client.alpn = clientALPN} runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h -> - runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case + runExceptT (smpClientHandshake h Nothing testKeyHash vr False) >>= \case Right th -> client th Left e -> error $ show e where @@ -167,10 +167,10 @@ cfgMS msType = } cfgV7 :: ServerConfig -cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} +cfgV7 = cfg {smpServerVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} cfgV8 :: ServerConfig -cfgV8 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} +cfgV8 = cfg {smpServerVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} cfgVPrev :: ServerConfig cfgVPrev = cfg {smpServerVRange = prevRange $ smpServerVRange cfg} @@ -185,13 +185,13 @@ proxyCfg :: ServerConfig proxyCfg = cfg { allowSMPProxy = True, - smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True}} + smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}} } where smpAgentCfg' = smpAgentCfg cfg proxyVRangeV8 :: VersionRangeSMP -proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion +proxyVRangeV8 = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn = (`withSmpServerStoreMsgLogOnMS` AMSType SMSJournal) diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index cbdc7a3f5..61b7c1670 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -162,12 +162,12 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do g <- C.newRandom -- set up proxy ts <- getCurrentTime - pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ()) + pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- set up relay msgQ <- newTBQueueIO 1024 - rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) ts (\_ -> pure ()) + rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion} (Just msgQ) ts (\_ -> pure ()) rc <- either (fail . show) pure rc' -- prepare receiving queue (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g @@ -205,7 +205,7 @@ proxyConnectDeadRelay n d proxyServ = do g <- C.newRandom -- set up proxy ts <- getCurrentTime - pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ()) + pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- get proxy session diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 9cde80286..088a7b977 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -851,7 +851,7 @@ testTiming = describe "should have similar time for auth error, whether queue exists or not, for all key types" $ forM_ timingTests $ \tst -> it (testName tst) $ \(ATransport t, msType) -> - smpTest2Cfg (cfgMS msType) (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> + smpTest2Cfg (cfgMS msType) (mkVersionRange minServerSMPRelayVersion authCmdsSMPVersion) t $ \rh sh -> testSameTiming rh sh tst where testName :: (C.AuthAlg, C.AuthAlg, Int) -> String From 298666380f598d32d709f963153acbb50d51afac Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 20 Jan 2025 16:32:42 +0000 Subject: [PATCH 17/51] servers: handle accept error ECONNABORTED (#1437) --- src/Simplex/Messaging/Transport/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index c328dd6e5..1f0d82195 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -159,7 +159,7 @@ safeAccept sock = | otherwise -> logError err >> E.throwIO e where retryAccept = maybe False ((`elem` again) . Errno) errno - again = [eAGAIN, eNETDOWN, ePROTO, eNOPROTOOPT, eHOSTDOWN, eNONET, eHOSTUNREACH, eOPNOTSUPP, eNETUNREACH] + again = [eCONNABORTED, eAGAIN, eNETDOWN, ePROTO, eNOPROTOOPT, eHOSTDOWN, eNONET, eHOSTUNREACH, eOPNOTSUPP, eNETUNREACH] err = "socket accept error: " <> tshow e <> maybe "" ((", errno=" <>) . tshow) errno errno = ioe_errno e From 23189753751dc52046865ce2d992335495020e91 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 20 Jan 2025 16:38:14 +0000 Subject: [PATCH 18/51] 6.3.0.2 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 82f9f3883..32c194be1 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.1 +version: 6.3.0.2 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From eda9e36c826f8e9f9d984e4d25612e7a6abddace Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 24 Jan 2025 10:31:50 +0000 Subject: [PATCH 19/51] agent: track queries (#1439) --- src/Simplex/Messaging/Agent/Store/SQLite.hs | 25 +++++---- .../Messaging/Agent/Store/SQLite/DB.hs | 56 +++++++++++-------- tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/AgentTests/MigrationTests.hs | 3 +- tests/AgentTests/SQLiteTests.hs | 4 +- tests/AgentTests/SchemaDump.hs | 13 +++-- 6 files changed, 59 insertions(+), 44 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 585f40a0c..e472db488 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -69,32 +69,33 @@ data DBOpts = DBOpts { dbFilePath :: FilePath, dbKey :: ScrubbedBytes, keepKey :: Bool, - vacuum :: Bool + vacuum :: Bool, + track :: DB.TrackQueries } createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createDBStore DBOpts {dbFilePath, dbKey, keepKey, vacuum} migrations confirmMigrations = do +createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do let dbDir = takeDirectory dbFilePath createDirectoryIfMissing True dbDir - st <- connectSQLiteStore dbFilePath dbKey keepKey + st <- connectSQLiteStore dbFilePath dbKey keepKey track r <- migrateSchema st migrations confirmMigrations vacuum `onException` closeDBStore st case r of Right () -> pure $ Right st Left e -> closeDBStore st $> Left e -connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> IO DBStore -connectSQLiteStore dbFilePath key keepKey = do +connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> DB.TrackQueries -> IO DBStore +connectSQLiteStore dbFilePath key keepKey track = do dbNew <- not <$> doesFileExist dbFilePath - dbConn <- dbBusyLoop (connectDB dbFilePath key) + dbConn <- dbBusyLoop (connectDB dbFilePath key track) dbConnection <- newMVar dbConn dbKey <- newTVarIO $! storeKey key keepKey dbClosed <- newTVarIO False dbSem <- newTVarIO 0 pure DBStore {dbFilePath, dbKey, dbSem, dbConnection, dbNew, dbClosed} -connectDB :: FilePath -> ScrubbedBytes -> IO DB.Connection -connectDB path key = do - db <- DB.open path +connectDB :: FilePath -> ScrubbedBytes -> DB.TrackQueries -> IO DB.Connection +connectDB path key track = do + db <- DB.open path track prepare db `onException` DB.close db -- _printPragmas db path pure db @@ -127,12 +128,12 @@ openSQLiteStore_ DBStore {dbConnection, dbFilePath, dbKey, dbClosed} key keepKey bracketOnError (takeMVar dbConnection) (tryPutMVar dbConnection) - $ \DB.Connection {slow} -> do - DB.Connection {conn} <- connectDB dbFilePath key + $ \DB.Connection {slow, track} -> do + DB.Connection {conn} <- connectDB dbFilePath key track atomically $ do writeTVar dbClosed False writeTVar dbKey $! storeKey key keepKey - putMVar dbConnection DB.Connection {conn, slow} + putMVar dbConnection DB.Connection {conn, slow, track} reopenDBStore :: DBStore -> IO () reopenDBStore st@DBStore {dbKey, dbClosed} = diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 7e8406d5c..6cf37fbda 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -11,6 +11,7 @@ module Simplex.Messaging.Agent.Store.SQLite.DB Binary (..), Connection (..), SlowQueryStats (..), + TrackQueries (..), open, close, execute, @@ -38,7 +39,7 @@ import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (diffToMilliseconds, tshow) +import Simplex.Messaging.Util (diffToMicroseconds, tshow) newtype BoolInt = BI {unBI :: Bool} deriving newtype (FromField, ToField) @@ -48,9 +49,13 @@ newtype Binary = Binary {fromBinary :: ByteString} data Connection = Connection { conn :: SQL.Connection, + track :: TrackQueries, slow :: TMap Query SlowQueryStats } +data TrackQueries = TQAll | TQSlow Int64 | TQOff + deriving (Eq) + data SlowQueryStats = SlowQueryStats { count :: Int64, timeMax :: Int64, @@ -59,22 +64,29 @@ data SlowQueryStats = SlowQueryStats } deriving (Show) -timeIt :: TMap Query SlowQueryStats -> Query -> IO a -> IO a -timeIt slow sql a = do - t <- getCurrentTime - r <- - a `catch` \e -> do - atomically $ TM.alter (Just . updateQueryErrors e) sql slow - throwIO e - t' <- getCurrentTime - let diff = diffToMilliseconds $ diffUTCTime t' t - when (diff > 1) $ atomically $ TM.alter (updateQueryStats diff) sql slow - pure r +timeIt :: Connection -> Query -> IO a -> IO a +timeIt Connection {slow, track} sql a + | track == TQOff = makeQuery + | otherwise = do + t <- getCurrentTime + r <- makeQuery + t' <- getCurrentTime + let diff = diffToMicroseconds $ diffUTCTime t' t + when (trackQuery diff) $ atomically $ TM.alter (updateQueryStats diff) sql slow + pure r where + makeQuery = + a `catch` \e -> do + atomically $ TM.alter (Just . updateQueryErrors e) sql slow + throwIO e + trackQuery diff = case track of + TQOff -> False + TQSlow t -> diff > t + TQAll -> True updateQueryErrors :: SomeException -> Maybe SlowQueryStats -> SlowQueryStats updateQueryErrors e Nothing = SlowQueryStats 0 0 0 $ M.singleton (tshow e) 1 - updateQueryErrors e (Just stats@SlowQueryStats {errs}) = - stats {errs = M.alter (Just . maybe 1 (+ 1)) (tshow e) errs} + updateQueryErrors e (Just st@SlowQueryStats {errs}) = + st {errs = M.alter (Just . maybe 1 (+ 1)) (tshow e) errs} updateQueryStats :: Int64 -> Maybe SlowQueryStats -> Maybe SlowQueryStats updateQueryStats diff Nothing = Just $ SlowQueryStats 1 diff diff M.empty updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg, errs}) = @@ -86,33 +98,33 @@ timeIt slow sql a = do errs } -open :: String -> IO Connection -open f = do +open :: String -> TrackQueries -> IO Connection +open f track = do conn <- SQL.open f slow <- TM.emptyIO - pure Connection {conn, slow} + pure Connection {conn, slow, track} close :: Connection -> IO () close = SQL.close . conn execute :: ToRow q => Connection -> Query -> q -> IO () -execute Connection {conn, slow} sql = timeIt slow sql . SQL.execute conn sql +execute c sql = timeIt c sql . SQL.execute (conn c) sql {-# INLINE execute #-} execute_ :: Connection -> Query -> IO () -execute_ Connection {conn, slow} sql = timeIt slow sql $ SQL.execute_ conn sql +execute_ c sql = timeIt c sql $ SQL.execute_ (conn c) sql {-# INLINE execute_ #-} executeMany :: ToRow q => Connection -> Query -> [q] -> IO () -executeMany Connection {conn, slow} sql = timeIt slow sql . SQL.executeMany conn sql +executeMany c sql = timeIt c sql . SQL.executeMany (conn c) sql {-# INLINE executeMany #-} query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] -query Connection {conn, slow} sql = timeIt slow sql . SQL.query conn sql +query c sql = timeIt c sql . SQL.query (conn c) sql {-# INLINE query #-} query_ :: FromRow r => Connection -> Query -> IO [r] -query_ Connection {conn, slow} sql = timeIt slow sql $ SQL.query_ conn sql +query_ c sql = timeIt c sql $ SQL.query_ (conn c) sql {-# INLINE query_ #-} $(J.deriveJSON defaultJSON ''SlowQueryStats) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 12bea5c90..9aa4feeca 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -3104,7 +3104,7 @@ insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") #else createStore :: String -> IO (Either MigrationError DBStore) -createStore dbPath = createAgentStore (DBOpts dbPath "" False True) MCError +createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) MCError insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)") diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index 5ad4f101d..1a879eca7 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/tests/AgentTests/MigrationTests.hs @@ -228,7 +228,8 @@ createStore randSuffix migrations confirmMigrations = do dbFilePath = testDB randSuffix, dbKey = "", keepKey = False, - vacuum = True + vacuum = True, + track = DB.TQOff } createDBStore dbOpts migrations confirmMigrations diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 84f30ff96..6950f3379 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -70,7 +70,7 @@ withStore2 = before connect2 . after (removeStore . fst) connect2 :: IO (DBStore, DBStore) connect2 = do s1@DBStore {dbFilePath} <- createStore' - s2 <- connectSQLiteStore dbFilePath "" False + s2 <- connectSQLiteStore dbFilePath "" False DB.TQOff pure (s1, s2) createStore' :: IO DBStore @@ -81,7 +81,7 @@ createEncryptedStore key keepKey = 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 - Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True) Migrations.app MCError + Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) Migrations.app MCError withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);") pure st diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 75e89d00e..b2ddbdbce 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -12,6 +12,7 @@ import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL import Simplex.Messaging.Agent.Store.SQLite import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') +import Simplex.Messaging.Agent.Store.SQLite.DB (TrackQueries (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import Simplex.Messaging.Util (ifM) @@ -49,7 +50,7 @@ testVerifySchemaDump :: IO () testVerifySchemaDump = do savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "") savedSchema `deepseq` pure () - void $ createDBStore (DBOpts testDB "" False True) Migrations.app MCConsole + void $ createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCConsole getSchema testDB appSchema `shouldReturn` savedSchema removeFile testDB @@ -57,7 +58,7 @@ testVerifyLintFKeyIndexes :: IO () testVerifyLintFKeyIndexes = do savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "") savedLint `deepseq` pure () - void $ createDBStore (DBOpts testDB "" False True) Migrations.app MCConsole + void $ createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCConsole getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint removeFile testDB @@ -70,7 +71,7 @@ withTmpFiles = testSchemaMigrations :: IO () testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app - Right st <- createDBStore (DBOpts testDB "" False True) noDownMigrations MCError + Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations MCError mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app closeDBStore st removeFile testDB @@ -93,7 +94,7 @@ testSchemaMigrations = do testUsersMigrationNew :: IO () testUsersMigrationNew = do - Right st <- createDBStore (DBOpts testDB "" False True) Migrations.app MCError + Right st <- createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCError withTransaction' st (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([] :: [Only Int]) closeDBStore st @@ -101,11 +102,11 @@ testUsersMigrationNew = do testUsersMigrationOld :: IO () testUsersMigrationOld = do let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app - Right st <- createDBStore (DBOpts testDB "" False True) beforeUsers MCError + Right st <- createDBStore (DBOpts testDB "" False True TQOff) beforeUsers MCError withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';") `shouldReturn` ([] :: [Only String]) closeDBStore st - Right st' <- createDBStore (DBOpts testDB "" False True) Migrations.app MCYesUp + Right st' <- createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCYesUp withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([Only (1 :: Int)]) closeDBStore st' From 817f5e17372c3b04772cd30d466be2b9c8c3ab11 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Fri, 24 Jan 2025 13:35:33 +0000 Subject: [PATCH 20/51] scripts/systemd: update services (#1440) --- scripts/main/smp-server.service | 9 +++++++++ scripts/main/xftp-server.service | 9 +++++++++ 2 files changed, 18 insertions(+) diff --git a/scripts/main/smp-server.service b/scripts/main/smp-server.service index 6d365041d..61c695217 100644 --- a/scripts/main/smp-server.service +++ b/scripts/main/smp-server.service @@ -5,12 +5,21 @@ Description=SMP server User=smp Group=smp Type=simple + ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS ExecStopPost=/usr/local/bin/simplex-servers-stopscript smp-server + LimitNOFILE=65535 KillSignal=SIGINT + TimeoutStartSec=infinity TimeoutStopSec=infinity + +Restart=on-failure +RestartSec=10s +StartLimitBurst=3 +StartLimitInterval=60s + AmbientCapabilities=CAP_NET_BIND_SERVICE [Install] diff --git a/scripts/main/xftp-server.service b/scripts/main/xftp-server.service index fcde29bf8..32229a47e 100644 --- a/scripts/main/xftp-server.service +++ b/scripts/main/xftp-server.service @@ -5,12 +5,21 @@ Description=XFTP server User=xftp Group=xftp Type=simple + ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS ExecStopPost=/usr/local/bin/simplex-servers-stopscript xftp-server + LimitNOFILE=65535 KillSignal=SIGINT + TimeoutStartSec=infinity TimeoutStopSec=infinity + +Restart=on-failure +RestartSec=10s +StartLimitBurst=3 +StartLimitInterval=60s + AmbientCapabilities=CAP_NET_BIND_SERVICE [Install] From b3c8358a43b7a15ba38e0a0385813172d47989c7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 25 Jan 2025 08:52:40 +0000 Subject: [PATCH 21/51] agent: combine connection deletion events (#1442) --- src/Simplex/Messaging/Agent.hs | 23 ++++++------ src/Simplex/Messaging/Agent/Protocol.hs | 25 +++++-------- tests/AgentTests/FunctionalAPITests.hs | 50 ++++++++++++------------- 3 files changed, 44 insertions(+), 54 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 709f129bd..2ff0d2ab2 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1805,8 +1805,8 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do -- ! if it was used to notify about the result, it might be necessary to differentiate -- ! between completed deletions of connections, and deletions delayed due to wait for delivery (see deleteConn) deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing - rs' <- lift $ catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) (M.keys delRs)) - forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN) + cIds_ <- lift $ L.nonEmpty . catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) (M.keys delRs)) + forM_ cIds_ $ \cIds -> notify ("", "", AEvt SAEConn $ DEL_CONNS cIds) pure (errs' <> delRs, rqs, connIds') where rcvQueues :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue] @@ -1826,32 +1826,33 @@ deleteConnQueues c waitDelivery ntf rqs = do rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs) let connIds = M.keys $ M.filter isRight rs deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing - rs' <- catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds) - forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN) + cIds_ <- L.nonEmpty . catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds) + forM_ cIds_ $ \cIds -> notify ("", "", AEvt SAEConn $ DEL_CONNS cIds) pure rs where deleteQueueRecs :: [(RcvQueue, Either AgentErrorType ())] -> AM' [(RcvQueue, Either AgentErrorType ())] deleteQueueRecs rs = do maxErrs <- asks $ deleteErrorCount . config - (rs', notifyActions) <- unzip . rights <$> withStoreBatch' c (\db -> map (deleteQueueRec db maxErrs) rs) - mapM_ sequence_ notifyActions - pure rs' + rs' <- rights <$> withStoreBatch' c (\db -> map (deleteQueueRec db maxErrs) rs) + let delQ ((rq, _), err_) = (qConnId rq,qServer rq,queueId rq,) <$> err_ + delQs_ = L.nonEmpty $ mapMaybe delQ rs' + forM_ delQs_ $ \delQs -> notify ("", "", AEvt SAEConn $ DEL_RCVQS delQs) + pure $ map fst rs' where deleteQueueRec :: DB.Connection -> Int -> (RcvQueue, Either AgentErrorType ()) -> - IO ((RcvQueue, Either AgentErrorType ()), Maybe (AM' ())) + IO ((RcvQueue, Either AgentErrorType ()), Maybe (Maybe AgentErrorType)) -- Nothing - no event, Just Nothing - no error deleteQueueRec db maxErrs (rq@RcvQueue {userId, server}, r) = case r of - Right _ -> deleteConnRcvQueue db rq $> ((rq, r), Just (notifyRQ rq Nothing)) + Right _ -> deleteConnRcvQueue db rq $> ((rq, r), Just Nothing) Left e | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> incRcvDeleteErrors db rq $> ((rq, r), Nothing) | otherwise -> do deleteConnRcvQueue db rq -- attempts and successes are counted in deleteQueues function atomically $ incSMPServerStat c userId server connDeleted - pure ((rq, Right ()), Just (notifyRQ rq (Just e))) - notifyRQ rq e_ = notify ("", qConnId rq, AEvt SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_) + pure ((rq, Right ()), Just (Just e)) notify = when ntf . atomically . writeTBQueue (subQ c) connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index b87f87f18..44128b4c4 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -168,12 +167,13 @@ import Data.Time.Clock.System (SystemTime) import Data.Type.Equality import Data.Typeable () import Data.Word (Word16, Word32) +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Transport (XFTPErrorType) import Simplex.FileTransfer.Types (FileErrorType) import Simplex.Messaging.Agent.QueryString -import Simplex.Messaging.Agent.Store.DB (Binary (..)) import Simplex.Messaging.Client (ProxyClientError) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet @@ -224,13 +224,6 @@ import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import Simplex.RemoteControl.Types import UnliftIO.Exception (Exception) -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif -- SMP agent protocol version history: -- 1 - binary protocol encoding (1/1/2022) @@ -366,8 +359,8 @@ data AEvent (e :: AEntity) where MSGNTF :: MsgId -> Maybe UTCTime -> AEvent AEConn RCVD :: MsgMeta -> NonEmpty MsgReceipt -> AEvent AEConn QCONT :: AEvent AEConn - DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> AEvent AEConn - DEL_CONN :: AEvent AEConn + DEL_RCVQS :: NonEmpty (ConnId, SMPServer, SMP.RecipientId, Maybe AgentErrorType) -> AEvent AEConn + DEL_CONNS :: NonEmpty ConnId -> AEvent AEConn DEL_USER :: Int64 -> AEvent AENone STAT :: ConnectionStats -> AEvent AEConn OK :: AEvent AEConn @@ -437,8 +430,8 @@ data AEventTag (e :: AEntity) where MSGNTF_ :: AEventTag AEConn RCVD_ :: AEventTag AEConn QCONT_ :: AEventTag AEConn - DEL_RCVQ_ :: AEventTag AEConn - DEL_CONN_ :: AEventTag AEConn + DEL_RCVQS_ :: AEventTag AEConn + DEL_CONNS_ :: AEventTag AEConn DEL_USER_ :: AEventTag AENone STAT_ :: AEventTag AEConn OK_ :: AEventTag AEConn @@ -492,8 +485,8 @@ aEventTag = \case MSGNTF {} -> MSGNTF_ RCVD {} -> RCVD_ QCONT -> QCONT_ - DEL_RCVQ {} -> DEL_RCVQ_ - DEL_CONN -> DEL_CONN_ + DEL_RCVQS _ -> DEL_RCVQS_ + DEL_CONNS _ -> DEL_CONNS_ DEL_USER _ -> DEL_USER_ STAT _ -> STAT_ OK -> OK_ @@ -651,7 +644,7 @@ instance ToJSON NotificationsMode where instance FromJSON NotificationsMode where parseJSON = strParseJSON "NotificationsMode" -instance ToField NotificationsMode where toField = toField . Binary . strEncode +instance ToField NotificationsMode where toField = toField . strEncode instance FromField NotificationsMode where fromField = blobFieldDecoder $ parseAll strP diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 9aa4feeca..1f7d9f1cc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -2055,8 +2055,8 @@ testAsyncCommands sqSecured alice bob baseId = ackMessageAsync alice "7" bobId (baseId + 4) Nothing get alice =##> \case ("7", _, OK) -> True; _ -> False deleteConnectionAsync alice False bobId - get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False - get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False + get alice =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing)]) -> c == bobId; _ -> False + get alice =##> \case ("", "", DEL_CONNS [c]) -> c == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" where msgId = subtract baseId @@ -2123,12 +2123,9 @@ testDeleteConnectionAsync t = runRight_ $ do deleteConnectionsAsync a False connIds nGet a =##> \case ("", "", DOWN {}) -> True; _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + let delOk = \case (c, _, _, Just (BROKER _ e)) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", "", DEL_RCVQS rs) -> length rs == 3 && all delOk rs; _ -> False + get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" testWaitDeliveryNoPending :: ATransport -> IO () @@ -2147,8 +2144,8 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> ackMessage alice bobId (baseId + 2) Nothing deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == bobId; _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Nothing)]) -> cId == bobId; _ -> False + get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False 3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2" get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 3); _ -> False @@ -2184,14 +2181,14 @@ testWaitDelivery t = 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do get alice ##> ("", bobId, SENT $ baseId + 3) get alice ##> ("", bobId, SENT $ baseId + 4) - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False liftIO $ getInAnyOrder @@ -2231,8 +2228,8 @@ testWaitDeliveryAUTHErr t = ackMessage alice bobId (baseId + 2) Nothing deleteConnectionsAsync bob False [aliceId] - get bob =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == aliceId; _ -> False - get bob =##> \case ("", cId, DEL_CONN) -> cId == aliceId; _ -> False + get bob =##> \case ("", "", DEL_RCVQS [(cId, _, _, Nothing)]) -> cId == aliceId; _ -> False + get bob =##> \case ("", "", DEL_CONNS [cId]) -> cId == aliceId; _ -> False pure (aliceId, bobId) @@ -2241,14 +2238,14 @@ testWaitDeliveryAUTHErr t = 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" withSmpServerStoreLogOn t testPort $ \_ -> do get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 3); _ -> False get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 4); _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" @@ -2281,8 +2278,8 @@ testWaitDeliveryTimeout t = 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" @@ -2321,8 +2318,8 @@ testWaitDeliveryTimeout2 t = 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" @@ -2430,8 +2427,8 @@ testUsers = (aId', bId') <- makeConnectionForUsers a auId b 1 exchangeGreetings a bId' b aId' deleteUser a auId True - get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False + get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing)]) -> c == bId'; _ -> False + get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" @@ -2462,8 +2459,8 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do nGet b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False runRight_ $ do deleteUser a auId True - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False + get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Just (BROKER _ e))]) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do @@ -2581,9 +2578,8 @@ testSwitchDelete servers = liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted] phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing] deleteConnectionAsync a False bId - get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False + get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing), (c', _, _, Nothing)]) -> c == bId && c' == bId; _ -> False + get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO () From e78ab60c97cbf96e51b701576dcdbaa40056d551 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 28 Jan 2025 22:02:41 +0000 Subject: [PATCH 22/51] build: fix postgres (#1444) --- src/Simplex/FileTransfer/Description.hs | 10 +--------- src/Simplex/FileTransfer/Types.hs | 9 +-------- src/Simplex/Messaging/Agent/Protocol.hs | 3 +-- src/Simplex/Messaging/Agent/Stats.hs | 9 +-------- src/Simplex/Messaging/Agent/Store/AgentStore.hs | 6 +----- src/Simplex/Messaging/Agent/Store/DB.hs | 4 ++++ src/Simplex/Messaging/Agent/Store/Postgres/DB.hs | 10 ++++++---- src/Simplex/Messaging/Agent/Store/SQLite/DB.hs | 2 ++ src/Simplex/Messaging/Crypto.hs | 9 +-------- src/Simplex/Messaging/Crypto/Ratchet.hs | 9 +-------- src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs | 8 +------- src/Simplex/Messaging/Notifications/Protocol.hs | 9 +-------- src/Simplex/Messaging/Notifications/Types.hs | 10 +--------- src/Simplex/RemoteControl/Types.hs | 1 - 14 files changed, 22 insertions(+), 77 deletions(-) diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index 0c7c42ab4..cd2df9d33 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} @@ -71,20 +70,13 @@ import qualified Data.Yaml as Y import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Protocol import Simplex.Messaging.Agent.QueryString -import Simplex.Messaging.Agent.Store.DB (Binary (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, parseAll) import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>)) -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif data FileDescription (p :: FileParty) = FileDescription { party :: SFileParty p, diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index c18d31779..d80ff7c77 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -23,13 +22,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol (XFTPServer) import System.FilePath (()) -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) type RcvFileId = ByteString -- Agent entity ID diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 44128b4c4..c5219ab22 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -167,8 +167,7 @@ import Data.Time.Clock.System (SystemTime) import Data.Type.Equality import Data.Typeable () import Data.Word (Word16, Word32) -import Database.SQLite.Simple.FromField -import Database.SQLite.Simple.ToField +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Transport (XFTPErrorType) diff --git a/src/Simplex/Messaging/Agent/Stats.hs b/src/Simplex/Messaging/Agent/Stats.hs index 1d174622e..020c6a89c 100644 --- a/src/Simplex/Messaging/Agent/Stats.hs +++ b/src/Simplex/Messaging/Agent/Stats.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} @@ -12,17 +11,11 @@ import Data.Int (Int64) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Simplex.Messaging.Agent.Protocol (UserId) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) import Simplex.Messaging.Parsers (defaultJSON, fromTextField_) import Simplex.Messaging.Protocol (NtfServer, SMPServer, XFTPServer) import Simplex.Messaging.Util (decodeJSON, encodeJSON) import UnliftIO.STM -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif data AgentSMPServerStats = AgentSMPServerStats { sentDirect :: TVar Int, -- successfully sent messages diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 5dcda9c79..46a358745 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -262,7 +262,7 @@ import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.Common import qualified Simplex.Messaging.Agent.Store.DB as DB -import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys) @@ -281,16 +281,12 @@ import qualified UnliftIO.Exception as E import UnliftIO.STM #if defined(dbPostgres) import Database.PostgreSQL.Simple (Only (..), Query, SqlError, (:.) (..)) -import Database.PostgreSQL.Simple.FromField (FromField (..)) import Database.PostgreSQL.Simple.Errors (constraintViolation) import Database.PostgreSQL.Simple.SqlQQ (sql) -import Database.PostgreSQL.Simple.ToField (ToField (..)) #else import Database.SQLite.Simple (FromRow (..), Only (..), Query (..), SQLError, ToRow (..), field, (:.) (..)) import qualified Database.SQLite.Simple as SQL -import Database.SQLite.Simple.FromField import Database.SQLite.Simple.QQ (sql) -import Database.SQLite.Simple.ToField (ToField (..)) #endif checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a) diff --git a/src/Simplex/Messaging/Agent/Store/DB.hs b/src/Simplex/Messaging/Agent/Store/DB.hs index f8c54e463..ade1f7e6d 100644 --- a/src/Simplex/Messaging/Agent/Store/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/DB.hs @@ -3,11 +3,15 @@ module Simplex.Messaging.Agent.Store.DB #if defined(dbPostgres) ( module Simplex.Messaging.Agent.Store.Postgres.DB, + FromField (..), + ToField (..), ) where import Simplex.Messaging.Agent.Store.Postgres.DB #else ( module Simplex.Messaging.Agent.Store.SQLite.DB, + FromField (..), + ToField (..), ) where import Simplex.Messaging.Agent.Store.SQLite.DB diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs index 9e597aef7..88b37f65a 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs @@ -4,6 +4,8 @@ module Simplex.Messaging.Agent.Store.Postgres.DB ( BoolInt (..), PSQL.Binary (..), PSQL.Connection, + FromField (..), + ToField (..), PSQL.connect, PSQL.close, execute, @@ -49,15 +51,15 @@ executeMany db q qs = void $ PSQL.executeMany db q qs -- used in FileSize instance FromField Word32 where fromField field dat = do - i <- fromField field dat - if i >= (0 :: Int64) + i :: Int64 <- fromField field dat + if i >= 0 && i <= fromIntegral (maxBound :: Word32) then pure (fromIntegral i :: Word32) else returnError ConversionFailed field "Negative value can't be converted to Word32" -- used in Version instance FromField Word16 where fromField field dat = do - i <- fromField field dat - if i >= (0 :: Int32) + i :: Int64 <- fromField field dat + if i >= 0 && i <= fromIntegral (maxBound :: Word16) then pure (fromIntegral i :: Word16) else returnError ConversionFailed field "Negative value can't be converted to Word16" diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs index 6cf37fbda..59c282c46 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/DB.hs @@ -12,6 +12,8 @@ module Simplex.Messaging.Agent.Store.SQLite.DB Connection (..), SlowQueryStats (..), TrackQueries (..), + FromField (..), + ToField (..), open, close, execute, diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index a955d0d8a..ef3548953 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -238,18 +238,11 @@ import Data.X509 import Data.X509.Validation (Fingerprint (..), getFingerprint) import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+)) import Network.Transport.Internal (decodeWord16, encodeWord16) -import Simplex.Messaging.Agent.Store.DB (Binary (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString) import Simplex.Messaging.Util ((<$?>)) -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif -- | Cryptographic algorithms. data Algorithm = Ed25519 | Ed448 | X25519 | X448 diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 310893de5..0ee4c75d0 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -111,7 +111,7 @@ import Data.Type.Equality import Data.Typeable (Typeable) import Data.Word (Word16, Word32) import Simplex.Messaging.Agent.QueryString -import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..)) import Simplex.Messaging.Crypto import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding @@ -121,13 +121,6 @@ import Simplex.Messaging.Util (($>>=), (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import UnliftIO.STM -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif -- e2e encryption headers version history: -- 1 - binary protocol encoding (1/1/2022) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs index 35e46e3de..82483491e 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -11,18 +11,12 @@ import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import Foreign (nullPtr) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.ToField -#else -import Database.SQLite.Simple.FromField -import Database.SQLite.Simple.ToField -#endif newtype KEMPublicKey = KEMPublicKey ByteString deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 96f8b337e..642465883 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -29,6 +28,7 @@ import Data.Time.Clock.System import Data.Type.Equality import Data.Word (Word16) import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts) +import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -36,13 +36,6 @@ import Simplex.Messaging.Notifications.Transport (NTFVersion, ntfClientHandshake import Simplex.Messaging.Parsers (fromTextField_) import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..)) import Simplex.Messaging.Util (eitherToMaybe, (<$?>)) -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif data NtfEntity = Token | Subscription deriving (Show) diff --git a/src/Simplex/Messaging/Notifications/Types.hs b/src/Simplex/Messaging/Notifications/Types.hs index dd6e99733..3daf97970 100644 --- a/src/Simplex/Messaging/Notifications/Types.hs +++ b/src/Simplex/Messaging/Notifications/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} @@ -11,19 +10,12 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time (UTCTime) import Simplex.Messaging.Agent.Protocol (ConnId, NotificationsMode (..), UserId) -import Simplex.Messaging.Agent.Store.DB (Binary (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Parsers (blobFieldDecoder, fromTextField_) import Simplex.Messaging.Protocol (NotifierId, NtfServer, SMPServer) -#if defined(dbPostgres) -import Database.PostgreSQL.Simple.FromField (FromField (..)) -import Database.PostgreSQL.Simple.ToField (ToField (..)) -#else -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) -#endif data NtfTknAction = NTARegister diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 666878c30..bc191824a 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} From ae41717b9b4323295b5dc7e6157f80acd7c63f28 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 28 Jan 2025 22:04:46 +0000 Subject: [PATCH 23/51] smp server: use origin client version when processing proxied command, fixes old client sending to new server (#1443) * smp server: pass origin client version when processing proxied command, fixes old client sending to new server * version * version --- src/Simplex/Messaging/Server.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index d31a50e34..a097da37a 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1156,9 +1156,10 @@ client ms clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" + let THandleParams {thVersion} = thParams' forever $ atomically (readTBQueue rcvQ) - >>= mapM processCommand + >>= mapM (processCommand thVersion) >>= mapM_ reply . L.nonEmpty . catMaybes . L.toList where reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m () @@ -1243,8 +1244,8 @@ client mkIncProxyStats ps psOwn own sel = do incStat $ sel ps when own $ incStat $ sel psOwn - processCommand :: (Maybe (StoreQueue s, QueueRec), Transmission Cmd) -> M (Maybe (Transmission BrokerMsg)) - processCommand (q_, (corrId, entId, cmd)) = case cmd of + processCommand :: VersionSMP -> (Maybe (StoreQueue s, QueueRec), Transmission Cmd) -> M (Maybe (Transmission BrokerMsg)) + processCommand clntVersion (q_, (corrId, entId, cmd)) = case cmd of Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command) Cmd SSender command -> Just <$> case command of SKEY sKey -> @@ -1506,7 +1507,7 @@ client sendMessage :: MsgFlags -> MsgBody -> StoreQueue s -> QueueRec -> M (Transmission BrokerMsg) sendMessage msgFlags msgBody q qr - | B.length msgBody > maxMessageLength thVersion = do + | B.length msgBody > maxMessageLength clntVersion = do stats <- asks serverStats incStat $ msgSentLarge stats pure $ err LARGE_MSG @@ -1545,7 +1546,6 @@ client liftIO $ updatePeriodStats (activeQueues stats) (recipientId qr) pure ok where - THandleParams {thVersion} = thParams' mkMessage :: MsgId -> C.MaxLenBS MaxMessageLen -> IO Message mkMessage msgId body = do msgTs <- getSystemTime @@ -1654,7 +1654,7 @@ client Left r -> pure r -- rejectOrVerify filters allowed commands, no need to repeat it here. -- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types). - Right t''@(_, (corrId', entId', _)) -> fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'') + Right t''@(_, (corrId', entId', _)) -> fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand fwdVersion t'') -- encode response r' <- case batchTransmissions (batch clntTHParams) (blockSize clntTHParams) [Right (Nothing, encodeTransmission clntTHParams r)] of [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right From efe71cd598ab065072b107489d549843621ba302 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Thu, 30 Jan 2025 09:22:13 +0000 Subject: [PATCH 24/51] docker: refactor (#1438) * docker: refactor * github/docker: bump actions and adjust smp ports --- .github/workflows/docker-image.yml | 12 +-- Dockerfile | 39 ++++++-- .../docker/docker-compose-smp-complete.yml | 67 ++++++++++++++ scripts/docker/docker-compose-smp-manual.yml | 15 +++ scripts/docker/docker-compose-smp.env | 11 +++ scripts/docker/docker-compose-xftp.env | 9 ++ scripts/docker/docker-compose-xftp.yml | 16 ++++ scripts/docker/entrypoint-smp-server | 85 ++++++++++++----- scripts/docker/entrypoint-xftp-server | 92 +++++++++++++------ scripts/main/simplex-servers-stopscript | 6 +- 10 files changed, 287 insertions(+), 65 deletions(-) create mode 100644 scripts/docker/docker-compose-smp-complete.yml create mode 100644 scripts/docker/docker-compose-smp-manual.yml create mode 100644 scripts/docker/docker-compose-smp.env create mode 100644 scripts/docker/docker-compose-xftp.env create mode 100644 scripts/docker/docker-compose-xftp.yml diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml index e1f4c87f1..efd74552f 100644 --- a/.github/workflows/docker-image.yml +++ b/.github/workflows/docker-image.yml @@ -14,22 +14,22 @@ jobs: matrix: include: - app: smp-server - app_port: 5223 + app_port: "443 5223" - app: xftp-server - app_port: 443 + app_port: 443 steps: - name: Clone project - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Log in to Docker Hub - uses: docker/login-action@v2 + uses: docker/login-action@v3 with: username: ${{ secrets.DOCKERHUB_USERNAME }} password: ${{ secrets.DOCKERHUB_PASSWORD }} - name: Extract metadata for Docker image id: meta - uses: docker/metadata-action@v4 + uses: docker/metadata-action@v5 with: images: ${{ secrets.DOCKERHUB_USERNAME }}/${{ matrix.app }} flavor: | @@ -40,7 +40,7 @@ jobs: type=semver,pattern=v{{major}} - name: Build and push Docker image - uses: docker/build-push-action@v4 + uses: docker/build-push-action@v6 with: push: true build-args: | diff --git a/Dockerfile b/Dockerfile index e81db17c3..06b59e6e1 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,15 +1,20 @@ -ARG TAG=22.04 +# syntax=docker/dockerfile:1.7.0-labs +ARG TAG=24.04 FROM ubuntu:${TAG} AS build ### Build stage # Install curl and git and simplexmq dependencies -RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev llvm-12 llvm-12-dev libnuma-dev libssl-dev +RUN apt-get update && apt-get install -y curl git build-essential libgmp3-dev zlib1g-dev llvm-18 llvm-18-dev libnuma-dev libssl-dev # Specify bootstrap Haskell versions ENV BOOTSTRAP_HASKELL_GHC_VERSION=9.6.3 -ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.10.1.0 +ENV BOOTSTRAP_HASKELL_CABAL_VERSION=3.12.1.0 + +# Do not install Stack +ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK=true +ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK_HOOK=true # Install ghcup RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 sh @@ -21,26 +26,42 @@ ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH" RUN ghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}" && \ ghcup set cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}" -COPY . /project +# Copy only the source code +COPY apps /project/apps/ +COPY cbits /project/cbits/ +COPY src /project/src/ + +COPY cabal.project Setup.hs simplexmq.cabal LICENSE /project + WORKDIR /project +# Debug +#ARG CACHEBUST=1 + +#ADD --chmod=755 https://github.com/MShekow/directory-checksum/releases/download/v1.4.6/directory-checksum_1.4.6_linux_amd64 /usr/local/bin/directory-checksum +#RUN directory-checksum --max-depth 2 . + +# Set build arguments and check if they exist ARG APP -ARG APP_PORT -RUN if [ -z "$APP" ] || [ -z "$APP_PORT" ]; then printf "Please spcify \$APP and \$APP_PORT build-arg.\n"; exit 1; fi +RUN if [ -z "$APP" ]; then printf "Please spcify \$APP build-arg.\n"; exit 1; fi # Compile app RUN cabal update RUN cabal build exe:$APP +# Copy scripts +COPY scripts /project/scripts/ + # Create new path containing all files needed RUN mkdir /final WORKDIR /final # Strip the binary from debug symbols to reduce size -RUN bin=$(find /project/dist-newstyle -name "$APP" -type f -executable) && \ +RUN bin="$(find /project/dist-newstyle -name "$APP" -type f -executable)" && \ mv "$bin" ./ && \ strip ./"$APP" &&\ - mv /project/scripts/docker/entrypoint-"$APP" ./entrypoint + mv /project/scripts/docker/entrypoint-"$APP" ./entrypoint &&\ + mv /project/scripts/main/simplex-servers-stopscript ./simplex-servers-stopscript ### Final stage FROM ubuntu:${TAG} @@ -53,6 +74,8 @@ COPY --from=build /final /usr/local/bin/ # Open app listening port ARG APP_PORT +RUN if [ -z "$APP_PORT" ]; then printf "Please spcify \$APP_PORT build-arg.\n"; exit 1; fi + EXPOSE $APP_PORT # simplexmq requires using SIGINT to correctly preserve undelivered messages and restore them on restart diff --git a/scripts/docker/docker-compose-smp-complete.yml b/scripts/docker/docker-compose-smp-complete.yml new file mode 100644 index 000000000..be871983a --- /dev/null +++ b/scripts/docker/docker-compose-smp-complete.yml @@ -0,0 +1,67 @@ +name: SimpleX Chat - smp-server + +services: + oneshot: + image: ubuntu:latest + environment: + CADDYCONF: | + ${CADDY_OPTS:-} + + http://{$$ADDR} { + redir https://{$$ADDR}{uri} permanent + } + + {$$ADDR}:8443 { + tls { + key_type rsa4096 + } + } + command: sh -c 'if [ ! -f /etc/caddy/Caddyfile ]; then printf "$${CADDYCONF}" > /etc/caddy/Caddyfile; fi' + volumes: + - ./caddy_conf:/etc/caddy + + caddy: + image: caddy:latest + depends_on: + oneshot: + condition: service_completed_successfully + cap_add: + - NET_ADMIN + environment: + ADDR: ${ADDR?"Please specify the domain."} + volumes: + - ./caddy_conf:/etc/caddy + - caddy_data:/data + - caddy_config:/config + ports: + - 80:80 + restart: unless-stopped + healthcheck: + test: "test -d /data/caddy/certificates/${CERT_PATH:-acme-v02.api.letsencrypt.org-directory}/${ADDR} || exit 1" + interval: 1s + retries: 60 + + smp-server: + image: ${SIMPLEX_IMAGE:-simplexchat/smp-server:latest} + depends_on: + caddy: + condition: service_healthy + environment: + ADDR: ${ADDR?"Please specify the domain."} + PASS: ${PASS:-} + volumes: + - ./smp_configs:/etc/opt/simplex + - ./smp_state:/var/opt/simplex + - type: volume + source: caddy_data + target: /certificates + volume: + subpath: "caddy/certificates/${CERT_PATH:-acme-v02.api.letsencrypt.org-directory}/${ADDR}" + ports: + - 443:443 + - 5223:5223 + restart: unless-stopped + +volumes: + caddy_data: + caddy_config: diff --git a/scripts/docker/docker-compose-smp-manual.yml b/scripts/docker/docker-compose-smp-manual.yml new file mode 100644 index 000000000..391219b15 --- /dev/null +++ b/scripts/docker/docker-compose-smp-manual.yml @@ -0,0 +1,15 @@ +name: SimpleX Chat - smp-server + +services: + smp-server: + image: ${SIMPLEX_IMAGE:-simplexchat/smp-server:latest} + environment: + WEB_MANUAL: ${WEB_MANUAL:-1} + ADDR: ${ADDR?"Please specify the domain."} + PASS: ${PASS:-} + volumes: + - ./smp_configs:/etc/opt/simplex + - ./smp_state:/var/opt/simplex + ports: + - 5223:5223 + restart: unless-stopped diff --git a/scripts/docker/docker-compose-smp.env b/scripts/docker/docker-compose-smp.env new file mode 100644 index 000000000..17c51cf9a --- /dev/null +++ b/scripts/docker/docker-compose-smp.env @@ -0,0 +1,11 @@ +# Mandatory +ADDR=your_ip_or_addr + +# Optional +#PASS='123123' +#WEB_MANUAL=1 + +# Debug +#SIMPLEX_SMP_IMAGE=smp-server-dev +#CERT_PATH=acme-staging-v02.api.letsencrypt.org-directory +#CADDY_OPTS='{\n acme_ca https://acme-staging-v02.api.letsencrypt.org/directory\n}' diff --git a/scripts/docker/docker-compose-xftp.env b/scripts/docker/docker-compose-xftp.env new file mode 100644 index 000000000..425b769a3 --- /dev/null +++ b/scripts/docker/docker-compose-xftp.env @@ -0,0 +1,9 @@ +# Mandatory +ADDR=your_ip_or_addr +QUOTA=120gb + +# Optional +#PASS='123123' + +# Debug +#SIMPLEX_XFTP_IMAGE=xftp-server-dev diff --git a/scripts/docker/docker-compose-xftp.yml b/scripts/docker/docker-compose-xftp.yml new file mode 100644 index 000000000..0686412f3 --- /dev/null +++ b/scripts/docker/docker-compose-xftp.yml @@ -0,0 +1,16 @@ +name: SimpleX Chat - xftp-server + +services: + xftp-server: + image: ${SIMPLEX_XFTP_IMAGE:-simplexchat/xftp-server:latest} + environment: + ADDR: ${ADDR?"Please specify the domain."} + QUOTA: ${QUOTA?"Please specify disk quota."} + PASS: ${PASS:-} + volumes: + - ./xftp_configs:/etc/opt/simplex-xftp + - ./xftp_state:/var/opt/simplex-xftp + - ./xftp_files:/srv/xftp + ports: + - 443:443 + restart: unless-stopped diff --git a/scripts/docker/entrypoint-smp-server b/scripts/docker/entrypoint-smp-server index 5817b7b56..eeea3582d 100755 --- a/scripts/docker/entrypoint-smp-server +++ b/scripts/docker/entrypoint-smp-server @@ -1,48 +1,87 @@ #!/usr/bin/env sh +set -e + confd='/etc/opt/simplex' -logd='/var/opt/simplex/' +cert_path='/certificates' # Check if server has been initialized if [ ! -f "${confd}/smp-server.ini" ]; then # If not, determine ip or domain case "${ADDR}" in - '') printf 'Please specify $ADDR environment variable.\n'; exit 1 ;; + '') + printf 'Please specify $ADDR environment variable.\n' + exit 1 + ;; + + # Determine domain or IPv6 *[a-zA-Z]*) case "${ADDR}" in - *:*) set -- --ip "${ADDR}" ;; - *) set -- -n "${ADDR}" ;; + # IPv6 + *:*) + set -- --ip "${ADDR}" + ;; + + # Domain + *) + case "${ADDR}" in + # It's in domain format + *.*) + # Determine the base domain + ADDR_BASE="$(printf '%s' "$ADDR" | awk -F. '{print $(NF-1)"."$NF}')" + set -- --fqdn "${ADDR}" --own-domains="${ADDR_BASE}" + ;; + + # Incorrect domain + *) + printf 'Incorrect $ADDR environment variable. Please specify the correct one in format: smp1.example.org / example.org \n' + exit 1 + ;; + esac esac ;; - *) set -- --ip "${ADDR}" ;; + + # Assume everything else is IPv4 + *) + set -- --ip "${ADDR}" ;; esac # Optionally, set password case "${PASS}" in - '') set -- "$@" --no-password ;; - *) set -- "$@" --password "${PASS}" ;; + # Empty value = no password + '') + set -- "$@" --no-password + ;; + + # Assume that everything else is a password + *) + set -- "$@" --password "${PASS}" + ;; esac # And init certificates and configs - smp-server init -y -l "$@" + smp-server init --yes \ + --store-log \ + --daily-stats \ + --source-code \ + "$@" > /dev/null 2>&1 + + # Fix path to certificates + if [ -n "${WEB_MANUAL}" ]; then + sed -i -e 's|^[^#]*https: |#&|' \ + -e 's|^[^#]*cert: |#&|' \ + -e 's|^[^#]*key: |#&|' \ + -e 's|^port:.*|port: 5223|' \ + "${confd}/smp-server.ini" + else + sed -i -e "s|cert: /etc/opt/simplex/web.crt|cert: $cert_path/$ADDR.crt|" \ + -e "s|key: /etc/opt/simplex/web.key|key: $cert_path/$ADDR.key|" \ + "${confd}/smp-server.ini" + fi fi # Backup store log just in case -# -# Uses the UTC (universal) time zone and this -# format: YYYY-mm-dd'T'HH:MM:SS -# year, month, day, letter T, hour, minute, second -# -# This is the ISO 8601 format without the time zone at the end. -# -_file="${logd}/smp-server-store.log" -if [ -f "${_file}" ]; then - _backup_extension="$(date -u '+%Y-%m-%dT%H:%M:%S')" - cp -v -p "${_file}" "${_file}.${_backup_extension:-date-failed}" - unset -v _backup_extension -fi -unset -v _file +DOCKER=true /usr/local/bin/simplex-servers-stopscript smp-server # Finally, run smp-sever. Notice that "exec" here is important: # smp-server replaces our helper script, so that it can catch INT signal exec smp-server start +RTS -N -RTS - diff --git a/scripts/docker/entrypoint-xftp-server b/scripts/docker/entrypoint-xftp-server index 9e5bf5ac1..31d75362e 100755 --- a/scripts/docker/entrypoint-xftp-server +++ b/scripts/docker/entrypoint-xftp-server @@ -1,50 +1,90 @@ #!/usr/bin/env sh +set -eu + confd='/etc/opt/simplex-xftp' -logd='/var/opt/simplex-xftp' # Check if server has been initialized if [ ! -f "${confd}/file-server.ini" ]; then # If not, determine ip or domain case "${ADDR}" in - '') printf 'Please specify $ADDR environment variable.\n'; exit 1 ;; + '') + printf 'Please specify $ADDR environment variable.\n' + exit 1 + ;; + + # Determine domain or IPv6 *[a-zA-Z]*) case "${ADDR}" in - *:*) set -- --ip "${ADDR}" ;; - *) set -- -n "${ADDR}" ;; + # IPv6 + *:*) + set -- --ip "${ADDR}" + ;; + + # Domain + *) + case "${ADDR}" in + # Check if format is correct + *.*) + set -- --fqdn "${ADDR}" + ;; + + # Incorrect domain + *) + printf 'Incorrect $ADDR environment variable. Please specify the correct one in format: smp1.example.org / example.org \n' + exit 1 + ;; + esac + ;; esac ;; - *) set -- --ip "${ADDR}" ;; + + # Assume everything else is IPv4 + *) + set -- --ip "${ADDR}" + ;; esac - # Set quota + # Set global disk quota case "${QUOTA}" in - '') printf 'Please specify $QUOTA environment variable.\n'; exit 1 ;; - *GB) QUOTA="$(printf ${QUOTA} | tr '[:upper:]' '[:lower:]')"; set -- "$@" --quota "${QUOTA}" ;; - *gb) set -- "$@" --quota "${QUOTA}" ;; - *) printf 'Wrong format. Format should be: 1gb, 10gb, 100gb.\n'; exit 1 ;; + '') + printf 'Please specify $QUOTA environment variable.\n' + exit 1 + ;; + + # Incorrect format in uppercase, but automagically workaround this, replacing characters to lowercase + *GB) + QUOTA="$(printf '%s' "${QUOTA}" | tr '[:upper:]' '[:lower:]')" + set -- "$@" --quota "${QUOTA}" + ;; + + # Correct format + *gb) + set -- "$@" --quota "${QUOTA}" + ;; + + # Incorrect format + *) + printf 'Wrong format. Format should be: 1gb, 10gb, 100gb.\n' + exit 1 + ;; esac # Init the certificates and configs - xftp-server init -l -p /srv/xftp "$@" + xftp-server init --store-log \ + --path /srv/xftp \ + "$@" > /dev/null 2>&1 + + # Optionally, set password + if [ -n "${PASS}" ]; then + sed -i -e "/^# create_password:/a create_password: $PASS" \ + "${confd}/file-server.ini" + fi fi # Backup store log just in case -# -# Uses the UTC (universal) time zone and this -# format: YYYY-mm-dd'T'HH:MM:SS -# year, month, day, letter T, hour, minute, second -# -# This is the ISO 8601 format without the time zone at the end. -# -_file="${logd}/file-server-store.log" -if [ -f "${_file}" ]; then - _backup_extension="$(date -u '+%Y-%m-%dT%H:%M:%S')" - cp -v -p "${_file}" "${_file}.${_backup_extension:-date-failed}" - unset -v _backup_extension -fi -unset -v _file + +DOCKER=true /usr/local/bin/simplex-servers-stopscript xftp-server # Finally, run xftp-sever. Notice that "exec" here is important: # smp-server replaces our helper script, so that it can catch INT signal exec xftp-server start +RTS -N -RTS - diff --git a/scripts/main/simplex-servers-stopscript b/scripts/main/simplex-servers-stopscript index acfed3431..0b7003ead 100755 --- a/scripts/main/simplex-servers-stopscript +++ b/scripts/main/simplex-servers-stopscript @@ -148,8 +148,10 @@ xftp_cleanup() { main() { type="${1:-}" - - checks + + if [ -z "${DOCKER+x}" ]; then + checks + fi case "$type" in smp-server) From 45373e7f1f755ac3dfaa3f8efa03d8dc7b2d69ce Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 31 Jan 2025 13:01:03 +0000 Subject: [PATCH 25/51] 6.3.0.3 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 32c194be1..7bdc8add2 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.2 +version: 6.3.0.3 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From ce24f83b64565a0ef7f397ccd0e135a8a3983198 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 5 Feb 2025 12:04:27 +0000 Subject: [PATCH 26/51] refactor STM queues (#1447) --- src/Simplex/Messaging/Server.hs | 99 ++++++----- src/Simplex/Messaging/Server/Env/STM.hs | 4 +- .../Messaging/Server/MsgStore/Journal.hs | 92 +++++----- src/Simplex/Messaging/Server/MsgStore/STM.hs | 66 ++++--- .../Messaging/Server/MsgStore/Types.hs | 87 +++++----- src/Simplex/Messaging/Server/QueueStore.hs | 3 +- .../Messaging/Server/QueueStore/STM.hs | 129 +++++++------- src/Simplex/Messaging/Server/StoreLog.hs | 27 ++- tests/CoreTests/MsgStoreTests.hs | 161 +++++++++--------- tests/CoreTests/StoreLogTests.hs | 24 +-- 10 files changed, 341 insertions(+), 351 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index a097da37a..4fecc4bef 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -397,8 +397,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT atomicModifyIORef'_ (msgExpired stats) (+ expired) printMessageStats "STORE: messages" msgStats where - expireQueueMsgs now ms old rId q = fmap (fromRight newMessageStats) . runExceptT $ do - (expired_, stored) <- idleDeleteExpiredMsgs now ms rId q old + expireQueueMsgs now ms old q = fmap (fromRight newMessageStats) . runExceptT $ do + (expired_, stored) <- idleDeleteExpiredMsgs now ms q old pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1} expireNtfsThread :: ServerConfig -> M () @@ -429,8 +429,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, ntfCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats AMS _ st <- asks msgStore - let queues = activeMsgQueues st - notifiers = notifiers' st + let STMQueueStore {queues, notifiers} = stmQueueStore st interval = 1000000 * logInterval forever $ do withFile statsFilePath AppendMode $ \h -> liftIO $ do @@ -581,13 +580,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT rtm <- getRealTimeMetrics env T.writeFile metricsFile $ prometheusMetrics sm rtm ts - getServerMetrics :: STMQueueStore s => s -> ServerStats -> IO ServerMetrics + getServerMetrics :: STMStoreClass s => s -> ServerStats -> IO ServerMetrics getServerMetrics st ss = do d <- getServerStatsData ss let ps = periodStatDataCounts $ _activeQueues d psNtf = periodStatDataCounts $ _activeQueuesNtf d - queueCount <- M.size <$> readTVarIO (activeMsgQueues st) - notifierCount <- M.size <$> readTVarIO (notifiers' st) + STMQueueStore {queues, notifiers} = stmQueueStore st + queueCount <- M.size <$> readTVarIO queues + notifierCount <- M.size <$> readTVarIO notifiers pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, queueCount, notifierCount} getRealTimeMetrics :: Env -> IO RealTimeMetrics @@ -675,8 +675,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT CPStats -> withUserRole $ do ss <- unliftIO u $ asks serverStats AMS _ st <- unliftIO u $ asks msgStore - let queues = activeMsgQueues st - notifiers = notifiers' st + let STMQueueStore {queues, notifiers} = stmQueueStore st getStat :: (ServerStats -> IORef a) -> IO a getStat var = readIORef (var ss) putStat :: Show a => String -> (ServerStats -> IORef a) -> IO () @@ -852,8 +851,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHT CPDelete sId -> withUserRole $ unliftIO u $ do AMS _ st <- asks msgStore r <- liftIO $ runExceptT $ do - (q, qr) <- ExceptT $ getQueueRec st SSender sId - ExceptT $ deleteQueueSize st (recipientId qr) q + q <- ExceptT $ getQueue st SSender sId + ExceptT $ deleteQueueSize st q case r of Left e -> liftIO $ hPutStrLn h $ "error: " <> show e Right (qr, numDeleted) -> do @@ -916,7 +915,7 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio c <- liftIO $ newClient msType clientId q thVersion sessionId ts runClientThreads msType ms active c clientId `finally` clientDisconnected c where - runClientThreads :: STMQueueStore (MsgStore s) => SMSType s -> MsgStore s -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore s) -> IS.Key -> M () + runClientThreads :: STMStoreClass (MsgStore s) => SMSType s -> MsgStore s -> TVar (IM.IntMap (Maybe AClient)) -> Client (MsgStore s) -> IS.Key -> M () runClientThreads msType ms active c clientId = do atomically $ modifyTVar' active $ IM.insert clientId $ Just (AClient msType c) s <- asks server @@ -972,7 +971,7 @@ cancelSub s = case subThread s of _ -> pure () ProhibitSub -> pure () -receive :: forall c s. (Transport c, STMQueueStore s) => THandleSMP c 'TServer -> s -> Client s -> M () +receive :: forall c s. (Transport c, STMStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M () receive h@THandle {params = THandleParams {thAuth}} ms Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive" sa <- asks serverActive @@ -1072,7 +1071,7 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail -- - the queue or party key do not exist. -- In all cases, the time of the verification should depend only on the provided authorization type, -- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result. -verifyTransmission :: forall s. STMQueueStore s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s) +verifyTransmission :: forall s. STMStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s) verifyTransmission ms auth_ tAuth authorized queueId cmd = case cmd of Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k @@ -1149,7 +1148,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do action `finally` atomically (modifyTVar' endThreads $ IM.delete tId) mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId -client :: forall s. STMQueueStore s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M () +client :: forall s. STMStoreClass s => THandleParams SMPVersion 'TServer -> Server -> s -> Client s -> M () client thParams' Server {subscribedQ, ntfSubscribedQ, subscribers} @@ -1282,10 +1281,9 @@ client updatedAt <- Just <$> liftIO getSystemDate let rcvDhSecret = C.dh' dhKey privDhKey qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} - qRec (recipientId, senderId) = + qRec senderId = QueueRec - { recipientId, - senderId, + { senderId, recipientKey, rcvDhSecret, senderKey = Nothing, @@ -1297,12 +1295,12 @@ client (corrId,entId,) <$> addQueueRetry 3 qik qRec where addQueueRetry :: - Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> M BrokerMsg + Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> (SenderId -> QueueRec) -> M BrokerMsg addQueueRetry 0 _ _ = pure $ ERR INTERNAL addQueueRetry n qik qRec = do - ids <- getIds - let qr = qRec ids - liftIO (addQueue ms qr) >>= \case + ids@(rId, sId) <- getIds + let qr = qRec sId + liftIO (addQueue ms rId qr) >>= \case Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec Left e -> pure $ ERR e Right q -> do @@ -1379,7 +1377,7 @@ client incStat $ qSubDuplicate stats atomically (tryTakeTMVar $ delivered s) >> deliver False s where - rId = recipientId qr + rId = recipientId' q newSub :: M Sub newSub = time "SUB newSub" . atomically $ do writeTQueue subscribedQ (rId, clientId, True) @@ -1390,7 +1388,7 @@ client deliver inc sub = do stats <- asks serverStats fmap (either (\e -> (corrId, rId, ERR e)) id) $ liftIO $ runExceptT $ do - msg_ <- tryPeekMsg ms rId q + msg_ <- tryPeekMsg ms q liftIO $ when (inc && isJust msg_) $ incStat (qSub stats) liftIO $ deliverMessage "SUB" qr rId sub msg_ @@ -1424,7 +1422,7 @@ client getMessage_ s delivered_ = do stats <- asks serverStats fmap (either err id) $ liftIO $ runExceptT $ - tryPeekMsg ms (recipientId qr) q >>= \case + tryPeekMsg ms q >>= \case Just msg -> do let encMsg = encryptMsg qr msg incStat $ (if isJust delivered_ then msgGetDuplicate else msgGet) stats @@ -1471,11 +1469,11 @@ client fmap (either err id) $ liftIO $ runExceptT $ do case st of ProhibitSub -> do - deletedMsg_ <- tryDelMsg ms (recipientId qr) q msgId + deletedMsg_ <- tryDelMsg ms q msgId liftIO $ mapM_ (updateStats stats True) deletedMsg_ pure ok _ -> do - (deletedMsg_, msg_) <- tryDelPeekMsg ms (recipientId qr) q msgId + (deletedMsg_, msg_) <- tryDelPeekMsg ms q msgId liftIO $ mapM_ (updateStats stats False) deletedMsg_ liftIO $ deliverMessage "ACK" qr entId sub msg_ _ -> pure $ err NO_MSG @@ -1529,7 +1527,7 @@ client msg_ <- liftIO $ time "SEND" $ runExceptT $ do expireMessages messageExpiration stats msg <- liftIO $ mkMessage msgId body - writeMsg ms (recipientId qr) q True msg + writeMsg ms q True msg case msg_ of Left e -> pure $ err e Right Nothing -> do @@ -1540,10 +1538,10 @@ client when (notification msgFlags) $ do mapM_ (`enqueueNotification` msg) (notifier qr) incStat $ msgSentNtf stats - liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) + liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId' q) incStat $ msgSent stats incStat $ msgCount stats - liftIO $ updatePeriodStats (activeQueues stats) (recipientId qr) + liftIO $ updatePeriodStats (activeQueues stats) (recipientId' q) pure ok where mkMessage :: MsgId -> C.MaxLenBS MaxMessageLen -> IO Message @@ -1553,7 +1551,7 @@ client expireMessages :: Maybe ExpirationConfig -> ServerStats -> ExceptT ErrorType IO () expireMessages msgExp stats = do - deleted <- maybe (pure 0) (deleteExpiredMsgs ms (recipientId qr) q <=< liftIO . expireBeforeEpoch) msgExp + deleted <- maybe (pure 0) (deleteExpiredMsgs ms q <=< liftIO . expireBeforeEpoch) msgExp liftIO $ when (deleted > 0) $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) -- The condition for delivery of the message is: @@ -1571,7 +1569,7 @@ client whenM (TM.memberIO rId subscribers) $ atomically deliverToSub >>= mapM_ forkDeliver where - rId = recipientId qr + rId = recipientId' q deliverToSub = -- lookup has ot be in the same transaction, -- so that if subscription ends, it re-evalutates @@ -1715,7 +1713,7 @@ client delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M (Transmission BrokerMsg) delQueueAndMsgs (q, _) = do - liftIO (deleteQueue ms entId q) >>= \case + liftIO (deleteQueue ms q) >>= \case Right qr -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it atomically $ do @@ -1735,11 +1733,11 @@ client Left e -> pure $ err e getQueueInfo :: StoreQueue s -> QueueRec -> M BrokerMsg - getQueueInfo q QueueRec {recipientId = rId, senderKey, notifier} = do + getQueueInfo q QueueRec {senderKey, notifier} = do fmap (either ERR id) $ liftIO $ runExceptT $ do qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub - qiSize <- getQueueSize ms rId q - qiMsg <- toMsgInfo <$$> tryPeekMsg ms rId q + qiSize <- getQueueSize ms q + qiMsg <- toMsgInfo <$$> tryPeekMsg ms q let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} pure $ INFO info where @@ -1809,8 +1807,9 @@ exportMessages tty ms f drainMsgs = do logError $ "error exporting messages: " <> tshow e exitFailure where - saveQueueMsgs h rId q = - runExceptT (getQueueMessages drainMsgs ms rId q) >>= \case + saveQueueMsgs h q = do + let rId = recipientId' q + runExceptT (getQueueMessages drainMsgs ms q) >>= \case Right msgs -> Sum (length msgs) <$ BLD.hPutBuilder h (encodeMessages rId msgs) Left e -> do logError $ "STORE: saveQueueMsgs, error exporting messages from queue " <> decodeLatin1 (strEncode rId) <> ", " <> tshow e @@ -1838,7 +1837,7 @@ processServerMessages = do withAllMsgQueues False ms $ processValidateQueue | otherwise -> logWarn "skipping message expiration" $> Nothing where - processExpireQueue old rId q = + processExpireQueue old q = runExceptT expireQueue >>= \case Right (storedMsgsCount, expiredMsgsCount) -> pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1} @@ -1847,20 +1846,20 @@ processServerMessages = do exitFailure where expireQueue = do - expired'' <- deleteExpiredMsgs ms rId q old - stored'' <- getQueueSize ms rId q + expired'' <- deleteExpiredMsgs ms q old + stored'' <- getQueueSize ms q liftIO $ closeMsgQueue q pure (stored'', expired'') - processValidateQueue :: RecipientId -> JournalQueue -> IO MessageStats - processValidateQueue rId q = - runExceptT (getQueueSize ms rId q) >>= \case + processValidateQueue :: JournalQueue -> IO MessageStats + processValidateQueue q = + runExceptT (getQueueSize ms q) >>= \case Right storedMsgsCount -> pure newMessageStats {storedMsgsCount, storedQueues = 1} Left e -> do logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e exitFailure -- TODO this function should be called after importing queues from store log -importMessages :: forall s. STMQueueStore s => Bool -> s -> FilePath -> Maybe Int64 -> IO MessageStats +importMessages :: forall s. STMStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> IO MessageStats importMessages tty ms f old_ = do logInfo $ "restoring messages from file " <> T.pack f LB.readFile f >>= runExceptT . foldM restoreMsg (0, Nothing, (0, 0, M.empty)) . LB.lines >>= \case @@ -1873,7 +1872,7 @@ importMessages tty ms f old_ = do renameFile f $ f <> ".bak" mapM_ setOverQuota_ overQuota logQueueStates ms - storedQueues <- M.size <$> readTVarIO (activeMsgQueues ms) + storedQueues <- M.size <$> readTVarIO (queues $ stmQueueStore ms) pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where progress i = "Processed " <> show i <> " lines" @@ -1892,7 +1891,7 @@ importMessages tty ms f old_ = do (i + 1,Just (rId, q),) <$> case msg of Message {msgTs} | maybe True (systemSeconds msgTs >=) old_ -> do - writeMsg ms rId q False msg >>= \case + writeMsg ms q False msg >>= \case Just _ -> pure (stored + 1, expired, overQuota) Nothing -> do logError $ decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) @@ -1901,11 +1900,11 @@ importMessages tty ms f old_ = do MessageQuota {} -> -- queue was over quota at some point, -- it will be set as over quota once fully imported - mergeQuotaMsgs >> writeMsg ms rId q False msg $> (stored, expired, M.insert rId q overQuota) + mergeQuotaMsgs >> writeMsg ms q False msg $> (stored, expired, M.insert rId q overQuota) where -- if the first message in queue head is "quota", remove it. mergeQuotaMsgs = - withPeekMsgQueue ms rId q "mergeQuotaMsgs" $ maybe (pure ()) $ \case + withPeekMsgQueue ms q "mergeQuotaMsgs" $ maybe (pure ()) $ \case (mq, MessageQuota {}) -> tryDeleteMsg_ q mq False _ -> pure () msgErr :: Show e => String -> e -> String @@ -1982,7 +1981,7 @@ restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >> Right d@ServerStatsData {_qCount = statsQCount, _msgCount = statsMsgCount, _ntfCount = statsNtfCount} -> do s <- asks serverStats AMS _ st <- asks msgStore - _qCount <- M.size <$> readTVarIO (activeMsgQueues st) + _qCount <- M.size <$> readTVarIO (queues $ stmQueueStore st) let _msgCount = maybe statsMsgCount storedMsgsCount msgStats_ _ntfCount = storedMsgsCount ntfStats _msgExpired' = _msgExpired d + maybe 0 expiredMsgsCount msgStats_ diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index f7a9cc7e8..4044e0d22 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -189,7 +189,7 @@ type family MsgStore s where MsgStore 'MSMemory = STMMsgStore MsgStore 'MSJournal = JournalMsgStore -data AMsgStore = forall s. (STMQueueStore (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s) +data AMsgStore = forall s. (STMStoreClass (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s) data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s)) @@ -362,5 +362,5 @@ newSMPProxyAgent smpAgentCfg random = do smpAgent <- newSMPClientAgent smpAgentCfg random pure ProxyAgent {smpAgent} -readWriteQueueStore :: STMQueueStore s => FilePath -> s -> IO (StoreLog 'WriteMode) +readWriteQueueStore :: STMStoreClass s => FilePath -> s -> IO (StoreLog 'WriteMode) readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 4e5496f66..0834ad1d9 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -15,7 +15,7 @@ {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Server.MsgStore.Journal - ( JournalMsgStore (queues, senders, notifiers, random), + ( JournalMsgStore (queueStore, random), JournalQueue, JournalMsgQueue (queue, state), JMQueue (queueDirectory, statePath), @@ -77,10 +77,7 @@ data JournalMsgStore = JournalMsgStore { config :: JournalStoreConfig, random :: TVar StdGen, queueLocks :: TMap RecipientId Lock, - queues :: TMap RecipientId JournalQueue, - senders :: TMap SenderId RecipientId, - notifiers :: TMap NotifierId RecipientId, - storeLog :: TVar (Maybe (StoreLog 'WriteMode)) + queueStore :: STMQueueStore JournalQueue } data JournalStoreConfig = JournalStoreConfig @@ -98,7 +95,8 @@ data JournalStoreConfig = JournalStoreConfig } data JournalQueue = JournalQueue - { queueLock :: Lock, + { recipientId :: RecipientId, + queueLock :: Lock, -- To avoid race conditions and errors when restoring queues, -- Nothing is written to TVar when queue is deleted. queueRec :: TVar (Maybe QueueRec), @@ -218,18 +216,15 @@ logFileExt = ".log" newtype StoreIO a = StoreIO {unStoreIO :: IO a} deriving newtype (Functor, Applicative, Monad) -instance STMQueueStore JournalMsgStore where - queues' = queues - senders' = senders - notifiers' = notifiers - storeLog' = storeLog - mkQueue st qr = do - lock <- getMapLock (queueLocks st) $ recipientId qr +instance STMStoreClass JournalMsgStore where + stmQueueStore JournalMsgStore {queueStore} = queueStore + mkQueue st rId qr = do + lock <- getMapLock (queueLocks st) rId q <- newTVar $ Just qr mq <- newTVar Nothing activeAt <- newTVar 0 isEmpty <- newTVar Nothing - pure $ JournalQueue lock q mq activeAt isEmpty + pure $ JournalQueue rId lock q mq activeAt isEmpty msgQueue_' = msgQueue_ instance MsgStoreClass JournalMsgStore where @@ -242,27 +237,21 @@ instance MsgStoreClass JournalMsgStore where newMsgStore config = do random <- newTVarIO =<< newStdGen queueLocks <- TM.emptyIO - queues <- TM.emptyIO - senders <- TM.emptyIO - notifiers <- TM.emptyIO - storeLog <- newTVarIO Nothing - pure JournalMsgStore {config, random, queueLocks, queues, senders, notifiers, storeLog} + queueStore <- newQueueStore + pure JournalMsgStore {config, random, queueLocks, queueStore} setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) + setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl) - closeMsgStore st = do + closeMsgStore JournalMsgStore {queueStore = st} = do readTVarIO (storeLog st) >>= mapM_ closeStoreLog readTVarIO (queues st) >>= mapM_ closeMsgQueue - activeMsgQueues = queues - {-# INLINE activeMsgQueues #-} - -- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result. -- It is used to export storage to a single file and also to expire messages and validate all queues when server is started. -- TODO this function requires case-sensitive file system, because it uses queue directory as recipient ID. -- It can be made to support case-insensite FS by supporting more than one queue per directory, by getting recipient ID from state file name. - withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (RecipientId -> JournalQueue -> IO a) -> IO a + withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (JournalQueue -> IO a) -> IO a withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty) where processStore = do @@ -276,7 +265,7 @@ instance MsgStoreClass JournalMsgStore where r' <- case strDecode $ B.pack queueId of Right rId -> getQueue ms SRecipient rId >>= \case - Right q -> unStoreIO (getMsgQueue ms rId q) *> action rId q <* closeMsgQueue q + Right q -> unStoreIO (getMsgQueue ms q) *> action q <* closeMsgQueue q Left AUTH -> do logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir removeQueueDirectory_ dir @@ -303,7 +292,7 @@ instance MsgStoreClass JournalMsgStore where (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping")) logQueueStates :: JournalMsgStore -> IO () - logQueueStates ms = withActiveMsgQueues ms $ \_ -> unStoreIO . logQueueState + logQueueStates ms = withActiveMsgQueues ms $ unStoreIO . logQueueState logQueueState :: JournalQueue -> StoreIO () logQueueState q = @@ -312,11 +301,14 @@ instance MsgStoreClass JournalMsgStore where $>>= \mq -> readTVarIO (handles mq) $>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ()) + recipientId' = recipientId + {-# INLINE recipientId' #-} + queueRec' = queueRec {-# INLINE queueRec' #-} - getMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO JournalMsgQueue - getMsgQueue ms@JournalMsgStore {random} rId JournalQueue {msgQueue_} = + getMsgQueue :: JournalMsgStore -> JournalQueue -> StoreIO JournalMsgQueue + getMsgQueue ms@JournalMsgStore {random} JournalQueue {recipientId = rId, msgQueue_} = StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure where newQ = do @@ -334,8 +326,8 @@ instance MsgStoreClass JournalMsgStore where journalId <- newJournalId random mkJournalQueue queue (newMsgQueueState journalId) Nothing - getPeekMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message)) - getPeekMsgQueue ms rId q@JournalQueue {isEmpty} = + getPeekMsgQueue :: JournalMsgStore -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message)) + getPeekMsgQueue ms q@JournalQueue {isEmpty} = StoreIO (readTVarIO isEmpty) >>= \case Just True -> pure Nothing Just False -> peek @@ -350,16 +342,16 @@ instance MsgStoreClass JournalMsgStore where pure r where peek = do - mq <- getMsgQueue ms rId q + mq <- getMsgQueue ms q (mq,) <$$> tryPeekMsg_ q mq -- only runs action if queue is not empty - withIdleMsgQueue :: Int64 -> JournalMsgStore -> RecipientId -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int) - withIdleMsgQueue now ms@JournalMsgStore {config} rId q action = + withIdleMsgQueue :: Int64 -> JournalMsgStore -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int) + withIdleMsgQueue now ms@JournalMsgStore {config} q action = StoreIO $ readTVarIO (msgQueue_ q) >>= \case Nothing -> E.bracket - (unStoreIO $ getPeekMsgQueue ms rId q) + (unStoreIO $ getPeekMsgQueue ms q) (mapM_ $ \_ -> closeMsgQueue q) (maybe (pure (Nothing, 0)) (unStoreIO . run)) where @@ -375,13 +367,12 @@ instance MsgStoreClass JournalMsgStore where sz <- unStoreIO $ getQueueSize_ mq pure (r, sz) - deleteQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType QueueRec) - deleteQueue ms rId q = - fst <$$> deleteQueue_ ms rId q + deleteQueue :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType QueueRec) + deleteQueue ms q = fst <$$> deleteQueue_ ms q - deleteQueueSize :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Int)) - deleteQueueSize ms rId q = - deleteQueue_ ms rId q >>= mapM (traverse getSize) + deleteQueueSize :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType (QueueRec, Int)) + deleteQueueSize ms q = + deleteQueue_ ms q >>= mapM (traverse getSize) -- traverse operates on the second tuple element where getSize = maybe (pure (-1)) (fmap size . readTVarIO . state) @@ -397,9 +388,9 @@ instance MsgStoreClass JournalMsgStore where updateReadPos q drainMsgs len hs (msg :) <$> run msgs - writeMsg :: JournalMsgStore -> RecipientId -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms rId q' logState msg = isolateQueue rId q' "writeMsg" $ do - q <- getMsgQueue ms rId q' + writeMsg :: JournalMsgStore -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg ms q' logState msg = isolateQueue q' "writeMsg" $ do + q <- getMsgQueue ms q' StoreIO $ (`E.finally` updateActiveAt q') $ do st@MsgQueueState {canWrite, size} <- readTVarIO (state q) let empty = size == 0 @@ -476,9 +467,9 @@ instance MsgStoreClass JournalMsgStore where $>>= \len -> readTVarIO handles $>>= \hs -> updateReadPos mq logState len hs $> Just () - isolateQueue :: RecipientId -> JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a - isolateQueue rId JournalQueue {queueLock} op = - tryStore' op rId . withLock' queueLock op . unStoreIO + isolateQueue :: JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a + isolateQueue JournalQueue {recipientId, queueLock} op = + tryStore' op recipientId . withLock' queueLock op . unStoreIO updateActiveAt :: JournalQueue -> IO () updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime @@ -721,11 +712,12 @@ validQueueState MsgQueueState {readState = rs, writeState = ws, size} && msgPos ws == msgCount ws && bytePos ws == byteCount ws -deleteQueue_ :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue)) -deleteQueue_ ms rId q = +deleteQueue_ :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue)) +deleteQueue_ ms q = runExceptT $ isolateQueueId "deleteQueue_" ms rId $ - deleteQueue' ms rId q >>= mapM remove + deleteQueue' ms q >>= mapM remove where + rId = recipientId q remove r@(_, mq_) = do mapM_ closeMsgQueueHandles mq_ removeQueueDirectory ms rId diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index cbeb75f9c..2df41a9f1 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -26,22 +26,18 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.TMap (TMap) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util ((<$$>), ($>>=)) import System.IO (IOMode (..)) data STMMsgStore = STMMsgStore { storeConfig :: STMStoreConfig, - queues :: TMap RecipientId STMQueue, - senders :: TMap SenderId RecipientId, - notifiers :: TMap NotifierId RecipientId, - storeLog :: TVar (Maybe (StoreLog 'WriteMode)) + queueStore :: STMQueueStore STMQueue } data STMQueue = STMQueue { -- To avoid race conditions and errors when restoring queues, -- Nothing is written to TVar when queue is deleted. + recipientId :: RecipientId, queueRec :: TVar (Maybe QueueRec), msgQueue_ :: TVar (Maybe STMMsgQueue) } @@ -57,12 +53,9 @@ data STMStoreConfig = STMStoreConfig quota :: Int } -instance STMQueueStore STMMsgStore where - queues' = queues - senders' = senders - notifiers' = notifiers - storeLog' = storeLog - mkQueue _ qr = STMQueue <$> newTVar (Just qr) <*> newTVar Nothing +instance STMStoreClass STMMsgStore where + stmQueueStore = queueStore + mkQueue _ rId qr = STMQueue rId <$> newTVar (Just qr) <*> newTVar Nothing msgQueue_' = msgQueue_ instance MsgStoreClass STMMsgStore where @@ -73,32 +66,31 @@ instance MsgStoreClass STMMsgStore where newMsgStore :: STMStoreConfig -> IO STMMsgStore newMsgStore storeConfig = do - queues <- TM.emptyIO - senders <- TM.emptyIO - notifiers <- TM.emptyIO - storeLog <- newTVarIO Nothing - pure STMMsgStore {storeConfig, queues, senders, notifiers, storeLog} + queueStore <- newQueueStore + pure STMMsgStore {storeConfig, queueStore} setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO () - setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl) + setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl) - closeMsgStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog - - activeMsgQueues = queues - {-# INLINE activeMsgQueues #-} + closeMsgStore st = readTVarIO (storeLog $ queueStore st) >>= mapM_ closeStoreLog withAllMsgQueues _ = withActiveMsgQueues {-# INLINE withAllMsgQueues #-} logQueueStates _ = pure () + {-# INLINE logQueueStates #-} logQueueState _ = pure () + {-# INLINE logQueueState #-} + + recipientId' = recipientId + {-# INLINE recipientId' #-} queueRec' = queueRec {-# INLINE queueRec' #-} - getMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM STMMsgQueue - getMsgQueue _ _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure + getMsgQueue :: STMMsgStore -> STMQueue -> STM STMMsgQueue + getMsgQueue _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure where newQ = do msgQueue <- newTQueue @@ -108,23 +100,23 @@ instance MsgStoreClass STMMsgStore where writeTVar msgQueue_ (Just q) pure q - getPeekMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM (Maybe (STMMsgQueue, Message)) - getPeekMsgQueue _ _ q@STMQueue {msgQueue_} = readTVar msgQueue_ $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq + getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message)) + getPeekMsgQueue _ q@STMQueue {msgQueue_} = readTVar msgQueue_ $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq -- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue) - withIdleMsgQueue :: Int64 -> STMMsgStore -> RecipientId -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int) - withIdleMsgQueue _ _ _ STMQueue {msgQueue_} action = readTVar msgQueue_ >>= \case + withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int) + withIdleMsgQueue _ _ STMQueue {msgQueue_} action = readTVar msgQueue_ >>= \case Just q -> do r <- action q sz <- getQueueSize_ q pure (Just r, sz) Nothing -> pure (Nothing, 0) - deleteQueue :: STMMsgStore -> RecipientId -> STMQueue -> IO (Either ErrorType QueueRec) - deleteQueue ms rId q = fst <$$> deleteQueue' ms rId q + deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec) + deleteQueue ms q = fst <$$> deleteQueue' ms q - deleteQueueSize :: STMMsgStore -> RecipientId -> STMQueue -> IO (Either ErrorType (QueueRec, Int)) - deleteQueueSize ms rId q = deleteQueue' ms rId q >>= mapM (traverse getSize) + deleteQueueSize :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Int)) + deleteQueueSize ms q = deleteQueue' ms q >>= mapM (traverse getSize) -- traverse operates on the second tuple element where getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size) @@ -137,9 +129,9 @@ instance MsgStoreClass STMMsgStore where mapM_ (writeTQueue q) msgs pure msgs - writeMsg :: STMMsgStore -> RecipientId -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) - writeMsg ms rId q' _logState msg = liftIO $ atomically $ do - STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms rId q' + writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg ms q' _logState msg = liftIO $ atomically $ do + STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms q' canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -171,5 +163,5 @@ instance MsgStoreClass STMMsgStore where Just _ -> modifyTVar' size (subtract 1) _ -> pure () - isolateQueue :: RecipientId -> STMQueue -> String -> STM a -> ExceptT ErrorType IO a - isolateQueue _ _ _ = liftIO . atomically + isolateQueue :: STMQueue -> String -> STM a -> ExceptT ErrorType IO a + isolateQueue _ _ = liftIO . atomically diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 8754767cd..7317a0fab 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -20,7 +20,6 @@ import Control.Monad.Trans.Except import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind -import qualified Data.Map.Strict as M import Data.Time.Clock.System (SystemTime (systemSeconds)) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore @@ -29,12 +28,16 @@ import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.Util ((<$$>)) import System.IO (IOMode (..)) -class MsgStoreClass s => STMQueueStore s where - queues' :: s -> TMap RecipientId (StoreQueue s) - senders' :: s -> TMap SenderId RecipientId - notifiers' :: s -> TMap NotifierId RecipientId - storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode)) - mkQueue :: s -> QueueRec -> STM (StoreQueue s) +data STMQueueStore q = STMQueueStore + { queues :: TMap RecipientId q, + senders :: TMap SenderId RecipientId, + notifiers :: TMap NotifierId RecipientId, + storeLog :: TVar (Maybe (StoreLog 'WriteMode)) + } + +class MsgStoreClass s => STMStoreClass s where + stmQueueStore :: s -> STMQueueStore (StoreQueue s) + mkQueue :: s -> RecipientId -> QueueRec -> STM (StoreQueue s) msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s)) class Monad (StoreMonad s) => MsgStoreClass s where @@ -45,25 +48,25 @@ class Monad (StoreMonad s) => MsgStoreClass s where newMsgStore :: MsgStoreConfig s -> IO s setStoreLog :: s -> StoreLog 'WriteMode -> IO () closeMsgStore :: s -> IO () - activeMsgQueues :: s -> TMap RecipientId (StoreQueue s) - withAllMsgQueues :: Monoid a => Bool -> s -> (RecipientId -> StoreQueue s -> IO a) -> IO a + withAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a logQueueStates :: s -> IO () logQueueState :: StoreQueue s -> StoreMonad s () + recipientId' :: StoreQueue s -> RecipientId queueRec' :: StoreQueue s -> TVar (Maybe QueueRec) - getPeekMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) - getMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (MsgQueue s) + getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) + getMsgQueue :: s -> StoreQueue s -> StoreMonad s (MsgQueue s) -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config - withIdleMsgQueue :: Int64 -> s -> RecipientId -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) - deleteQueue :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType QueueRec) - deleteQueueSize :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int)) + withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) + deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec) + deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int)) getQueueMessages_ :: Bool -> MsgQueue s -> StoreMonad s [Message] - writeMsg :: s -> RecipientId -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) + writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running getQueueSize_ :: MsgQueue s -> StoreMonad s Int tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message) tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s () - isolateQueue :: RecipientId -> StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a + isolateQueue :: StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a data MSType = MSMemory | MSJournal @@ -73,28 +76,26 @@ data SMSType :: MSType -> Type where data AMSType = forall s. AMSType (SMSType s) -withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (RecipientId -> StoreQueue s -> IO a) -> IO a -withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= foldM run mempty . M.assocs +withActiveMsgQueues :: (STMStoreClass s, Monoid a) => s -> (StoreQueue s -> IO a) -> IO a +withActiveMsgQueues st f = readTVarIO (queues $ stmQueueStore st) >>= foldM run mempty where - run !acc (k, v) = do - r <- f k v - pure $! acc <> r + run !acc = fmap (acc <>) . f -getQueueMessages :: MsgStoreClass s => Bool -> s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO [Message] -getQueueMessages drainMsgs st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs . fst) +getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message] +getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs . fst) {-# INLINE getQueueMessages #-} -getQueueSize :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO Int -getQueueSize st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst) +getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int +getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst) {-# INLINE getQueueSize #-} -tryPeekMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message) -tryPeekMsg st rId q = snd <$$> withPeekMsgQueue st rId q "tryPeekMsg" pure +tryPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message) +tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure {-# INLINE tryPeekMsg #-} -tryDelMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message) -tryDelMsg st rId q msgId' = - withPeekMsgQueue st rId q "tryDelMsg" $ +tryDelMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message) +tryDelMsg st q msgId' = + withPeekMsgQueue st q "tryDelMsg" $ maybe (pure Nothing) $ \(mq, msg) -> if | messageId msg == msgId' -> @@ -102,30 +103,30 @@ tryDelMsg st rId q msgId' = | otherwise -> pure Nothing -- atomic delete (== read) last and peek next message if available -tryDelPeekMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) -tryDelPeekMsg st rId q msgId' = - withPeekMsgQueue st rId q "tryDelPeekMsg" $ +tryDelPeekMsg :: MsgStoreClass s => s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message) +tryDelPeekMsg st q msgId' = + withPeekMsgQueue st q "tryDelPeekMsg" $ maybe (pure (Nothing, Nothing)) $ \(mq, msg) -> if | messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq) | otherwise -> pure (Nothing, Just msg) -- The action is called with Nothing when it is known that the queue is empty -withPeekMsgQueue :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a -withPeekMsgQueue st rId q op a = isolateQueue rId q op $ getPeekMsgQueue st rId q >>= a +withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a +withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a {-# INLINE withPeekMsgQueue #-} -deleteExpiredMsgs :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int -deleteExpiredMsgs st rId q old = - isolateQueue rId q "deleteExpiredMsgs" $ - getMsgQueue st rId q >>= deleteExpireMsgs_ old q +deleteExpiredMsgs :: MsgStoreClass s => s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int +deleteExpiredMsgs st q old = + isolateQueue q "deleteExpiredMsgs" $ + getMsgQueue st q >>= deleteExpireMsgs_ old q -- closed and idle queues will be closed after expiration -- returns (expired count, queue size after expiration) -idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int) -idleDeleteExpiredMsgs now st rId q old = - isolateQueue rId q "idleDeleteExpiredMsgs" $ - withIdleMsgQueue now st rId q (deleteExpireMsgs_ old q) +idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int) +idleDeleteExpiredMsgs now st q old = + isolateQueue q "idleDeleteExpiredMsgs" $ + withIdleMsgQueue now st q (deleteExpireMsgs_ old q) deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int deleteExpireMsgs_ old q mq = do diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index a40875680..af26b91f7 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -16,8 +16,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol data QueueRec = QueueRec - { recipientId :: !RecipientId, - recipientKey :: !RcvPublicAuthKey, + { recipientKey :: !RcvPublicAuthKey, rcvDhSecret :: !RcvDhSecret, senderId :: !SenderId, senderKey :: !(Maybe SndPublicAuthKey), diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index a073b5500..f1347533a 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -25,6 +25,7 @@ module Simplex.Messaging.Server.QueueStore.STM unblockQueue, updateQueueTime, deleteQueue', + newQueueStore, readQueueStore, withLog', ) @@ -51,99 +52,106 @@ import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$)) import System.IO import UnliftIO.STM -addQueue :: STMQueueStore s => s -> QueueRec -> IO (Either ErrorType (StoreQueue s)) -addQueue st qr@QueueRec {recipientId = rId, senderId = sId, notifier}= - atomically add - $>>= \q -> q <$$ withLog "addQueue" st (`logCreateQueue` qr) - where - add = ifM hasId (pure $ Left DUPLICATE_) $ do - q <- mkQueue st qr -- STMQueue lock <$> (newTVar $! Just qr) <*> newTVar Nothing - TM.insert rId q $ queues' st - TM.insert sId rId $ senders' st - forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers' st - pure $ Right q - hasId = or <$> sequence [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier] - hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers' st)) notifier +newQueueStore :: IO (STMQueueStore q) +newQueueStore = do + queues <- TM.emptyIO + senders <- TM.emptyIO + notifiers <- TM.emptyIO + storeLog <- newTVarIO Nothing + pure STMQueueStore {queues, senders, notifiers, storeLog} -getQueue :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) +addQueue :: STMStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s)) +addQueue st rId qr@QueueRec {senderId = sId, notifier}= + atomically add + $>>= \q -> q <$$ withLog "addQueue" st (\s -> logCreateQueue s rId qr) + where + STMQueueStore {queues, senders, notifiers} = stmQueueStore st + add = ifM hasId (pure $ Left DUPLICATE_) $ do + q <- mkQueue st rId qr + TM.insert rId q queues + TM.insert sId rId senders + forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers + pure $ Right q + hasId = or <$> sequence [TM.member rId queues, TM.member sId senders, hasNotifier] + hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier + +getQueue :: (STMStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s)) getQueue st party qId = maybe (Left AUTH) Right <$> case party of - SRecipient -> TM.lookupIO qId $ queues' st - SSender -> TM.lookupIO qId (senders' st) $>>= (`TM.lookupIO` queues' st) - SNotifier -> TM.lookupIO qId (notifiers' st) $>>= (`TM.lookupIO` queues' st) + SRecipient -> TM.lookupIO qId queues + SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues) + SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues) + where + STMQueueStore {queues, senders, notifiers} = stmQueueStore st -getQueueRec :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) +getQueueRec :: (STMStoreClass s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec)) getQueueRec st party qId = getQueue st party qId $>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec' q)) -secureQueue :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) +secureQueue :: STMStoreClass s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = atomically (readQueueRec qr $>>= secure) - $>>= \rId -> withLog "secureQueue" st $ \s -> logSecureQueue s rId sKey + $>>= \_ -> withLog "secureQueue" st $ \s -> logSecureQueue s (recipientId' sq) sKey where qr = queueRec' sq - secure q@QueueRec {recipientId = rId} = case senderKey q of - Just k -> pure $ if sKey == k then Right rId else Left AUTH + secure q = case senderKey q of + Just k -> pure $ if sKey == k then Right () else Left AUTH Nothing -> do writeTVar qr $ Just q {senderKey = Just sKey} - pure $ Right rId + pure $ Right () -addQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) +addQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} = atomically (readQueueRec qr $>>= add) - $>>= \(rId, nId_) -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds) + $>>= \nId_ -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds) where + rId = recipientId' sq qr = queueRec' sq - add q@QueueRec {recipientId = rId} = ifM (TM.member nId (notifiers' st)) (pure $ Left DUPLICATE_) $ do - nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId (notifiers' st) $> notifierId + STMQueueStore {notifiers} = stmQueueStore st + add q = ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do + nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId let !q' = q {notifier = Just ntfCreds} writeTVar qr $ Just q' - TM.insert nId rId $ notifiers' st - pure $ Right (rId, nId_) + TM.insert nId rId notifiers + pure $ Right nId_ -deleteQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) +deleteQueueNotifier :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier st sq = atomically (readQueueRec qr >>= mapM delete) - $>>= \(rId, nId_) -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId) + $>>= \nId_ -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` recipientId' sq) where qr = queueRec' sq - delete q = fmap (recipientId q,) $ forM (notifier q) $ \NtfCreds {notifierId} -> do - TM.delete notifierId $ notifiers' st + delete q = forM (notifier q) $ \NtfCreds {notifierId} -> do + TM.delete notifierId $ notifiers $ stmQueueStore st writeTVar qr $! Just q {notifier = Nothing} pure notifierId -suspendQueue :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ()) +suspendQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ()) suspendQueue st sq = atomically (readQueueRec qr >>= mapM suspend) - $>>= \rId -> withLog "suspendQueue" st (`logSuspendQueue` rId) + $>>= \_ -> withLog "suspendQueue" st (`logSuspendQueue` recipientId' sq) where qr = queueRec' sq - suspend q = do - writeTVar qr $! Just q {status = EntityOff} - pure $ recipientId q + suspend q = writeTVar qr $! Just q {status = EntityOff} -blockQueue :: STMQueueStore s => s -> StoreQueue s -> BlockingInfo -> IO (Either ErrorType ()) +blockQueue :: STMStoreClass s => s -> StoreQueue s -> BlockingInfo -> IO (Either ErrorType ()) blockQueue st sq info = atomically (readQueueRec qr >>= mapM block) - $>>= \rId -> withLog "blockQueue" st (\sl -> logBlockQueue sl rId info) + $>>= \_ -> withLog "blockQueue" st (\sl -> logBlockQueue sl (recipientId' sq) info) where qr = queueRec' sq - block q = do - writeTVar qr $ Just q {status = EntityBlocked info} - pure $ recipientId q + block q = writeTVar qr $ Just q {status = EntityBlocked info} -unblockQueue :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ()) +unblockQueue :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType ()) unblockQueue st sq = atomically (readQueueRec qr >>= mapM unblock) - $>>= \rId -> withLog "unblockQueue" st (`logUnblockQueue` rId) + $>>= \_ -> withLog "unblockQueue" st (`logUnblockQueue` recipientId' sq) where qr = queueRec' sq - unblock q = do - writeTVar qr $ Just q {status = EntityActive} - pure $ recipientId q + unblock q = writeTVar qr $ Just q {status = EntityActive} -updateQueueTime :: STMQueueStore s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) +updateQueueTime :: STMStoreClass s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log' where qr = queueRec' sq @@ -153,20 +161,21 @@ updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log' let !q' = q {updatedAt = Just t} in (writeTVar qr $! Just q') $> (q', True) log' (q, changed) - | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId q) t) + | changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId' sq) t) | otherwise = pure $ Right q -deleteQueue' :: STMQueueStore s => s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s))) -deleteQueue' st rId sq = +deleteQueue' :: STMStoreClass s => s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s))) +deleteQueue' st sq = atomically (readQueueRec qr >>= mapM delete) - $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` rId) + $>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` recipientId' sq) >>= bimapM pure (\_ -> (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing)) where qr = queueRec' sq + STMQueueStore {senders, notifiers} = stmQueueStore st delete q = do writeTVar qr Nothing - TM.delete (senderId q) $ senders' st - forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers' st + TM.delete (senderId q) senders + forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers pure q readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec) @@ -183,10 +192,10 @@ withLog' name sl action = where err = name <> ", withLog, " <> show e -withLog :: STMQueueStore s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) -withLog name = withLog' name . storeLog' +withLog :: STMStoreClass s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()) +withLog name = withLog' name . storeLog . stmQueueStore -readQueueStore :: forall s. STMQueueStore s => FilePath -> s -> IO () +readQueueStore :: forall s. STMStoreClass s => FilePath -> s -> IO () readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines where processLine :: LB.ByteString -> IO () @@ -195,13 +204,13 @@ readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLin s = LB.toStrict s' procLogRecord :: StoreLogRecord -> IO () procLogRecord = \case - CreateQueue q -> addQueue st q >>= qError (recipientId q) "CreateQueue" + CreateQueue rId q -> addQueue st rId q >>= qError rId "CreateQueue" SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info UnblockQueue qId -> withQueue qId "UnblockQueue" $ unblockQueue st - DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st qId + DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t printError :: String -> IO () diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 8dee31940..e676770f7 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -54,7 +54,7 @@ import System.Directory (doesFileExist, renameFile) import System.IO data StoreLogRecord - = CreateQueue QueueRec + = CreateQueue RecipientId QueueRec | SecureQueue QueueId SndPublicAuthKey | AddNotifier QueueId NtfCreds | SuspendQueue QueueId @@ -77,10 +77,9 @@ data SLRTag | UpdateTime_ instance StrEncoding QueueRec where - strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = + strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} = B.unwords - [ "rid=" <> strEncode recipientId, - "rk=" <> strEncode recipientKey, + [ "rk=" <> strEncode recipientKey, "rdh=" <> strEncode rcvDhSecret, "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey @@ -98,7 +97,6 @@ instance StrEncoding QueueRec where _ -> " status=" <> strEncode status strP = do - recipientId <- "rid=" *> strP_ recipientKey <- "rk=" *> strP_ rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ @@ -107,7 +105,7 @@ instance StrEncoding QueueRec where notifier <- optional $ " notifier=" *> strP updatedAt <- optional $ " updated_at=" *> strP status <- (" status=" *> strP) <|> pure EntityActive - pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} + pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} instance StrEncoding SLRTag where strEncode = \case @@ -136,7 +134,7 @@ instance StrEncoding SLRTag where instance StrEncoding StoreLogRecord where strEncode = \case - CreateQueue q -> strEncode (CreateQueue_, q) + CreateQueue rId q -> B.unwords [strEncode CreateQueue_, "rid=" <> strEncode rId, strEncode q] SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey) AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds) SuspendQueue rId -> strEncode (SuspendQueue_, rId) @@ -148,7 +146,7 @@ instance StrEncoding StoreLogRecord where strP = strP_ >>= \case - CreateQueue_ -> CreateQueue <$> strP + CreateQueue_ -> CreateQueue <$> ("rid=" *> strP_) <*> strP SecureQueue_ -> SecureQueue <$> strP_ <*> strP AddNotifier_ -> AddNotifier <$> strP_ <*> strP SuspendQueue_ -> SuspendQueue <$> strP @@ -186,8 +184,8 @@ writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do B.hPut h $ strEncode r `B.snoc` '\n' -- hPutStrLn makes write non-atomic for length > 1024 hFlush h -logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO () -logCreateQueue s = writeStoreLogRecord s . CreateQueue +logCreateQueue :: StoreLog 'WriteMode -> RecipientId -> QueueRec -> IO () +logCreateQueue s rId q = writeStoreLogRecord s $ CreateQueue rId q logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey @@ -248,10 +246,11 @@ readWriteStoreLog readStore writeStore f st = renameFile tempBackup timedBackup logInfo $ "original state preserved as " <> T.pack timedBackup -writeQueueStore :: STMQueueStore s => StoreLog 'WriteMode -> s -> IO () -writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M.assocs +writeQueueStore :: STMStoreClass s => StoreLog 'WriteMode -> s -> IO () +writeQueueStore s st = readTVarIO qs >>= mapM_ writeQueue . M.assocs where + qs = queues $ stmQueueStore st writeQueue (rId, q) = readTVarIO (queueRec' q) >>= \case - Just q' -> logCreateQueue s q' - Nothing -> atomically $ TM.delete rId $ activeMsgQueues st + Just q' -> logCreateQueue s rId q' + Nothing -> atomically $ TM.delete rId qs diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index f9afecf5a..f97930b52 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -58,12 +58,12 @@ msgStoreTests = do it "should create write file when missing" testWriteFileMissing it "should create read file when read and write files are missing" testReadAndWriteFilesMissing where - someMsgStoreTests :: STMQueueStore s => SpecWith s + someMsgStoreTests :: STMStoreClass s => SpecWith s someMsgStoreTests = do it "should get queue and store/read messages" testGetQueue it "should not fail on EOF when changing read journal" testChangeReadJournal -withMsgStore :: STMQueueStore s => MsgStoreConfig s -> (s -> IO ()) -> IO () +withMsgStore :: STMStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig @@ -105,8 +105,7 @@ testNewQueueRec g sndSecure = do (k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g let qr = QueueRec - { recipientId = rId, - recipientKey, + { recipientKey, rcvDhSecret = C.dh' k pk, senderId, senderKey = Nothing, @@ -117,66 +116,66 @@ testNewQueueRec g sndSecure = do } pure (rId, qr) -testGetQueue :: STMQueueStore s => s -> IO () +testGetQueue :: STMStoreClass s => s -> IO () testGetQueue ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True runRight_ $ do - q <- ExceptT $ addQueue ms qr - let write s = writeMsg ms rId q True =<< mkMessage s + q <- ExceptT $ addQueue ms rId qr + let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" Just (Message {msgId = mId2}, False) <- write "message 2" Just (Message {msgId = mId3}, False) <- write "message 3" - Msg "message 1" <- tryPeekMsg ms rId q - Msg "message 1" <- tryPeekMsg ms rId q - Nothing <- tryDelMsg ms rId q mId2 - Msg "message 1" <- tryDelMsg ms rId q mId1 - Nothing <- tryDelMsg ms rId q mId1 - Msg "message 2" <- tryPeekMsg ms rId q - Nothing <- tryDelMsg ms rId q mId1 - (Nothing, Msg "message 2") <- tryDelPeekMsg ms rId q mId1 - (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms rId q mId2 - (Nothing, Msg "message 3") <- tryDelPeekMsg ms rId q mId2 - Msg "message 3" <- tryPeekMsg ms rId q - (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3 - Nothing <- tryDelMsg ms rId q mId2 - Nothing <- tryDelMsg ms rId q mId3 - Nothing <- tryPeekMsg ms rId q + Msg "message 1" <- tryPeekMsg ms q + Msg "message 1" <- tryPeekMsg ms q + Nothing <- tryDelMsg ms q mId2 + Msg "message 1" <- tryDelMsg ms q mId1 + Nothing <- tryDelMsg ms q mId1 + Msg "message 2" <- tryPeekMsg ms q + Nothing <- tryDelMsg ms q mId1 + (Nothing, Msg "message 2") <- tryDelPeekMsg ms q mId1 + (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2 + (Nothing, Msg "message 3") <- tryDelPeekMsg ms q mId2 + Msg "message 3" <- tryPeekMsg ms q + (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 + Nothing <- tryDelMsg ms q mId2 + Nothing <- tryDelMsg ms q mId3 + Nothing <- tryPeekMsg ms q Just (Message {msgId = mId4}, True) <- write "message 4" - Msg "message 4" <- tryPeekMsg ms rId q + Msg "message 4" <- tryPeekMsg ms q Just (Message {msgId = mId5}, False) <- write "message 5" - (Nothing, Msg "message 4") <- tryDelPeekMsg ms rId q mId3 - (Msg "message 4", Msg "message 5") <- tryDelPeekMsg ms rId q mId4 + (Nothing, Msg "message 4") <- tryDelPeekMsg ms q mId3 + (Msg "message 4", Msg "message 5") <- tryDelPeekMsg ms q mId4 Just (Message {msgId = mId6}, False) <- write "message 6" Just (Message {msgId = mId7}, False) <- write "message 7" Nothing <- write "message 8" - Msg "message 5" <- tryPeekMsg ms rId q - (Nothing, Msg "message 5") <- tryDelPeekMsg ms rId q mId4 - (Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms rId q mId5 - (Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms rId q mId6 - (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms rId q mId7 - (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms rId q mId8 - (Nothing, Nothing) <- tryDelPeekMsg ms rId q mId8 - void $ ExceptT $ deleteQueue ms rId q + Msg "message 5" <- tryPeekMsg ms q + (Nothing, Msg "message 5") <- tryDelPeekMsg ms q mId4 + (Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms q mId5 + (Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms q mId6 + (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms q mId7 + (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId8 + (Nothing, Nothing) <- tryDelPeekMsg ms q mId8 + void $ ExceptT $ deleteQueue ms q -testChangeReadJournal :: STMQueueStore s => s -> IO () +testChangeReadJournal :: STMStoreClass s => s -> IO () testChangeReadJournal ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True runRight_ $ do - q <- ExceptT $ addQueue ms qr - let write s = writeMsg ms rId q True =<< mkMessage s + q <- ExceptT $ addQueue ms rId qr + let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" - (Msg "message 1", Nothing) <- tryDelPeekMsg ms rId q mId1 + (Msg "message 1", Nothing) <- tryDelPeekMsg ms q mId1 Just (Message {msgId = mId2}, True) <- write "message 2" - (Msg "message 2", Nothing) <- tryDelPeekMsg ms rId q mId2 + (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 Just (Message {msgId = mId3}, True) <- write "message 3" - (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3 + (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 Just (Message {msgId = mId4}, True) <- write "message 4" - (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId q mId4 + (Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4 Just (Message {msgId = mId5}, True) <- write "message 5" - (Msg "message 5", Nothing) <- tryDelPeekMsg ms rId q mId5 - void $ ExceptT $ deleteQueue ms rId q + (Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5 + void $ ExceptT $ deleteQueue ms q testExportImportStore :: JournalMsgStore -> IO () testExportImportStore ms = do @@ -185,21 +184,21 @@ testExportImportStore ms = do (rId2, qr2) <- testNewQueueRec g True sl <- readWriteQueueStore testStoreLogFile ms runRight_ $ do - let write rId q s = writeMsg ms rId q True =<< mkMessage s - q1 <- ExceptT $ addQueue ms qr1 - liftIO $ logCreateQueue sl qr1 - Just (Message {}, True) <- write rId1 q1 "message 1" - Just (Message {}, False) <- write rId1 q1 "message 2" - q2 <- ExceptT $ addQueue ms qr2 - liftIO $ logCreateQueue sl qr2 - Just (Message {msgId = mId3}, True) <- write rId2 q2 "message 3" - Just (Message {msgId = mId4}, False) <- write rId2 q2 "message 4" - (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms rId2 q2 mId3 - (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId2 q2 mId4 - Just (Message {}, True) <- write rId2 q2 "message 5" - Just (Message {}, False) <- write rId2 q2 "message 6" - Just (Message {}, False) <- write rId2 q2 "message 7" - Nothing <- write rId2 q2 "message 8" + let write q s = writeMsg ms q True =<< mkMessage s + q1 <- ExceptT $ addQueue ms rId1 qr1 + liftIO $ logCreateQueue sl rId1 qr1 + Just (Message {}, True) <- write q1 "message 1" + Just (Message {}, False) <- write q1 "message 2" + q2 <- ExceptT $ addQueue ms rId2 qr2 + liftIO $ logCreateQueue sl rId2 qr2 + Just (Message {msgId = mId3}, True) <- write q2 "message 3" + Just (Message {msgId = mId4}, False) <- write q2 "message 4" + (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q2 mId3 + (Msg "message 4", Nothing) <- tryDelPeekMsg ms q2 mId4 + Just (Message {}, True) <- write q2 "message 5" + Just (Message {}, False) <- write q2 "message 6" + Just (Message {}, False) <- write q2 "message 7" + Nothing <- write q2 "message 8" pure () length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 @@ -297,10 +296,10 @@ testMessageState ms = do (rId, qr) <- testNewQueueRec g True let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) - write q s = writeMsg ms rId q True =<< mkMessage s + write q s = writeMsg ms q True =<< mkMessage s mId1 <- runRight $ do - q <- ExceptT $ addQueue ms qr + q <- ExceptT $ addQueue ms rId qr Just (Message {msgId = mId1}, True) <- write q "message 1" Just (Message {}, False) <- write q "message 2" liftIO $ closeMsgQueue q @@ -312,19 +311,19 @@ testMessageState ms = do runRight_ $ do q <- ExceptT $ getQueue ms SRecipient rId Just (Message {msgId = mId3}, False) <- write q "message 3" - (Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms rId q mId1 - (Msg "message 3", Nothing) <- tryDelPeekMsg ms rId q mId3 + (Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms q mId1 + (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 liftIO $ closeMsgQueue q testReadFileMissing :: JournalMsgStore -> IO () testReadFileMissing ms = do g <- C.newRandom (rId, qr) <- testNewQueueRec g True - let write q s = writeMsg ms rId q True =<< mkMessage s + let write q s = writeMsg ms q True =<< mkMessage s q <- runRight $ do - q <- ExceptT $ addQueue ms qr + q <- ExceptT $ addQueue ms rId qr Just (Message {}, True) <- write q "message 1" - Msg "message 1" <- tryPeekMsg ms rId q + Msg "message 1" <- tryPeekMsg ms q pure q mq <- fromJust <$> readTVarIO (msgQueue_' q) @@ -335,9 +334,9 @@ testReadFileMissing ms = do runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Nothing <- tryPeekMsg ms rId q' + Nothing <- tryPeekMsg ms q' Just (Message {}, True) <- write q' "message 2" - Msg "message 2" <- tryPeekMsg ms rId q' + Msg "message 2" <- tryPeekMsg ms q' pure () testReadFileMissingSwitch :: JournalMsgStore -> IO () @@ -354,8 +353,8 @@ testReadFileMissingSwitch ms = do runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Just (Message {}, False) <- writeMsg ms rId q' True =<< mkMessage "message 6" - Msg "message 5" <- tryPeekMsg ms rId q' + Just (Message {}, False) <- writeMsg ms q' True =<< mkMessage "message 6" + Msg "message 5" <- tryPeekMsg ms q' pure () testWriteFileMissing :: JournalMsgStore -> IO () @@ -373,12 +372,12 @@ testWriteFileMissing ms = do runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Just Message {msgId = mId3} <- tryPeekMsg ms rId q' - (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms rId q' mId3 - Just Message {msgId = mId4} <- tryPeekMsg ms rId q' - (Msg "message 4", Nothing) <- tryDelPeekMsg ms rId q' mId4 - Just (Message {}, True) <- writeMsg ms rId q' True =<< mkMessage "message 6" - Msg "message 6" <- tryPeekMsg ms rId q' + Just Message {msgId = mId3} <- tryPeekMsg ms q' + (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q' mId3 + Just Message {msgId = mId4} <- tryPeekMsg ms q' + (Msg "message 4", Nothing) <- tryDelPeekMsg ms q' mId4 + Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6" + Msg "message 6" <- tryPeekMsg ms q' pure () testReadAndWriteFilesMissing :: JournalMsgStore -> IO () @@ -395,20 +394,20 @@ testReadAndWriteFilesMissing ms = do runRight_ $ do q' <- ExceptT $ getQueue ms SRecipient rId - Nothing <- tryPeekMsg ms rId q' - Just (Message {}, True) <- writeMsg ms rId q' True =<< mkMessage "message 6" - Msg "message 6" <- tryPeekMsg ms rId q' + Nothing <- tryPeekMsg ms q' + Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6" + Msg "message 6" <- tryPeekMsg ms q' pure () writeMessages :: JournalMsgStore -> RecipientId -> QueueRec -> IO JournalQueue writeMessages ms rId qr = runRight $ do - q <- ExceptT $ addQueue ms qr - let write s = writeMsg ms rId q True =<< mkMessage s + q <- ExceptT $ addQueue ms rId qr + let write s = writeMsg ms q True =<< mkMessage s Just (Message {msgId = mId1}, True) <- write "message 1" Just (Message {msgId = mId2}, False) <- write "message 2" Just (Message {}, False) <- write "message 3" - (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms rId q mId1 - (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms rId q mId2 + (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 + (Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2 Just (Message {}, False) <- write "message 4" Just (Message {}, False) <- write "message 5" pure q diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 90bea0192..f62fb808f 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -60,38 +60,38 @@ storeLogTests = ("SMP server store log, sndSecure = " <> show sndSecure) [ SLTC { name = "create new queue", - saved = [CreateQueue qr], - compacted = [CreateQueue qr], + saved = [CreateQueue rId qr], + compacted = [CreateQueue rId qr], state = M.fromList [(rId, qr)] }, SLTC { name = "secure queue", - saved = [CreateQueue qr, SecureQueue rId testPublicAuthKey], - compacted = [CreateQueue qr {senderKey = Just testPublicAuthKey}], + saved = [CreateQueue rId qr, SecureQueue rId testPublicAuthKey], + compacted = [CreateQueue rId qr {senderKey = Just testPublicAuthKey}], state = M.fromList [(rId, qr {senderKey = Just testPublicAuthKey})] }, SLTC { name = "create and delete queue", - saved = [CreateQueue qr, DeleteQueue rId], + saved = [CreateQueue rId qr, DeleteQueue rId], compacted = [], state = M.fromList [] }, SLTC { name = "create queue and add notifier", - saved = [CreateQueue qr, AddNotifier rId ntfCreds], - compacted = [CreateQueue $ qr {notifier = Just ntfCreds}], + saved = [CreateQueue rId qr, AddNotifier rId ntfCreds], + compacted = [CreateQueue rId qr {notifier = Just ntfCreds}], state = M.fromList [(rId, qr {notifier = Just ntfCreds})] }, SLTC { name = "delete notifier", - saved = [CreateQueue qr, AddNotifier rId ntfCreds, DeleteNotifier rId], - compacted = [CreateQueue qr], + saved = [CreateQueue rId qr, AddNotifier rId ntfCreds, DeleteNotifier rId], + compacted = [CreateQueue rId qr], state = M.fromList [(rId, qr)] }, SLTC { name = "update time", - saved = [CreateQueue qr, UpdateTime rId date], - compacted = [CreateQueue qr {updatedAt = Just date}], + saved = [CreateQueue rId qr, UpdateTime rId date], + compacted = [CreateQueue rId qr {updatedAt = Just date}], state = M.fromList [(rId, qr {updatedAt = Just date})] } ] @@ -112,4 +112,4 @@ testSMPStoreLog testSuite tests = ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile compacted' `shouldBe` compacted storeState :: JournalMsgStore -> IO (M.Map RecipientId QueueRec) - storeState st = M.mapMaybe id <$> (readTVarIO (queues st) >>= mapM (readTVarIO . queueRec')) + storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec')) From 944a22a2fb96dc6346e186c48960a7431b9dd191 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 6 Feb 2025 17:11:35 +0000 Subject: [PATCH 27/51] ntf server: record token invalidation reason, add date of the last token activity (#1449) * ntf server: record token invalidation reason, add date of the last token activity * update time * rename * optional * include token ID in delivery error * version * protocol version * fix, log error --- simplexmq.cabal | 2 +- .../Messaging/Notifications/Protocol.hs | 39 +++++++-- src/Simplex/Messaging/Notifications/Server.hs | 77 +++++++++------- .../Messaging/Notifications/Server/Env.hs | 2 +- .../Notifications/Server/Push/APNS.hs | 8 +- .../Messaging/Notifications/Server/Store.hs | 20 +++-- .../Notifications/Server/StoreLog.hs | 87 +++++++++++-------- .../Messaging/Notifications/Transport.hs | 7 +- 8 files changed, 153 insertions(+), 89 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 7bdc8add2..fd42fb016 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.3 +version: 6.3.0.301 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 642465883..879538505 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -11,7 +11,7 @@ module Simplex.Messaging.Notifications.Protocol where -import Control.Applicative ((<|>)) +import Control.Applicative (optional, (<|>)) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE @@ -32,7 +32,7 @@ import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Transport (NTFVersion, ntfClientHandshake) +import Simplex.Messaging.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake) import Simplex.Messaging.Parsers (fromTextField_) import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..)) import Simplex.Messaging.Util (eitherToMaybe, (<$?>)) @@ -296,12 +296,18 @@ data NtfResponse instance ProtocolEncoding NTFVersion ErrorType NtfResponse where type Tag NtfResponse = NtfResponseTag - encodeProtocol _v = \case + encodeProtocol v = \case NRTknId entId dhKey -> e (NRTknId_, ' ', entId, dhKey) NRSubId entId -> e (NRSubId_, ' ', entId) NROk -> e NROk_ NRErr err -> e (NRErr_, ' ', err) - NRTkn stat -> e (NRTkn_, ' ', stat) + NRTkn stat -> e (NRTkn_, ' ', stat') + where + stat' + | v >= invalidReasonNTFVersion = stat + | otherwise = case stat of + NTInvalid _ -> NTInvalid Nothing + _ -> stat NRSub stat -> e (NRSub_, ' ', stat) NRPong -> e NRPong_ where @@ -520,7 +526,7 @@ data NtfTknStatus | -- | state after registration (TNEW) NTRegistered | -- | if initial notification failed (push provider error) or verification failed - NTInvalid + NTInvalid (Maybe NTInvalidReason) | -- | Token confirmed via notification (accepted by push provider or verification code received by client) NTConfirmed | -- | after successful verification (TVFY) @@ -533,7 +539,7 @@ instance Encoding NtfTknStatus where smpEncode = \case NTNew -> "NEW" NTRegistered -> "REGISTERED" - NTInvalid -> "INVALID" + NTInvalid r_ -> "INVALID" <> maybe "" (\r -> ',' `B.cons` strEncode r) r_ NTConfirmed -> "CONFIRMED" NTActive -> "ACTIVE" NTExpired -> "EXPIRED" @@ -541,12 +547,31 @@ instance Encoding NtfTknStatus where A.takeTill (== ' ') >>= \case "NEW" -> pure NTNew "REGISTERED" -> pure NTRegistered - "INVALID" -> pure NTInvalid + "INVALID" -> NTInvalid <$> optional (A.char ',' *> strP) "CONFIRMED" -> pure NTConfirmed "ACTIVE" -> pure NTActive "EXPIRED" -> pure NTExpired _ -> fail "bad NtfTknStatus" +instance StrEncoding NTInvalidReason where + strEncode = smpEncode + strP = smpP + +data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRGone410 + deriving (Eq, Show) + +instance Encoding NTInvalidReason where + smpEncode = \case + NTIRBadToken -> "BAD" + NTIRTokenNotForTopic -> "TOPIC" + NTIRGone410 -> "GONE" + smpP = + A.takeTill (== ' ') >>= \case + "BAD" -> pure NTIRBadToken + "TOPIC" -> pure NTIRTokenNotForTopic + "GONE" -> pure NTIRGone410 + _ -> fail "bad NTInvalidReason" + instance StrEncoding NtfTknStatus where strEncode = smpEncode strP = smpP diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index ca24a2318..50dd22d77 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -58,6 +58,7 @@ import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Control (CPClientRole (..)) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getSystemDate) import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, updatePeriodStats) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -435,17 +436,19 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) status <- readTVarIO tknStatus case ntf of - PNVerification _ - | status /= NTInvalid && status /= NTExpired -> - deliverNotification pp tkn ntf >>= \case - Right _ -> do - status_ <- atomically $ stateTVar tknStatus $ \case - NTActive -> (Nothing, NTActive) - NTConfirmed -> (Nothing, NTConfirmed) - _ -> (Just NTConfirmed, NTConfirmed) - forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status' - _ -> pure () - | otherwise -> logError "bad notification token status" + PNVerification _ -> case status of + NTInvalid _ -> logError $ "bad notification token status: " <> tshow status + -- TODO nothing makes token "expired" on the server + NTExpired -> logError $ "bad notification token status: " <> tshow status + _ -> + deliverNotification pp tkn ntf >>= \case + Right _ -> do + status_ <- atomically $ stateTVar tknStatus $ \case + NTActive -> (Nothing, NTActive) + NTConfirmed -> (Nothing, NTConfirmed) + _ -> (Just NTConfirmed, NTConfirmed) + forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status' + _ -> pure () PNCheckMessages -> checkActiveTkn status $ do void $ deliverNotification pp tkn ntf PNMessage {} -> checkActiveTkn status $ do @@ -459,7 +462,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do | status == NTActive = action | otherwise = liftIO $ logError "bad notification token status" deliverNotification :: PushProvider -> NtfTknData -> PushNotification -> M (Either PushProviderError ()) - deliverNotification pp tkn ntf = do + deliverNotification pp tkn@NtfTknData {ntfTknId} ntf = do deliver <- liftIO $ getPushClient s pp liftIO (runExceptT $ deliver tkn ntf) >>= \case Right _ -> pure $ Right () @@ -468,14 +471,14 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do PPRetryLater -> retryDeliver PPCryptoError _ -> err e PPResponseError _ _ -> err e - PPTokenInvalid -> updateTknStatus tkn NTInvalid >> err e + PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e PPPermanentError -> err e where retryDeliver :: M (Either PushProviderError ()) retryDeliver = do deliver <- liftIO $ newPushClient s pp liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right) - err e = logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) $> Left e + err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e updateTknStatus :: NtfTknData -> NtfTknStatus -> M () updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do @@ -509,13 +512,17 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ where cmdAction t@(_, _, (corrId, entId, cmdOrError)) = case cmdOrError of - Left e -> pure $ Left (corrId, entId, NRErr e) + Left e -> do + logError $ "invalid client request: " <> tshow e + pure $ Left (corrId, entId, NRErr e) Right cmd -> - verified <$> verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd + verified =<< verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd where verified = \case - VRVerified req -> Right req - VRFailed -> Left (corrId, entId, NRErr AUTH) + VRVerified req -> pure $ Right req + VRFailed -> do + logError "unauthorized client request" + pure $ Left (corrId, entId, NRErr AUTH) write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO () @@ -524,7 +531,7 @@ send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do void . liftIO $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime -data VerificationResult = VRVerified NtfRequest | VRFailed +data VerificationResult = VRVerified (Maybe NtfTknData, NtfRequest) | VRFailed verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do @@ -538,34 +545,34 @@ verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do Just t@NtfTknData {tknVerifyKey} | k == tknVerifyKey -> verifiedTknCmd t c | otherwise -> VRFailed - _ -> VRVerified (NtfReqNew corrId (ANE SToken tkn)) + Nothing -> VRVerified (Nothing, NtfReqNew corrId (ANE SToken tkn)) else VRFailed NtfCmd SToken c -> do - t_ <- atomically $ getNtfToken st entId + t_ <- liftIO $ getNtfTokenIO st entId verifyToken t_ (`verifiedTknCmd` c) NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> do s_ <- atomically $ findNtfSubscription st smpQueue case s_ of Nothing -> do t_ <- atomically $ getActiveNtfToken st tknId - verifyToken' t_ $ VRVerified (NtfReqNew corrId (ANE SSubscription sub)) + verifyToken' t_ $ VRVerified (t_, NtfReqNew corrId (ANE SSubscription sub)) Just s@NtfSubData {tokenId = subTknId} -> if subTknId == tknId then do t_ <- atomically $ getActiveNtfToken st subTknId - verifyToken' t_ $ verifiedSubCmd s c + verifyToken' t_ $ verifiedSubCmd t_ s c else pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed - NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId + NtfCmd SSubscription PING -> pure $ VRVerified (Nothing, NtfReqPing corrId entId) NtfCmd SSubscription c -> do - s_ <- atomically $ getNtfSubscription st entId + s_ <- liftIO $ getNtfSubscriptionIO st entId case s_ of Just s@NtfSubData {tokenId = subTknId} -> do t_ <- atomically $ getActiveNtfToken st subTknId - verifyToken' t_ $ verifiedSubCmd s c + verifyToken' t_ $ verifiedSubCmd t_ s c _ -> pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed where - verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c)) - verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)) + verifiedTknCmd t c = VRVerified (Just t, NtfReqCmd SToken (NtfTkn t) (corrId, entId, c)) + verifiedSubCmd t_ s c = VRVerified (t_, NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)) verifyToken :: Maybe NtfTknData -> (NtfTknData -> VerificationResult) -> M VerificationResult verifyToken t_ positiveVerificationResult = pure $ case t_ of @@ -579,11 +586,18 @@ verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M () client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} = - forever $ + forever $ do + ts <- liftIO getSystemDate atomically (readTBQueue rcvQ) - >>= mapM processCommand + >>= mapM (\(tkn_, req) -> updateTokenDate ts tkn_ >> processCommand req) >>= atomically . writeTBQueue sndQ where + updateTokenDate :: RoundedSystemTime -> Maybe NtfTknData -> M () + updateTokenDate ts' = mapM_ $ \NtfTknData {ntfTknId, tknUpdatedAt} -> do + let t' = Just ts' + t <- atomically $ swapTVar tknUpdatedAt t' + unless (t' == t) $ withNtfLog $ \s -> logUpdateTokenTime s ntfTknId ts' + processCommand :: NtfRequest -> M (Transmission NtfResponse) processCommand = \case NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do @@ -593,7 +607,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu let dhSecret = C.dh' dhPubKey srvDhPrivKey tknId <- getId regCode <- getRegCode - tkn <- atomically $ mkNtfTknData tknId newTkn ks dhSecret regCode + ts <- liftIO $ getSystemDate + tkn <- liftIO $ mkNtfTknData tknId newTkn ks dhSecret regCode ts atomically $ addNtfToken st tknId tkn atomically $ writeTBQueue pushQ (tkn, PNVerification regCode) withNtfLog (`logCreateToken` tkn) diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index bc89c2e34..3859a3df1 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -159,7 +159,7 @@ data NtfRequest | NtfReqPing CorrId NtfEntityId data NtfServerClient = NtfServerClient - { rcvQ :: TBQueue (NonEmpty NtfRequest), + { rcvQ :: TBQueue (NonEmpty (Maybe NtfTknData, NtfRequest)), sndQ :: TBQueue (NonEmpty (Transmission NtfResponse)), ntfThParams :: THandleParams NTFVersion 'TServer, connected :: TVar Bool, diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 3b8ae1af1..6be4823cd 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -308,7 +308,7 @@ data PushProviderError = PPConnection HTTP2ClientError | PPCryptoError C.CryptoError | PPResponseError (Maybe Status) Text - | PPTokenInvalid + | PPTokenInvalid NTInvalidReason | PPRetryLater | PPPermanentError deriving (Show, Exception) @@ -338,15 +338,15 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke | status == Just N.ok200 = pure () | status == Just N.badRequest400 = case reason' of - "BadDeviceToken" -> throwE PPTokenInvalid - "DeviceTokenNotForTopic" -> throwE PPTokenInvalid + "BadDeviceToken" -> throwE $ PPTokenInvalid NTIRBadToken + "DeviceTokenNotForTopic" -> throwE $ PPTokenInvalid NTIRTokenNotForTopic "TopicDisallowed" -> throwE PPPermanentError _ -> err status reason' | status == Just N.forbidden403 = case reason' of "ExpiredProviderToken" -> throwE PPPermanentError -- there should be no point retrying it as the token was refreshed "InvalidProviderToken" -> throwE PPPermanentError _ -> err status reason' - | status == Just N.gone410 = throwE PPTokenInvalid + | status == Just N.gone410 = throwE $ PPTokenInvalid NTIRGone410 | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater -- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token | otherwise = err status reason' diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs index 41f181df6..259a933b6 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store.hs @@ -25,6 +25,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (whenM, ($>>=)) @@ -57,14 +58,16 @@ data NtfTknData = NtfTknData tknDhKeys :: C.KeyPair 'C.X25519, tknDhSecret :: C.DhSecretX25519, tknRegCode :: NtfRegCode, - tknCronInterval :: TVar Word16 + tknCronInterval :: TVar Word16, + tknUpdatedAt :: TVar (Maybe RoundedSystemTime) } -mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData -mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do - tknStatus <- newTVar NTRegistered - tknCronInterval <- newTVar 0 - pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} +mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> RoundedSystemTime -> IO NtfTknData +mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode ts = do + tknStatus <- newTVarIO NTRegistered + tknCronInterval <- newTVarIO 0 + tknUpdatedAt <- newTVarIO $ Just ts + pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} data NtfSubData = NtfSubData { ntfSubId :: NtfSubscriptionId, @@ -156,9 +159,8 @@ deleteTokenSubs st tknId = do $>>= \NtfSubData {smpQueue} -> TM.delete smpQueue (subscriptionLookup st) $> Just smpQueue -getNtfSubscription :: NtfStore -> NtfSubscriptionId -> STM (Maybe NtfSubData) -getNtfSubscription st subId = - TM.lookup subId (subscriptions st) +getNtfSubscriptionIO :: NtfStore -> NtfSubscriptionId -> IO (Maybe NtfSubData) +getNtfSubscriptionIO st subId = TM.lookupIO subId (subscriptions st) findNtfSubscription :: NtfStore -> SMPQueueNtf -> STM (Maybe NtfSubData) findNtfSubscription st smpQueue = do diff --git a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs index a0dbb1fee..fa0ae373c 100644 --- a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs @@ -16,6 +16,7 @@ module Simplex.Messaging.Notifications.Server.StoreLog logUpdateToken, logTokenCron, logDeleteToken, + logUpdateTokenTime, logCreateSubscription, logSubscriptionStatus, logDeleteSubscription, @@ -23,6 +24,7 @@ module Simplex.Messaging.Notifications.Server.StoreLog ) where +import Control.Applicative (optional) import Control.Concurrent.STM import Control.Logger.Simple import Control.Monad @@ -36,6 +38,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Store import Simplex.Messaging.Protocol (NtfPrivateAuthKey) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (safeDecodeUtf8) import System.IO @@ -46,6 +49,7 @@ data NtfStoreLogRecord | UpdateToken NtfTokenId DeviceToken NtfRegCode | TokenCron NtfTokenId Word16 | DeleteToken NtfTokenId + | UpdateTokenTime NtfTokenId RoundedSystemTime | CreateSubscription NtfSubRec | SubscriptionStatus NtfSubscriptionId NtfSubStatus | DeleteSubscription NtfSubscriptionId @@ -59,21 +63,24 @@ data NtfTknRec = NtfTknRec tknDhKeys :: C.KeyPair 'C.X25519, tknDhSecret :: C.DhSecretX25519, tknRegCode :: NtfRegCode, - tknCronInterval :: Word16 + tknCronInterval :: Word16, + tknUpdatedAt :: Maybe RoundedSystemTime } deriving (Show) -mkTknData :: NtfTknRec -> STM NtfTknData -mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do - tknStatus <- newTVar status - tknCronInterval <- newTVar cronInt - pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} +mkTknData :: NtfTknRec -> IO NtfTknData +mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do + tknStatus <- newTVarIO status + tknCronInterval <- newTVarIO cronInt + tknUpdatedAt <- newTVarIO updatedAt + pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} -mkTknRec :: NtfTknData -> STM NtfTknRec -mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do - tknStatus <- readTVar status - tknCronInterval <- readTVar cronInt - pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} +mkTknRec :: NtfTknData -> IO NtfTknRec +mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt, tknUpdatedAt = updatedAt} = do + tknStatus <- readTVarIO status + tknCronInterval <- readTVarIO cronInt + tknUpdatedAt <- readTVarIO updatedAt + pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} data NtfSubRec = NtfSubRec { ntfSubId :: NtfSubscriptionId, @@ -84,9 +91,9 @@ data NtfSubRec = NtfSubRec } deriving (Show) -mkSubData :: NtfSubRec -> STM NtfSubData +mkSubData :: NtfSubRec -> IO NtfSubData mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do - subStatus <- newTVar status + subStatus <- newTVarIO status pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} mkSubRec :: NtfSubData -> STM NtfSubRec @@ -101,6 +108,7 @@ instance StrEncoding NtfStoreLogRecord where UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode) TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt) DeleteToken tknId -> strEncode (Str "TDELETE", tknId) + UpdateTokenTime tknId ts -> strEncode (Str "TTIME", tknId, ts) CreateSubscription subRec -> strEncode (Str "SCREATE", subRec) SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus) DeleteSubscription subId -> strEncode (Str "SDELETE", subId) @@ -111,13 +119,14 @@ instance StrEncoding NtfStoreLogRecord where "TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP), "TCRON " *> (TokenCron <$> strP_ <*> strP), "TDELETE " *> (DeleteToken <$> strP), + "TTIME " *> (UpdateTokenTime <$> strP_ <*> strP), "SCREATE " *> (CreateSubscription <$> strP), "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP), "SDELETE " *> (DeleteSubscription <$> strP) ] instance StrEncoding NtfTknRec where - strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} = + strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} = B.unwords [ "tknId=" <> strEncode ntfTknId, "token=" <> strEncode token, @@ -128,6 +137,9 @@ instance StrEncoding NtfTknRec where "regCode=" <> strEncode tknRegCode, "cron=" <> strEncode tknCronInterval ] + <> maybe "" updatedAtStr tknUpdatedAt + where + updatedAtStr t = " updatedAt=" <> strEncode t strP = do ntfTknId <- "tknId=" *> strP_ token <- "token=" *> strP_ @@ -137,7 +149,8 @@ instance StrEncoding NtfTknRec where tknDhSecret <- "dhSecret=" *> strP_ tknRegCode <- "regCode=" *> strP_ tknCronInterval <- "cron=" *> strP - pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} + tknUpdatedAt <- optional $ " updatedAt=" *> strP + pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} instance StrEncoding NtfSubRec where strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} = @@ -161,7 +174,7 @@ logNtfStoreRecord = writeStoreLogRecord {-# INLINE logNtfStoreRecord #-} logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO () -logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< atomically (mkTknRec tkn) +logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< mkTknRec tkn logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO () logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus @@ -175,6 +188,9 @@ logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO () logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId +logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> RoundedSystemTime -> IO () +logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t + logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO () logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub) @@ -192,36 +208,39 @@ readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.read where addNtfLogRecord s = case strDecode s of Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s) - Right lr -> atomically $ case lr of + Right lr -> case lr of CreateToken r@NtfTknRec {ntfTknId} -> do tkn <- mkTknData r - addNtfToken st ntfTknId tkn + atomically $ addNtfToken st ntfTknId tkn TokenStatus tknId status -> do - tkn_ <- getNtfToken st tknId + tkn_ <- getNtfTokenIO st tknId forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do - writeTVar tknStatus status - when (status == NTActive) $ void $ removeInactiveTokenRegistrations st tkn - UpdateToken tknId token' tknRegCode -> - getNtfToken st tknId + atomically $ writeTVar tknStatus status + when (status == NTActive) $ void $ atomically $ removeInactiveTokenRegistrations st tkn + UpdateToken tknId token' tknRegCode -> do + getNtfTokenIO st tknId >>= mapM_ ( \tkn@NtfTknData {tknStatus} -> do - removeTokenRegistration st tkn - writeTVar tknStatus NTRegistered - addNtfToken st tknId tkn {token = token', tknRegCode} + atomically $ removeTokenRegistration st tkn + atomically $ writeTVar tknStatus NTRegistered + atomically $ addNtfToken st tknId tkn {token = token', tknRegCode} ) TokenCron tknId cronInt -> - getNtfToken st tknId - >>= mapM_ (\NtfTknData {tknCronInterval} -> writeTVar tknCronInterval cronInt) + getNtfTokenIO st tknId + >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt) DeleteToken tknId -> - void $ deleteNtfToken st tknId + atomically $ void $ deleteNtfToken st tknId + UpdateTokenTime tknId t -> + getNtfTokenIO st tknId + >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t) CreateSubscription r@NtfSubRec {ntfSubId} -> do sub <- mkSubData r - void $ addNtfSubscription st ntfSubId sub - SubscriptionStatus subId status -> - getNtfSubscription st subId - >>= mapM_ (\NtfSubData {subStatus} -> writeTVar subStatus status) + void $ atomically $ addNtfSubscription st ntfSubId sub + SubscriptionStatus subId status -> do + getNtfSubscriptionIO st subId + >>= mapM_ (\NtfSubData {subStatus} -> atomically $ writeTVar subStatus status) DeleteSubscription subId -> - deleteNtfSubscription st subId + atomically $ deleteNtfSubscription st subId writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO () writeNtfStore s NtfStore {tokens, subscriptions} = do diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index fc928535d..a563a2689 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -44,11 +44,14 @@ initialNTFVersion = VersionNTF 1 authBatchCmdsNTFVersion :: VersionNTF authBatchCmdsNTFVersion = VersionNTF 2 +invalidReasonNTFVersion :: VersionNTF +invalidReasonNTFVersion = VersionNTF 3 + currentClientNTFVersion :: VersionNTF -currentClientNTFVersion = VersionNTF 2 +currentClientNTFVersion = VersionNTF 3 currentServerNTFVersion :: VersionNTF -currentServerNTFVersion = VersionNTF 2 +currentServerNTFVersion = VersionNTF 3 supportedClientNTFVRange :: VersionRangeNTF supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion From b633f89c1a51b00b630be74893d464a8e3a4d8bf Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 7 Feb 2025 15:36:29 +0400 Subject: [PATCH 28/51] agent: check ntf token status on registration (#1450) * agent: check ntf token status on registration * remove check * update on check * refactor * version * fix * test, verify invalid * rename * increase delay * disable new tests in CI * fix --------- Co-authored-by: Evgeny Poberezkin --- simplexmq.cabal | 2 +- src/Simplex/Messaging/Agent.hs | 30 +++++---- src/Simplex/Messaging/Notifications/Server.hs | 22 +++---- tests/AgentTests/NotificationTests.hs | 65 ++++++++++++++++++- 4 files changed, 92 insertions(+), 27 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index fd42fb016..7bdc8add2 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.301 +version: 6.3.0.3 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 2ff0d2ab2..ed516e50a 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1946,7 +1946,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = -- possible improvement: add minimal time before repeat registration (Just tknId, Nothing) | savedDeviceToken == suppliedDeviceToken -> - when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered + registerToken tkn $> NTRegistered | otherwise -> replaceToken tknId (Just tknId, Just (NTAVerify code)) | savedDeviceToken == suppliedDeviceToken -> @@ -1955,14 +1955,16 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = (Just tknId, Just NTACheck) | savedDeviceToken == suppliedDeviceToken -> do ns <- asks ntfSupervisor - atomically $ nsUpdateToken ns tkn {ntfMode = suppliedNtfMode} - when (ntfTknStatus == NTActive) $ do - cron <- asks $ ntfCron . config - agentNtfEnableCron c tknId tkn cron - when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c - when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete - -- possible improvement: get updated token status from the server, or maybe TCRON could return the current status - pure ntfTknStatus + let tkn' = tkn {ntfMode = suppliedNtfMode} + atomically $ nsUpdateToken ns tkn' + agentNtfCheckToken c tknId tkn' >>= \case + NTActive -> do + cron <- asks $ ntfCron . config + agentNtfEnableCron c tknId tkn cron + when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c + when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete + t tkn' (NTActive, Just NTACheck) $ pure () + status -> t tkn' (status, Nothing) $ pure () | otherwise -> replaceToken tknId -- deprecated (Just _tknId, Just NTADelete) -> deleteToken c tkn $> NTExpired @@ -2029,9 +2031,15 @@ verifyNtfToken' c deviceToken nonce code = checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus checkNtfToken' c deviceToken = withStore' c getSavedNtfToken >>= \case - Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId} -> do + Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfTknAction} -> do when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "checkNtfToken: different token" - agentNtfCheckToken c tknId tkn + status <- agentNtfCheckToken c tknId tkn + let action = case status of + NTInvalid _ -> Nothing + NTExpired -> Nothing + _ -> ntfTknAction + withStore' c $ \db -> updateNtfToken db tkn status action + pure status _ -> throwE $ CMD PROHIBITED "checkNtfToken: no token" deleteNtfToken' :: AgentClient -> DeviceToken -> AM () diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 50dd22d77..12a7e0f7b 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -436,19 +436,15 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) status <- readTVarIO tknStatus case ntf of - PNVerification _ -> case status of - NTInvalid _ -> logError $ "bad notification token status: " <> tshow status - -- TODO nothing makes token "expired" on the server - NTExpired -> logError $ "bad notification token status: " <> tshow status - _ -> - deliverNotification pp tkn ntf >>= \case - Right _ -> do - status_ <- atomically $ stateTVar tknStatus $ \case - NTActive -> (Nothing, NTActive) - NTConfirmed -> (Nothing, NTConfirmed) - _ -> (Just NTConfirmed, NTConfirmed) - forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status' - _ -> pure () + PNVerification _ -> + deliverNotification pp tkn ntf >>= \case + Right _ -> do + status_ <- atomically $ stateTVar tknStatus $ \case + NTActive -> (Nothing, NTActive) + NTConfirmed -> (Nothing, NTConfirmed) + _ -> (Just NTConfirmed, NTConfirmed) + forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status' + _ -> pure () PNCheckMessages -> checkActiveTkn status $ do void $ deliverNotification pp tkn ntf PNMessage {} -> checkActiveTkn status $ do diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 9ad97fe1f..cbca52df1 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -53,18 +53,21 @@ 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 Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.IO as TIO import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, testStoreMsgsDir2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, xit'') import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT) import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken) import Simplex.Messaging.Agent.Store.Common (withTransaction) -import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore) import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol @@ -117,6 +120,12 @@ notificationTests t = do it "should keep working with active token until replaced" $ withAPNSMockServer $ \apns -> testNtfTokenChangeServers t apns + xit'' "should re-register token in NTInvalid status after register attempt" $ + withAPNSMockServer $ \apns -> + testNtfTokenReRegisterInvalid t apns + xit'' "should re-register token in NTInvalid status after checking token" $ + withAPNSMockServer $ \apns -> + testNtfTokenReRegisterInvalidOnCheck t apns describe "notification server tests" $ do it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Nothing let srv1 = testNtfServer {keyHash = "1234"} @@ -459,6 +468,58 @@ testNtfTokenChangeServers t apns = tkn <- registerTestToken a "qwer" NMInstant apns checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive +testNtfTokenReRegisterInvalid :: ATransport -> APNSMockServer -> IO () +testNtfTokenReRegisterInvalid t apns = do + tkn <- withNtfServerStoreLog t $ \_ -> do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do + tkn <- registerTestToken a "abcd" NMInstant apns + NTActive <- checkNtfToken a tkn + pure tkn + + threadDelay 250000 + -- start server to compact + withNtfServerStoreLog t $ \_ -> pure () + + threadDelay 250000 + replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID" + + threadDelay 250000 + withNtfServerStoreLog t $ \_ -> do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do + NTInvalid Nothing <- registerNtfToken a tkn NMInstant + tkn1 <- registerTestToken a "abcd" NMInstant apns + NTActive <- checkNtfToken a tkn1 + pure () + +replaceSubstringInFile :: FilePath -> Text -> Text -> IO () +replaceSubstringInFile filePath oldText newText = do + content <- TIO.readFile filePath + let newContent = T.replace oldText newText content + TIO.writeFile filePath newContent + +testNtfTokenReRegisterInvalidOnCheck :: ATransport -> APNSMockServer -> IO () +testNtfTokenReRegisterInvalidOnCheck t apns = do + tkn <- withNtfServerStoreLog t $ \_ -> do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do + tkn <- registerTestToken a "abcd" NMInstant apns + NTActive <- checkNtfToken a tkn + pure tkn + + threadDelay 250000 + -- start server to compact + withNtfServerStoreLog t $ \_ -> pure () + + threadDelay 250000 + replaceSubstringInFile ntfTestStoreLogFile "tokenStatus=ACTIVE" "tokenStatus=INVALID" + + threadDelay 250000 + withNtfServerStoreLog t $ \_ -> do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do + NTInvalid Nothing <- checkNtfToken a tkn + tkn1 <- registerTestToken a "abcd" NMInstant apns + NTActive <- checkNtfToken a tkn1 + pure () + testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure) testRunNTFServerTests t srv = withNtfServerOn t ntfTestPort $ From 5dbe6337eab6a210d64a3b7cbdad5f0ee107686d Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 7 Feb 2025 12:19:11 +0000 Subject: [PATCH 29/51] ntf server: additional statistics, new invalid token reasons (#1451) * agent: check ntf token status on registration * remove check * update on check * refactor * version * fix * ntf server: additional statistics * swap * version * more stats * test, verify invalid * rename * exclude test token from stats * increase delay * handle invalid token in retry, more reasons * focus tests * disable new tests in CI * fix --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- .../Messaging/Notifications/Protocol.hs | 8 +- src/Simplex/Messaging/Notifications/Server.hs | 65 ++++++-- .../Messaging/Notifications/Server/Main.hs | 2 +- .../Notifications/Server/Push/APNS.hs | 27 ++-- .../Messaging/Notifications/Server/Stats.hs | 148 +++++++++++++++++- 5 files changed, 214 insertions(+), 36 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 879538505..4284a6131 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -557,19 +557,21 @@ instance StrEncoding NTInvalidReason where strEncode = smpEncode strP = smpP -data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRGone410 +data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRExpiredToken | NTIRUnregistered deriving (Eq, Show) instance Encoding NTInvalidReason where smpEncode = \case NTIRBadToken -> "BAD" NTIRTokenNotForTopic -> "TOPIC" - NTIRGone410 -> "GONE" + NTIRExpiredToken -> "EXPIRED" + NTIRUnregistered -> "UNREGISTERED" smpP = A.takeTill (== ' ') >>= \case "BAD" -> pure NTIRBadToken "TOPIC" -> pure NTIRTokenNotForTopic - "GONE" -> pure NTIRGone410 + "EXPIRED" -> pure NTIRExpiredToken + "UNREGISTERED" -> pure NTIRUnregistered _ -> fail "bad NTInvalidReason" instance StrEncoding NtfTknStatus where diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 12a7e0f7b..84aebf9db 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -136,7 +136,8 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime logInfo $ "server stats log enabled: " <> T.pack statsFilePath liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0) - NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats + NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, tknReplaced, subCreated, subDeleted, ntfReceived, ntfDelivered, ntfFailed, ntfCronDelivered, ntfCronFailed, ntfVrfQueued, ntfVrfDelivered, ntfVrfFailed, ntfVrfInvalidTkn, activeTokens, activeSubs} <- + asks serverStats let interval = 1000000 * logInterval forever $ do withFile statsFilePath AppendMode $ \h -> liftIO $ do @@ -146,10 +147,18 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do tknCreated' <- atomicSwapIORef tknCreated 0 tknVerified' <- atomicSwapIORef tknVerified 0 tknDeleted' <- atomicSwapIORef tknDeleted 0 + tknReplaced' <- atomicSwapIORef tknReplaced 0 subCreated' <- atomicSwapIORef subCreated 0 subDeleted' <- atomicSwapIORef subDeleted 0 ntfReceived' <- atomicSwapIORef ntfReceived 0 ntfDelivered' <- atomicSwapIORef ntfDelivered 0 + ntfFailed' <- atomicSwapIORef ntfFailed 0 + ntfCronDelivered' <- atomicSwapIORef ntfCronDelivered 0 + ntfCronFailed' <- atomicSwapIORef ntfCronFailed 0 + ntfVrfQueued' <- atomicSwapIORef ntfVrfQueued 0 + ntfVrfDelivered' <- atomicSwapIORef ntfVrfDelivered 0 + ntfVrfFailed' <- atomicSwapIORef ntfVrfFailed 0 + ntfVrfInvalidTkn' <- atomicSwapIORef ntfVrfInvalidTkn 0 tkn <- liftIO $ periodStatCounts activeTokens ts sub <- liftIO $ periodStatCounts activeSubs ts hPutStrLn h $ @@ -168,7 +177,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do monthCount tkn, dayCount sub, weekCount sub, - monthCount sub + monthCount sub, + show tknReplaced', + show ntfFailed', + show ntfCronDelivered', + show ntfCronFailed', + show ntfVrfQueued', + show ntfVrfDelivered', + show ntfVrfFailed', + show ntfVrfInvalidTkn' ] liftIO $ threadDelay' interval @@ -225,9 +242,18 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do putStat "tknCreated" tknCreated putStat "tknVerified" tknVerified putStat "tknDeleted" tknDeleted + putStat "tknReplaced" tknReplaced putStat "subCreated" subCreated putStat "subDeleted" subDeleted putStat "ntfReceived" ntfReceived + putStat "ntfDelivered" ntfDelivered + putStat "ntfFailed" ntfFailed + putStat "ntfCronDelivered" ntfCronDelivered + putStat "ntfCronFailed" ntfCronFailed + putStat "ntfVrfQueued" ntfVrfQueued + putStat "ntfVrfDelivered" ntfVrfDelivered + putStat "ntfVrfFailed" ntfVrfFailed + putStat "ntfVrfInvalidTkn" ntfVrfInvalidTkn getStat (day . activeTokens) >>= \v -> hPutStrLn h $ "daily active tokens: " <> show (IS.size v) getStat (day . activeSubs) >>= \v -> hPutStrLn h $ "daily active subscriptions: " <> show (IS.size v) CPStatsRTS -> tryAny getRTSStats >>= either (hPrint h) (hPrint h) @@ -242,15 +268,19 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do #else hPutStrLn h "Threads: not available on GHC 8.10" #endif - NtfSubscriber {smpSubscribers, smpAgent = a} <- unliftIO u $ asks subscriber + NtfEnv {subscriber, pushServer} <- unliftIO u ask + let NtfSubscriber {smpSubscribers, smpAgent = a} = subscriber + NtfPushServer {pushQ} = pushServer + SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a putSMPWorkers a "SMP subcscribers" smpSubscribers - let SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a putSMPWorkers a "SMP clients" smpClients putSMPWorkers a "SMP subscription workers" smpSubWorkers sessions <- readTVarIO smpSessions hPutStrLn h $ "SMP sessions count: " <> show (M.size sessions) putSMPSubs a "SMP subscriptions" srvSubs putSMPSubs a "Pending SMP subscriptions" pendingSrvSubs + sz <- atomically $ lengthTBQueue pushQ + hPutStrLn h $ "Push notifications queue length: " <> show sz where putSMPSubs :: SMPClientAgent -> String -> TMap SMPServer (TMap SMPSub a) -> IO () putSMPSubs a name v = do @@ -432,7 +462,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge ntfPush :: NtfPushServer -> M () ntfPush s@NtfPushServer {pushQ} = forever $ do - (tkn@NtfTknData {ntfTknId, token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ) + (tkn@NtfTknData {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ) liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) status <- readTVarIO tknStatus case ntf of @@ -444,14 +474,16 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do NTConfirmed -> (Nothing, NTConfirmed) _ -> (Just NTConfirmed, NTConfirmed) forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status' - _ -> pure () + incNtfStatT t ntfVrfDelivered + Left _ -> incNtfStatT t ntfVrfFailed PNCheckMessages -> checkActiveTkn status $ do - void $ deliverNotification pp tkn ntf + deliverNotification pp tkn ntf + >>= incNtfStatT t . (\case Left _ -> ntfCronFailed; Right () -> ntfCronDelivered) PNMessage {} -> checkActiveTkn status $ do stats <- asks serverStats liftIO $ updatePeriodStats (activeTokens stats) ntfTknId - void $ deliverNotification pp tkn ntf - incNtfStat ntfDelivered + deliverNotification pp tkn ntf + >>= incNtfStatT t . (\case Left _ -> ntfFailed; Right () -> ntfDelivered) where checkActiveTkn :: NtfTknStatus -> M () -> M () checkActiveTkn status action @@ -466,14 +498,18 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do PPConnection _ -> retryDeliver PPRetryLater -> retryDeliver PPCryptoError _ -> err e - PPResponseError _ _ -> err e + PPResponseError {} -> err e PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e PPPermanentError -> err e where retryDeliver :: M (Either PushProviderError ()) retryDeliver = do deliver <- liftIO $ newPushClient s pp - liftIO (runExceptT $ deliver tkn ntf) >>= either err (pure . Right) + liftIO (runExceptT $ deliver tkn ntf) >>= \case + Right _ -> pure $ Right () + Left e -> case e of + PPTokenInvalid r -> updateTknStatus tkn (NTInvalid $ Just r) >> err e + _ -> err e err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e updateTknStatus :: NtfTknData -> NtfTknStatus -> M () @@ -593,7 +629,6 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu let t' = Just ts' t <- atomically $ swapTVar tknUpdatedAt t' unless (t' == t) $ withNtfLog $ \s -> logUpdateTokenTime s ntfTknId ts' - processCommand :: NtfRequest -> M (Transmission NtfResponse) processCommand = \case NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do @@ -607,6 +642,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu tkn <- liftIO $ mkNtfTknData tknId newTkn ks dhSecret regCode ts atomically $ addNtfToken st tknId tkn atomically $ writeTBQueue pushQ (tkn, PNVerification regCode) + incNtfStatT token ntfVrfQueued withNtfLog (`logCreateToken` tkn) incNtfStatT token tknCreated pure (corrId, NoEntity, NRTknId tknId srvDhPubKey) @@ -620,6 +656,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu if tknDhSecret == dhSecret then do atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode) + incNtfStatT token ntfVrfQueued pure $ NRTknId ntfTknId srvDhPubKey else pure $ NRErr AUTH TVFY code -- this allows repeated verification for cases when client connection dropped before server response @@ -647,9 +684,9 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu let tkn' = tkn {token = token', tknRegCode = regCode} addNtfToken st tknId tkn' writeTBQueue pushQ (tkn', PNVerification regCode) + incNtfStatT token ntfVrfQueued withNtfLog $ \s -> logUpdateToken s tknId token' regCode - incNtfStatT token tknDeleted - incNtfStatT token tknCreated + incNtfStatT token tknReplaced pure NROk TDEL -> do logDebug "TDEL" diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 24dd58e8b..b8c7b409c 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -154,7 +154,7 @@ ntfServerCLI cfgPath logPath = regCodeBytes = 32, clientQSize = 64, subQSize = 512, - pushQSize = 1048, + pushQSize = 16384, smpAgentCfg = defaultSMPClientAgentConfig { smpCfg = diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 6be4823cd..ec9cd272c 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -337,19 +337,20 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke result status reason' | status == Just N.ok200 = pure () | status == Just N.badRequest400 = - case reason' of - "BadDeviceToken" -> throwE $ PPTokenInvalid NTIRBadToken - "DeviceTokenNotForTopic" -> throwE $ PPTokenInvalid NTIRTokenNotForTopic - "TopicDisallowed" -> throwE PPPermanentError - _ -> err status reason' - | status == Just N.forbidden403 = case reason' of - "ExpiredProviderToken" -> throwE PPPermanentError -- there should be no point retrying it as the token was refreshed - "InvalidProviderToken" -> throwE PPPermanentError - _ -> err status reason' - | status == Just N.gone410 = throwE $ PPTokenInvalid NTIRGone410 + throwE $ case reason' of + "BadDeviceToken" -> PPTokenInvalid NTIRBadToken + "DeviceTokenNotForTopic" -> PPTokenInvalid NTIRTokenNotForTopic + "TopicDisallowed" -> PPPermanentError + _ -> PPResponseError status reason' + | status == Just N.forbidden403 = throwE $ case reason' of + "ExpiredProviderToken" -> PPPermanentError -- there should be no point retrying it as the token was refreshed + "InvalidProviderToken" -> PPPermanentError + _ -> PPResponseError status reason' + | status == Just N.gone410 = throwE $ case reason' of + "ExpiredToken" -> PPTokenInvalid NTIRExpiredToken + "Unregistered" -> PPTokenInvalid NTIRUnregistered + _ -> PPRetryLater | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater -- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token - | otherwise = err status reason' - err :: Maybe Status -> Text -> ExceptT PushProviderError IO () - err s r = throwE $ PPResponseError s r + | otherwise = throwE $ PPResponseError status reason' liftHTTPS2 a = ExceptT $ first PPConnection <$> a diff --git a/src/Simplex/Messaging/Notifications/Server/Stats.hs b/src/Simplex/Messaging/Notifications/Server/Stats.hs index d05257664..eeff48c76 100644 --- a/src/Simplex/Messaging/Notifications/Server/Stats.hs +++ b/src/Simplex/Messaging/Notifications/Server/Stats.hs @@ -4,7 +4,7 @@ module Simplex.Messaging.Notifications.Server.Stats where -import Control.Applicative (optional) +import Control.Applicative (optional, (<|>)) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.IORef @@ -17,10 +17,18 @@ data NtfServerStats = NtfServerStats tknCreated :: IORef Int, tknVerified :: IORef Int, tknDeleted :: IORef Int, + tknReplaced :: IORef Int, subCreated :: IORef Int, subDeleted :: IORef Int, ntfReceived :: IORef Int, ntfDelivered :: IORef Int, + ntfFailed :: IORef Int, + ntfCronDelivered :: IORef Int, + ntfCronFailed :: IORef Int, + ntfVrfQueued :: IORef Int, + ntfVrfDelivered :: IORef Int, + ntfVrfFailed :: IORef Int, + ntfVrfInvalidTkn :: IORef Int, activeTokens :: PeriodStats, activeSubs :: PeriodStats } @@ -30,10 +38,18 @@ data NtfServerStatsData = NtfServerStatsData _tknCreated :: Int, _tknVerified :: Int, _tknDeleted :: Int, + _tknReplaced :: Int, _subCreated :: Int, _subDeleted :: Int, _ntfReceived :: Int, _ntfDelivered :: Int, + _ntfFailed :: Int, + _ntfCronDelivered :: Int, + _ntfCronFailed :: Int, + _ntfVrfQueued :: Int, + _ntfVrfDelivered :: Int, + _ntfVrfFailed :: Int, + _ntfVrfInvalidTkn :: Int, _activeTokens :: PeriodStatsData, _activeSubs :: PeriodStatsData } @@ -44,13 +60,41 @@ newNtfServerStats ts = do tknCreated <- newIORef 0 tknVerified <- newIORef 0 tknDeleted <- newIORef 0 + tknReplaced <- newIORef 0 subCreated <- newIORef 0 subDeleted <- newIORef 0 ntfReceived <- newIORef 0 ntfDelivered <- newIORef 0 + ntfFailed <- newIORef 0 + ntfCronDelivered <- newIORef 0 + ntfCronFailed <- newIORef 0 + ntfVrfQueued <- newIORef 0 + ntfVrfDelivered <- newIORef 0 + ntfVrfFailed <- newIORef 0 + ntfVrfInvalidTkn <- newIORef 0 activeTokens <- newPeriodStats activeSubs <- newPeriodStats - pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} + pure + NtfServerStats + { fromTime, + tknCreated, + tknVerified, + tknDeleted, + tknReplaced, + subCreated, + subDeleted, + ntfReceived, + ntfDelivered, + ntfFailed, + ntfCronDelivered, + ntfCronFailed, + ntfVrfQueued, + ntfVrfDelivered, + ntfVrfFailed, + ntfVrfInvalidTkn, + activeTokens, + activeSubs + } getNtfServerStatsData :: NtfServerStats -> IO NtfServerStatsData getNtfServerStatsData s@NtfServerStats {fromTime} = do @@ -58,13 +102,41 @@ getNtfServerStatsData s@NtfServerStats {fromTime} = do _tknCreated <- readIORef $ tknCreated s _tknVerified <- readIORef $ tknVerified s _tknDeleted <- readIORef $ tknDeleted s + _tknReplaced <- readIORef $ tknReplaced s _subCreated <- readIORef $ subCreated s _subDeleted <- readIORef $ subDeleted s _ntfReceived <- readIORef $ ntfReceived s _ntfDelivered <- readIORef $ ntfDelivered s + _ntfFailed <- readIORef $ ntfFailed s + _ntfCronDelivered <- readIORef $ ntfCronDelivered s + _ntfCronFailed <- readIORef $ ntfCronFailed s + _ntfVrfQueued <- readIORef $ ntfVrfQueued s + _ntfVrfDelivered <- readIORef $ ntfVrfDelivered s + _ntfVrfFailed <- readIORef $ ntfVrfFailed s + _ntfVrfInvalidTkn <- readIORef $ ntfVrfInvalidTkn s _activeTokens <- getPeriodStatsData $ activeTokens s _activeSubs <- getPeriodStatsData $ activeSubs s - pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} + pure + NtfServerStatsData + { _fromTime, + _tknCreated, + _tknVerified, + _tknDeleted, + _tknReplaced, + _subCreated, + _subDeleted, + _ntfReceived, + _ntfDelivered, + _ntfFailed, + _ntfCronDelivered, + _ntfCronFailed, + _ntfVrfQueued, + _ntfVrfDelivered, + _ntfVrfFailed, + _ntfVrfInvalidTkn, + _activeTokens, + _activeSubs + } -- this function is not thread safe, it is used on server start only setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> IO () @@ -73,24 +145,60 @@ setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} = writeIORef (tknCreated s) $! _tknCreated d writeIORef (tknVerified s) $! _tknVerified d writeIORef (tknDeleted s) $! _tknDeleted d + writeIORef (tknReplaced s) $! _tknReplaced d writeIORef (subCreated s) $! _subCreated d writeIORef (subDeleted s) $! _subDeleted d writeIORef (ntfReceived s) $! _ntfReceived d writeIORef (ntfDelivered s) $! _ntfDelivered d + writeIORef (ntfFailed s) $! _ntfFailed d + writeIORef (ntfCronDelivered s) $! _ntfCronDelivered d + writeIORef (ntfCronFailed s) $! _ntfCronFailed d + writeIORef (ntfVrfQueued s) $! _ntfVrfQueued d + writeIORef (ntfVrfDelivered s) $! _ntfVrfDelivered d + writeIORef (ntfVrfFailed s) $! _ntfVrfFailed d + writeIORef (ntfVrfInvalidTkn s) $! _ntfVrfInvalidTkn d setPeriodStats (activeTokens s) (_activeTokens d) setPeriodStats (activeSubs s) (_activeSubs d) instance StrEncoding NtfServerStatsData where - strEncode NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} = + strEncode + NtfServerStatsData + { _fromTime, + _tknCreated, + _tknVerified, + _tknDeleted, + _tknReplaced, + _subCreated, + _subDeleted, + _ntfReceived, + _ntfDelivered, + _ntfFailed, + _ntfCronDelivered, + _ntfCronFailed, + _ntfVrfQueued, + _ntfVrfDelivered, + _ntfVrfFailed, + _ntfVrfInvalidTkn, + _activeTokens, + _activeSubs + } = B.unlines [ "fromTime=" <> strEncode _fromTime, "tknCreated=" <> strEncode _tknCreated, "tknVerified=" <> strEncode _tknVerified, "tknDeleted=" <> strEncode _tknDeleted, + "tknReplaced=" <> strEncode _tknReplaced, "subCreated=" <> strEncode _subCreated, "subDeleted=" <> strEncode _subDeleted, "ntfReceived=" <> strEncode _ntfReceived, "ntfDelivered=" <> strEncode _ntfDelivered, + "ntfFailed=" <> strEncode _ntfFailed, + "ntfCronDelivered=" <> strEncode _ntfCronDelivered, + "ntfCronFailed=" <> strEncode _ntfCronFailed, + "ntfVrfQueued=" <> strEncode _ntfVrfQueued, + "ntfVrfDelivered=" <> strEncode _ntfVrfDelivered, + "ntfVrfFailed=" <> strEncode _ntfVrfFailed, + "ntfVrfInvalidTkn=" <> strEncode _ntfVrfInvalidTkn, "activeTokens:", strEncode _activeTokens, "activeSubs:", @@ -101,12 +209,42 @@ instance StrEncoding NtfServerStatsData where _tknCreated <- "tknCreated=" *> strP <* A.endOfLine _tknVerified <- "tknVerified=" *> strP <* A.endOfLine _tknDeleted <- "tknDeleted=" *> strP <* A.endOfLine + _tknReplaced <- opt "tknReplaced=" _subCreated <- "subCreated=" *> strP <* A.endOfLine _subDeleted <- "subDeleted=" *> strP <* A.endOfLine _ntfReceived <- "ntfReceived=" *> strP <* A.endOfLine _ntfDelivered <- "ntfDelivered=" *> strP <* A.endOfLine + _ntfFailed <- opt "ntfFailed=" + _ntfCronDelivered <- opt "ntfCronDelivered=" + _ntfCronFailed <- opt "ntfCronFailed=" + _ntfVrfQueued <- opt "ntfVrfQueued=" + _ntfVrfDelivered <- opt "ntfVrfDelivered=" + _ntfVrfFailed <- opt "ntfVrfFailed=" + _ntfVrfInvalidTkn <- opt "ntfVrfInvalidTkn=" _ <- "activeTokens:" <* A.endOfLine _activeTokens <- strP <* A.endOfLine _ <- "activeSubs:" <* A.endOfLine _activeSubs <- strP <* optional A.endOfLine - pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} + pure + NtfServerStatsData + { _fromTime, + _tknCreated, + _tknVerified, + _tknDeleted, + _tknReplaced, + _subCreated, + _subDeleted, + _ntfReceived, + _ntfDelivered, + _ntfFailed, + _ntfCronDelivered, + _ntfCronFailed, + _ntfVrfQueued, + _ntfVrfDelivered, + _ntfVrfFailed, + _ntfVrfInvalidTkn, + _activeTokens, + _activeSubs + } + where + opt s = A.string s *> strP <* A.endOfLine <|> pure 0 From a58d3540add65e43146d026666e9d82550977d24 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 7 Feb 2025 17:17:53 +0000 Subject: [PATCH 30/51] agent: refactor migrations (#1452) * agent: refactor migrations * fix postgres --- src/Simplex/Messaging/Agent.hs | 5 +- src/Simplex/Messaging/Agent/Store.hs | 5 +- .../Messaging/Agent/Store/Migrations.hs | 59 +++++++------------ src/Simplex/Messaging/Agent/Store/Postgres.hs | 13 +++- .../Messaging/Agent/Store/Postgres/DB.hs | 2 +- .../Agent/Store/Postgres/Migrations.hs | 16 ++--- src/Simplex/Messaging/Agent/Store/SQLite.hs | 17 +++++- .../Agent/Store/SQLite/Migrations.hs | 12 ++-- tests/AgentTests/SQLiteTests.hs | 5 +- tests/AgentTests/SchemaDump.hs | 14 ++--- 10 files changed, 75 insertions(+), 73 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index ed516e50a..a37851e60 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -170,8 +170,7 @@ import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.AgentStore import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Agent.Store.DB as DB -import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL) -import qualified Simplex.Messaging.Agent.Store.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations) import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration) import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C @@ -2180,7 +2179,7 @@ execAgentStoreSQL :: AgentClient -> Text -> AE [Text] execAgentStoreSQL c sql = withAgentEnv c $ withStore' c (`execSQL` sql) getAgentMigrations :: AgentClient -> AE [UpMigration] -getAgentMigrations c = withAgentEnv c $ map upMigration <$> withStore' c Migrations.getCurrent +getAgentMigrations c = withAgentEnv c $ map upMigration <$> withStore' c getCurrentMigrations debugAgentLocks :: AgentClient -> IO AgentLocks debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index ed48bc12b..ff78888a6 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -30,8 +30,7 @@ import Data.Type.Equality import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State) import Simplex.Messaging.Agent.Store.Common -import Simplex.Messaging.Agent.Store.Interface (DBOpts, createDBStore) -import qualified Simplex.Messaging.Agent.Store.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Interface (DBOpts, appMigrations, createDBStore) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, RatchetX448) @@ -54,7 +53,7 @@ import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore) -createStore dbOpts = createDBStore dbOpts Migrations.app +createStore dbOpts = createDBStore dbOpts appMigrations -- * Queue types diff --git a/src/Simplex/Messaging/Agent/Store/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Migrations.hs index 7dc1528f1..f6b6c2df3 100644 --- a/src/Simplex/Messaging/Agent/Store/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Migrations.hs @@ -1,16 +1,11 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} module Simplex.Messaging.Agent.Store.Migrations ( Migration (..), MigrationsToRun (..), DownMigration (..), - Migrations.app, - Migrations.getCurrent, - get, - Migrations.initialize, - Migrations.run, - migrateSchema, + DBMigrate (..), + sharedMigrateSchema, -- for tests migrationsToRun, toDownMigration, @@ -21,19 +16,9 @@ import Control.Monad import Data.Char (toLower) import Data.Functor (($>)) import Data.Maybe (isNothing, mapMaybe) -import Simplex.Messaging.Agent.Store.Common import Simplex.Messaging.Agent.Store.Shared import System.Exit (exitFailure) import System.IO (hFlush, stdout) -#if defined(dbPostgres) -import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations -#else -import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations -import System.Directory (copyFile) -#endif - -get :: DBStore -> [Migration] -> IO (Either MTRError MigrationsToRun) -get st migrations = migrationsToRun migrations <$> withTransaction st Migrations.getCurrent migrationsToRun :: [Migration] -> [Migration] -> Either MTRError MigrationsToRun migrationsToRun [] [] = Right MTRNone @@ -48,44 +33,42 @@ migrationsToRun (a : as) (d : ds) | name a == name d = migrationsToRun as ds | otherwise = Left $ MTREDifferent (name a) (name d) -migrateSchema :: DBStore -> [Migration] -> MigrationConfirmation -> Bool -> IO (Either MigrationError ()) -migrateSchema st migrations confirmMigrations vacuum = do - Migrations.initialize st - get st migrations >>= \case +data DBMigrate = DBMigrate + { initialize :: IO (), + getCurrent :: IO [Migration], + run :: MigrationsToRun -> IO (), + backup :: IO () + } + +sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ()) +sharedMigrateSchema dbm dbNew' migrations confirmMigrations = do + initialize dbm + currentMs <- getCurrent dbm + case migrationsToRun migrations currentMs of Left e -> do when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e) pure . Left $ MigrationError e Right MTRNone -> pure $ Right () Right ms@(MTRUp ums) - | dbNew st -> Migrations.run st vacuum ms $> Right () + | dbNew' -> run dbm ms $> Right () | otherwise -> case confirmMigrations of - MCYesUp -> runWithBackup st vacuum ms - MCYesUpDown -> runWithBackup st vacuum ms - MCConsole -> confirm err >> runWithBackup st vacuum ms + MCYesUp -> runWithBackup ms + MCYesUpDown -> runWithBackup ms + MCConsole -> confirm err >> runWithBackup ms MCError -> pure $ Left err where err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums) Right ms@(MTRDown dms) -> case confirmMigrations of - MCYesUpDown -> runWithBackup st vacuum ms - MCConsole -> confirm err >> runWithBackup st vacuum ms + MCYesUpDown -> runWithBackup ms + MCConsole -> confirm err >> runWithBackup ms MCYesUp -> pure $ Left err MCError -> pure $ Left err where err = MEDowngrade $ map downName dms where + runWithBackup ms = backup dbm >> run dbm ms $> Right () confirm err = confirmOrExit $ migrationErrorDescription err -runWithBackup :: DBStore -> Bool -> MigrationsToRun -> IO (Either a ()) -#if defined(dbPostgres) -runWithBackup st vacuum ms = Migrations.run st vacuum ms $> Right () -#else -runWithBackup st vacuum ms = do - let f = dbFilePath st - copyFile f (f <> ".bak") - Migrations.run st vacuum ms - pure $ Right () -#endif - confirmOrExit :: String -> IO () confirmOrExit s = do putStrLn s diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index 803cbfb99..cda905a25 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -6,6 +6,8 @@ module Simplex.Messaging.Agent.Store.Postgres ( DBOpts (..), + Migrations.appMigrations, + Migrations.getCurrentMigrations, createDBStore, closeDBStore, reopenDBStore, @@ -22,7 +24,8 @@ import Data.Text (Text) import Database.PostgreSQL.Simple (Only (..)) import qualified Database.PostgreSQL.Simple as PSQL import Database.PostgreSQL.Simple.SqlQQ (sql) -import Simplex.Messaging.Agent.Store.Migrations (migrateSchema) +import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema) +import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations import Simplex.Messaging.Agent.Store.Postgres.Common import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) @@ -43,10 +46,16 @@ data DBOpts = DBOpts createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore) createDBStore DBOpts {connstr, schema} migrations confirmMigrations = do st <- connectPostgresStore connstr schema - r <- migrateSchema st migrations confirmMigrations True `onException` closeDBStore st + r <- migrateSchema st `onException` closeDBStore st case r of Right () -> pure $ Right st Left e -> closeDBStore st $> Left e + where + migrateSchema st = + let initialize = Migrations.initialize st + getCurrent = withTransaction st Migrations.getCurrentMigrations + dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()} + in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations connectPostgresStore :: ByteString -> String -> IO DBStore connectPostgresStore dbConnstr dbSchema = do diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs index 88b37f65a..38debb070 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/DB.hs @@ -17,7 +17,7 @@ module Simplex.Messaging.Agent.Store.Postgres.DB where import Control.Monad (void) -import Data.Int (Int32, Int64) +import Data.Int (Int64) import Data.Word (Word16, Word32) import Database.PostgreSQL.Simple (ResultError (..)) import qualified Database.PostgreSQL.Simple as PSQL diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs index 9f8d5744d..857d64d04 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs @@ -5,10 +5,10 @@ {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.Postgres.Migrations - ( app, + ( appMigrations, initialize, run, - getCurrent, + getCurrentMigrations, ) where @@ -34,8 +34,8 @@ schemaMigrations = ] -- | The list of migrations in ascending order by date -app :: [Migration] -app = sortOn name $ map migration schemaMigrations +appMigrations :: [Migration] +appMigrations = sortOn name $ map migration schemaMigrations where migration (name, up, down) = Migration {name, up, down = down} @@ -53,8 +53,8 @@ initialize st = withTransaction' st $ \db -> ) |] -run :: DBStore -> Bool -> MigrationsToRun -> IO () -run st _vacuum = \case +run :: DBStore -> MigrationsToRun -> IO () +run st = \case MTRUp [] -> pure () MTRUp ms -> mapM_ runUp ms MTRDown ms -> mapM_ runDown $ reverse ms @@ -72,7 +72,7 @@ run st _vacuum = \case withMVar (connectionHandle db) $ \pqConn -> void $ LibPQ.exec pqConn (TE.encodeUtf8 query) -getCurrent :: PSQL.Connection -> IO [Migration] -getCurrent db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;" +getCurrentMigrations :: PSQL.Connection -> IO [Migration] +getCurrentMigrations db = map toMigration <$> PSQL.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;" where toMigration (name, down) = Migration {name, up = T.pack "", down} diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index e472db488..0f3e81273 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -26,6 +26,8 @@ module Simplex.Messaging.Agent.Store.SQLite ( DBOpts (..), + Migrations.appMigrations, + Migrations.getCurrentMigrations, createDBStore, closeDBStore, reopenDBStore, @@ -52,12 +54,13 @@ import Database.SQLite.Simple (Query (..)) import qualified Database.SQLite.Simple as SQL import Database.SQLite.Simple.QQ (sql) import qualified Database.SQLite3 as SQLite3 -import Simplex.Messaging.Agent.Store.Migrations (migrateSchema) +import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSchema) +import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Agent.Store.SQLite.Common import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..)) import Simplex.Messaging.Util (ifM, safeDecodeUtf8) -import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist) import System.FilePath (takeDirectory) import UnliftIO.Exception (bracketOnError, onException) import UnliftIO.MVar @@ -78,10 +81,18 @@ createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations conf let dbDir = takeDirectory dbFilePath createDirectoryIfMissing True dbDir st <- connectSQLiteStore dbFilePath dbKey keepKey track - r <- migrateSchema st migrations confirmMigrations vacuum `onException` closeDBStore st + r <- migrateSchema st `onException` closeDBStore st case r of Right () -> pure $ Right st Left e -> closeDBStore st $> Left e + where + migrateSchema st = + let initialize = Migrations.initialize st + getCurrent = withTransaction st Migrations.getCurrentMigrations + run = Migrations.run st vacuum + backup = copyFile dbFilePath (dbFilePath <> ".bak") + dbm = DBMigrate {initialize, getCurrent, run, backup} + in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> DB.TrackQueries -> IO DBStore connectSQLiteStore dbFilePath key keepKey track = do diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 73ab17e5a..dbdc2e0c0 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -8,10 +8,10 @@ {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.SQLite.Migrations - ( app, + ( appMigrations, initialize, run, - getCurrent, + getCurrentMigrations, ) where @@ -112,13 +112,13 @@ schemaMigrations = ] -- | The list of migrations in ascending order by date -app :: [Migration] -app = sortOn name $ map migration schemaMigrations +appMigrations :: [Migration] +appMigrations = sortOn name $ map migration schemaMigrations where migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} -getCurrent :: DB.Connection -> IO [Migration] -getCurrent DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;" +getCurrentMigrations :: DB.Connection -> IO [Migration] +getCurrentMigrations DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;" where toMigration (name, down) = Migration {name, up = "", down} diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 6950f3379..1d5667eb2 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -45,6 +45,7 @@ import Simplex.Messaging.Agent.Store.AgentStore import Simplex.Messaging.Agent.Store.SQLite import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction') import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB +import Simplex.Messaging.Agent.Store.SQLite.Migrations (appMigrations, getCurrentMigrations) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import qualified Simplex.Messaging.Crypto as C @@ -81,7 +82,7 @@ createEncryptedStore key keepKey = 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 - Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) Migrations.app MCError + Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) appMigrations MCError withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);") pure st @@ -635,7 +636,7 @@ testReopenEncryptedStoreKeepKey = do hasMigrations st getMigrations :: DBStore -> IO Bool -getMigrations st = not . null <$> withTransaction st Migrations.getCurrent +getMigrations st = not . null <$> withTransaction st getCurrentMigrations hasMigrations :: DBStore -> Expectation hasMigrations st = getMigrations st `shouldReturn` True diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index b2ddbdbce..ed8668de2 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -50,7 +50,7 @@ testVerifySchemaDump :: IO () testVerifySchemaDump = do savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "") savedSchema `deepseq` pure () - void $ createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCConsole + void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCConsole getSchema testDB appSchema `shouldReturn` savedSchema removeFile testDB @@ -58,7 +58,7 @@ testVerifyLintFKeyIndexes :: IO () testVerifyLintFKeyIndexes = do savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "") savedLint `deepseq` pure () - void $ createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCConsole + void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCConsole getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint removeFile testDB @@ -70,9 +70,9 @@ withTmpFiles = testSchemaMigrations :: IO () testSchemaMigrations = do - let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app + let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) appMigrations Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations MCError - mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app + mapM_ (testDownMigration st) $ drop (length noDownMigrations) appMigrations closeDBStore st removeFile testDB removeFile testSchema @@ -94,19 +94,19 @@ testSchemaMigrations = do testUsersMigrationNew :: IO () testUsersMigrationNew = do - Right st <- createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCError + Right st <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCError withTransaction' st (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([] :: [Only Int]) closeDBStore st testUsersMigrationOld :: IO () testUsersMigrationOld = do - let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app + let beforeUsers = takeWhile (("m20230110_users" /=) . name) appMigrations Right st <- createDBStore (DBOpts testDB "" False True TQOff) beforeUsers MCError withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';") `shouldReturn` ([] :: [Only String]) closeDBStore st - Right st' <- createDBStore (DBOpts testDB "" False True TQOff) Migrations.app MCYesUp + Right st' <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCYesUp withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;") `shouldReturn` ([Only (1 :: Int)]) closeDBStore st' From bd97cb04495b90412c1300fd1a4862f488db85cb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 10 Feb 2025 15:12:54 +0000 Subject: [PATCH 31/51] 6.3.0.4 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 7bdc8add2..c17f3e4be 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.3 +version: 6.3.0.4 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 0d8a1a28790f9930345ba42db25c2dc4d4c926bc Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 14 Feb 2025 16:35:18 +0400 Subject: [PATCH 32/51] agent: encrypt messages on delivery (#1446) * agent: save message body once (plan, schema) * split * new type * bs * encrypt on delivery * schema * fix test * check pad size * rename --------- Co-authored-by: Evgeny Poberezkin --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 45 +++++++++----- src/Simplex/Messaging/Agent/Store.hs | 10 ++- .../Messaging/Agent/Store/AgentStore.hs | 15 ++--- .../Agent/Store/SQLite/Migrations.hs | 4 +- .../SQLite/Migrations/M20250203_msg_bodies.hs | 36 +++++++++++ .../Store/SQLite/Migrations/agent_schema.sql | 2 + src/Simplex/Messaging/Crypto.hs | 6 ++ src/Simplex/Messaging/Crypto/Ratchet.hs | 62 ++++++++++++++++--- tests/AgentTests/DoubleRatchetTests.hs | 6 +- tests/AgentTests/SQLiteTests.hs | 4 +- 11 files changed, 154 insertions(+), 37 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index c17f3e4be..7d2b6a59e 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -198,6 +198,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies if !flag(client_library) exposed-modules: Simplex.FileTransfer.Client.Main diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index a37851e60..1f10c4c73 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1379,6 +1379,7 @@ enqueueMessage c cData sq msgFlags aMessage = ExceptT $ fmap fst . runIdentity <$> enqueueMessageB c (Identity (Right (cData, [sq], Nothing, msgFlags, aMessage))) {-# INLINE enqueueMessage #-} +-- TODO [save once] IntMap of msg bodies. -- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) enqueueMessageB c reqs = do @@ -1391,7 +1392,7 @@ enqueueMessageB c reqs = do where storeSentMsg :: DB.Connection -> AgentConfig -> (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage), InternalId, PQEncryption)) storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do - let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg + let AgentConfig {e2eEncryptVRange} = cfg internalTs <- liftIO getCurrentTime (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash @@ -1399,11 +1400,13 @@ enqueueMessageB c reqs = do agentMsgStr = smpEncode agentMsg internalHash = C.sha256Hash agentMsgStr currentE2EVersion = maxVersion e2eEncryptVRange - (encAgentMessage, pqEnc) <- agentRatchetEncrypt db cData agentMsgStr e2eEncAgentMsgLength pqEnc_ currentE2EVersion - let agentVersion = maxVersion smpAgentVRange - msgBody = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage} - msgType = agentMessageType agentMsg - msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, pqEncryption = pqEnc, internalHash, prevMsgHash} + -- TODO [save once] Save single MsgBody / enveloped body agentMsgStr (outside of withStoreBatch ... storeSentMsg). + -- TODO Link messages to it, save encryption data per message. + -- TODO 'msg_body' field is not nullable - use default empty strings? + (mek, paddedLen, pqEnc) <- agentRatchetEncryptHeader db cData e2eEncAgentMsgLength pqEnc_ currentE2EVersion + withExceptT (SEAgentError . cryptoError) $ CR.rcCheckCanPad paddedLen agentMsgStr + let msgType = agentMessageType agentMsg + msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody = agentMsgStr, pqEncryption = pqEnc, internalHash, prevMsgHash, encryptKey_ = Just mek, paddedLen_ = Just paddedLen} liftIO $ createSndMsg db connId msgData liftIO $ createSndMsgDelivery db connId sq internalId pure (req, internalId, pqEnc) @@ -1451,7 +1454,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI liftIO $ throwWhenNoDelivery c sq atomically $ beginAgentOperation c AOSndNetwork withWork c doWork (\db -> getPendingQueueMsg db connId sq) $ - \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs}) -> do + \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs, encryptKey_, paddedLen_}) -> do atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in submitPendingMsg let mId = unId msgId ri' = maybe id updateRetryInterval2 msgRetryState ri @@ -1461,7 +1464,15 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI resp <- tryError $ case msgType of AM_CONN_INFO -> sendConfirmation c sq msgBody AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody - _ -> sendAgentMessage c sq msgFlags msgBody + _ -> case (encryptKey_, paddedLen_) of + (Nothing, Nothing) -> sendAgentMessage c sq msgFlags msgBody + (Just mek, Just paddedLen) -> do + AgentConfig {smpAgentVRange} <- asks config + encAgentMessage <- liftError cryptoError $ CR.rcEncryptMsg mek paddedLen msgBody + let agentVersion = maxVersion smpAgentVRange + msgBody' = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage} + sendAgentMessage c sq msgFlags msgBody' + _ -> throwE $ INTERNAL "runSmpQueueMsgDelivery: missing encryption data" case resp of Left e -> do let err = if msgType == AM_A_MSG_ then MERR mId e else ERR e @@ -1833,7 +1844,7 @@ deleteConnQueues c waitDelivery ntf rqs = do deleteQueueRecs rs = do maxErrs <- asks $ deleteErrorCount . config rs' <- rights <$> withStoreBatch' c (\db -> map (deleteQueueRec db maxErrs) rs) - let delQ ((rq, _), err_) = (qConnId rq,qServer rq,queueId rq,) <$> err_ + let delQ ((rq, _), err_) = (qConnId rq,qServer rq,queueId rq,) <$> err_ delQs_ = L.nonEmpty $ mapMaybe delQ rs' forM_ delQs_ $ \delQs -> notify ("", "", AEvt SAEConn $ DEL_RCVQS delQs) pure $ map fst rs' @@ -2952,7 +2963,7 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq (encConnInfo, pqEncryption) <- agentRatchetEncrypt db cData agentMsgStr e2eEncConnInfoLength (Just pqEnc) currentE2EVersion let msgBody = smpEncode $ AgentConfirmation {agentVersion = v, e2eEncryption_, encConnInfo} msgType = agentMessageType agentMsg - msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash} + msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, encryptKey_ = Nothing, paddedLen_ = Nothing} liftIO $ createSndMsg db connId msgData liftIO $ createSndMsgDelivery db connId sq internalId @@ -2978,19 +2989,25 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do let msgBody = smpEncode $ AgentRatchetKey {agentVersion, e2eEncryption, info = agentMsgStr} msgType = agentMessageType agentMsg -- this message is e2e encrypted with queue key, not with double ratchet - msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption = PQEncOff, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash} + msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption = PQEncOff, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, encryptKey_ = Nothing, paddedLen_ = Nothing} liftIO $ createSndMsg db connId msgData liftIO $ createSndMsgDelivery db connId sq internalId pure internalId -- encoded AgentMessage -> encoded EncAgentMessage agentRatchetEncrypt :: DB.Connection -> ConnData -> ByteString -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (ByteString, PQEncryption) -agentRatchetEncrypt db ConnData {connId, connAgentVersion = v, pqSupport} msg getPaddedLen pqEnc_ currentE2EVersion = do +agentRatchetEncrypt db cData msg getPaddedLen pqEnc_ currentE2EVersion = do + (mek, paddedLen, pqEnc) <- agentRatchetEncryptHeader db cData getPaddedLen pqEnc_ currentE2EVersion + encMsg <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncryptMsg mek paddedLen msg + pure (encMsg, pqEnc) + +agentRatchetEncryptHeader :: DB.Connection -> ConnData -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (CR.MsgEncryptKeyX448, Int, PQEncryption) +agentRatchetEncryptHeader db ConnData {connId, connAgentVersion = v, pqSupport} getPaddedLen pqEnc_ currentE2EVersion = do rc <- ExceptT $ getRatchet db connId let paddedLen = getPaddedLen v pqSupport - (encMsg, rc') <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg pqEnc_ currentE2EVersion + (mek, rc') <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncryptHeader rc pqEnc_ currentE2EVersion liftIO $ updateRatchet db connId rc' CR.SMDNoChange - pure (encMsg, CR.rcSndKEM rc') + pure (mek, paddedLen, CR.rcSndKEM rc') -- encoded EncAgentMessage -> encoded AgentMessage agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption) diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index ff78888a6..dbd22f9fa 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -33,7 +33,7 @@ import Simplex.Messaging.Agent.Store.Common import Simplex.Messaging.Agent.Store.Interface (DBOpts, appMigrations, createDBStore) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, RatchetX448) +import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol ( MsgBody, @@ -542,7 +542,9 @@ data SndMsgData = SndMsgData msgBody :: MsgBody, pqEncryption :: PQEncryption, internalHash :: MsgHash, - prevMsgHash :: MsgHash + prevMsgHash :: MsgHash, + encryptKey_ :: Maybe MsgEncryptKeyX448, + paddedLen_ :: Maybe Int } data SndMsg = SndMsg @@ -560,7 +562,9 @@ data PendingMsgData = PendingMsgData msgBody :: MsgBody, pqEncryption :: PQEncryption, msgRetryState :: Maybe RI2State, - internalTs :: InternalTs + internalTs :: InternalTs, + encryptKey_ :: Maybe MsgEncryptKeyX448, + paddedLen_ :: Maybe Int } deriving (Show) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 46a358745..1f6101f60 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -844,18 +844,18 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} = DB.query db [sql| - SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast + SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast, s.msg_encrypt_key, s.padded_msg_len FROM messages m JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id WHERE m.conn_id = ? AND m.internal_id = ? |] (connId, msgId) err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []" - pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData - pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_) = + pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, Maybe Int64, Maybe Int64, Maybe CR.MsgEncryptKeyX448, Maybe Int) -> PendingMsgData + pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_, encryptKey_, paddedLen_) = let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_ msgRetryState = RI2State <$> riSlow_ <*> riFast_ - in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs} + in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs, encryptKey_, paddedLen_} markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId) getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a)) @@ -997,6 +997,7 @@ deleteDeliveredSndMsg db connId msgId = do cnt <- countPendingSndDeliveries_ db connId msgId when (cnt == 0) $ deleteMsg db connId msgId +-- TODO [save once] Delete from shared message bodies if no deliveries reference it. (`when (cnt == 0)`) deleteSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> Bool -> IO () deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do DB.execute @@ -2206,11 +2207,11 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} = dbConn [sql| INSERT INTO snd_messages - ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash) + ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash, msg_encrypt_key, padded_msg_len) VALUES - (?,?,?,?,?) + (?,?,?,?,?,?,?) |] - (connId, internalSndId, internalId, Binary internalHash, Binary prevMsgHash) + (connId, internalSndId, internalId, Binary internalHash, Binary prevMsgHash, encryptKey_, paddedLen_) updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () updateSndMsgHash db connId internalSndId internalHash = diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index dbdc2e0c0..4d4e0d554 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -66,6 +66,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies import Simplex.Messaging.Agent.Store.Shared import Simplex.Messaging.Encoding.String import Simplex.Messaging.Transport.Client (TransportHost) @@ -108,7 +109,8 @@ schemaMigrations = ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats), ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete), ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts), - ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params) + ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params), + ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs new file mode 100644 index 000000000..209c4c0b8 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20250203_msg_bodies :: Query +m20250203_msg_bodies = + [sql| +ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BLOB; +ALTER TABLE snd_messages ADD COLUMN padded_msg_len INTEGER; + + +-- CREATE TABLE msg_bodies ( +-- msg_body_id INTEGER PRIMARY KEY, +-- msg_body BLOB NOT NULL DEFAULT x'' +-- ) + +-- ALTER TABLE snd_messages ADD COLUMN msg_body_id INTEGER REFERENCES msg_bodies ON DELETE CASCADE; + +-- fkey to msg_bodies +-- on each delivery check if other deliveries reference the same msg_body_id, if not delete it +|] + +down_m20250203_msg_bodies :: Query +down_m20250203_msg_bodies = + [sql| +ALTER TABLE snd_messages DROP COLUMN msg_encrypt_key; +ALTER TABLE snd_messages DROP COLUMN padded_msg_len; + + +-- ALTER TABLE snd_messages DROP COLUMN msg_body_id; + +-- DROP TABLE msg_bodies; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 5b9339b4f..858ad7628 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -127,6 +127,8 @@ CREATE TABLE snd_messages( retry_int_fast INTEGER, rcpt_internal_id INTEGER, rcpt_status TEXT, + msg_encrypt_key BLOB, + padded_msg_len INTEGER, PRIMARY KEY(conn_id, internal_snd_id), FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index ef3548953..5a22ef203 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -169,6 +169,7 @@ module Simplex.Messaging.Crypto sha512Hash, -- * Message padding / un-padding + canPad, pad, unPad, @@ -1010,6 +1011,11 @@ decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do maxMsgLen :: Int maxMsgLen = 2 ^ (16 :: Int) - 3 +canPad :: Int -> Int -> Bool +canPad msgLen paddedLen = msgLen <= maxMsgLen && padLen >= 0 + where + padLen = paddedLen - msgLen - 2 + pad :: ByteString -> Int -> Either CryptoError ByteString pad msg paddedLen | len <= maxMsgLen && padLen >= 0 = Right $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#' diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 0ee4c75d0..bd87f70b9 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -21,6 +21,8 @@ module Simplex.Messaging.Crypto.Ratchet ( Ratchet (..), RatchetX448, + MsgEncryptKey (..), + MsgEncryptKeyX448, SkippedMsgDiff (..), SkippedMsgKeys, InitialKeys (..), @@ -64,7 +66,9 @@ module Simplex.Messaging.Crypto.Ratchet pqX3dhRcv, initSndRatchet, initRcvRatchet, - rcEncrypt, + rcCheckCanPad, + rcEncryptHeader, + rcEncryptMsg, rcDecrypt, -- used in tests MsgHeader (..), @@ -85,6 +89,7 @@ module Simplex.Messaging.Crypto.Ratchet where import Control.Applicative ((<|>)) +import Control.Monad (unless) import Control.Monad.Except import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except @@ -116,7 +121,7 @@ import Simplex.Messaging.Crypto import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE') +import Simplex.Messaging.Parsers (blobFieldDecoder, blobFieldParser, defaultJSON, parseE, parseE') import Simplex.Messaging.Util (($>>=), (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal @@ -564,6 +569,7 @@ applySMDiff smks = \case type HeaderKey = Key data MessageKey = MessageKey Key IV + deriving (Show) instance Encoding MessageKey where smpEncode (MessageKey (Key key) (IV iv)) = smpEncode (key, iv) @@ -845,9 +851,13 @@ connPQEncryption = \case IKUsePQ -> PQSupportOn IKNoPQ pq -> pq -- default for creating connection is IKNoPQ PQEncOn -rcEncrypt :: AlgorithmI a => Ratchet a -> Int -> ByteString -> Maybe PQEncryption -> VersionE2E -> ExceptT CryptoError IO (ByteString, Ratchet a) -rcEncrypt Ratchet {rcSnd = Nothing} _ _ _ _ = throwE CERatchetState -rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcSupportKEM, rcEnableKEM, rcVersion} paddedMsgLen msg pqEnc_ supportedE2EVersion = do +rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO () +rcCheckCanPad paddedMsgLen msg = + unless (canPad (B.length msg) paddedMsgLen) $ throwE CryptoLargeMsgError + +rcEncryptHeader :: AlgorithmI a => Ratchet a -> Maybe PQEncryption -> VersionE2E -> ExceptT CryptoError IO (MsgEncryptKey a, Ratchet a) +rcEncryptHeader Ratchet {rcSnd = Nothing} _ _ = throwE CERatchetState +rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcSupportKEM, rcEnableKEM, rcVersion} pqEnc_ supportedE2EVersion = do -- state.CKs, mk = KDF_CK(state.CKs) let (ck', mk, iv, ehIV) = chainKdf rcCKs v = current rcVersion @@ -862,11 +872,15 @@ rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcVersion' = rcVersion {maxSupported = maxSupported'} -- enc_header = HENCRYPT(state.HKs, header) (ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen v rcSupportKEM') rcAD (msgHeader v maxSupported') - -- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header)) + -- return enc_header let emHeader = smpEncode EncMessageHeader {ehVersion = v, ehBody, ehAuthTag, ehIV} - (emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (rcAD <> emHeader) msg - let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag} - -- state.Ns += 1 + msgEncryptKey = + MsgEncryptKey + { msgRcVersion = v, + msgKey = MessageKey mk iv, + msgRcAD = rcAD, + msgEncHeader = emHeader + } rc' = rc { rcSnd = Just sr {rcCKs = ck'}, @@ -876,7 +890,7 @@ rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcVersion = rcVersion', rcKEM = if pqEnc_ == Just PQEncOff then (\rck -> rck {rcKEMs = Nothing}) <$> rcKEM else rcKEM } - pure (msg', rc') + pure (msgEncryptKey, rc') where -- header = HEADER_PQ2( -- dh = state.DHRs.public, @@ -899,6 +913,23 @@ rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, Nothing -> ARKP SRKSProposed $ RKParamsProposed k Just RatchetKEMAccepted {rcPQRct} -> ARKP SRKSAccepted $ RKParamsAccepted rcPQRct k +type MsgEncryptKeyX448 = MsgEncryptKey 'X448 + +data MsgEncryptKey a = MsgEncryptKey + { msgRcVersion :: VersionE2E, + msgKey :: MessageKey, + msgRcAD :: ByteString, + msgEncHeader :: ByteString + } + deriving (Show) + +rcEncryptMsg :: AlgorithmI a => MsgEncryptKey a -> Int -> ByteString -> ExceptT CryptoError IO ByteString +rcEncryptMsg MsgEncryptKey {msgKey = MessageKey mk iv, msgRcAD, msgEncHeader, msgRcVersion = v} paddedMsgLen msg = do + -- return ENCRYPT(mk, plaintext, CONCAT(AD, enc_header)) + (emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (msgRcAD <> msgEncHeader) msg + let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader = msgEncHeader, emBody, emAuthTag} + pure msg' + data SkippedMessage a = SMMessage (DecryptResult a) | SMHeader (Maybe RatchetStep) (MsgHeader a) @@ -1145,3 +1176,14 @@ instance FromField PQSupport where #else fromField f = PQSupport . unBI <$> fromField f #endif + +instance Encoding (MsgEncryptKey a) where + smpEncode MsgEncryptKey {msgRcVersion = v, msgKey, msgRcAD, msgEncHeader} = + smpEncode (v, msgRcAD, msgKey, Large msgEncHeader) + smpP = do + (v, msgRcAD, msgKey, Large msgEncHeader) <- smpP + pure MsgEncryptKey {msgRcVersion = v, msgRcAD, msgKey, msgEncHeader} + +instance AlgorithmI a => ToField (MsgEncryptKey a) where toField = toField . Binary . smpEncode + +instance (AlgorithmI a, Typeable a) => FromField (MsgEncryptKey a) where fromField = blobFieldParser smpP diff --git a/tests/AgentTests/DoubleRatchetTests.hs b/tests/AgentTests/DoubleRatchetTests.hs index c3fbf01e8..ac42c73ad 100644 --- a/tests/AgentTests/DoubleRatchetTests.hs +++ b/tests/AgentTests/DoubleRatchetTests.hs @@ -585,9 +585,13 @@ testRatchetVersions = encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff)) encrypt_ pqEnc_ (_, rc, _) msg = -- print msg >> - runExceptT (rcEncrypt rc paddedMsgLen msg pqEnc_ currentE2EEncryptVersion) + runExceptT encrypt >>= either (pure . Left) checkLength where + encrypt = do + (mek, rc') <- rcEncryptHeader rc pqEnc_ currentE2EEncryptVersion + msg' <- rcEncryptMsg mek paddedMsgLen msg + pure (msg', rc') checkLength (msg', rc') = do B.length msg' `shouldBe` fullMsgLen rc' pure $ Right (msg', rc', SMDNoChange) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 1d5667eb2..a901727eb 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -554,7 +554,9 @@ mkSndMsgData internalId internalSndId internalHash = msgBody = hw, pqEncryption = CR.PQEncOn, internalHash, - prevMsgHash = internalHash + prevMsgHash = internalHash, + encryptKey_ = Nothing, + paddedLen_ = Nothing } testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndQueue -> SndMsgData -> Expectation From 7ac80bffcb51e2461ff8d0f54094943c56f1c4e6 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 14 Feb 2025 22:01:40 +0400 Subject: [PATCH 33/51] agent: store shared message body only once (when it is the same across messages when batching) (#1453) * agent: store shared message body only once (when it is the same across messages when batching) * rename * refactor * refactor * save bodies and messages in single transaction * comment * comment * comment * box * mapME * box * ValueOrRef * remove instances * refactor * comments * test * refactor * mapAccumLM compatibility with ghc 8.10.7 --------- Co-authored-by: Evgeny Poberezkin --- simplexmq.cabal | 1 + src/Simplex/Messaging/Agent.hs | 121 ++++++++++++------ src/Simplex/Messaging/Agent/Client.hs | 6 + src/Simplex/Messaging/Agent/Protocol.hs | 38 +++--- src/Simplex/Messaging/Agent/Store.hs | 22 +++- .../Messaging/Agent/Store/AgentStore.hs | 55 ++++++-- .../Agent/Store/Postgres/Migrations.hs | 4 +- .../Migrations/M20250203_msg_bodies.hs | 37 ++++++ .../SQLite/Migrations/M20250203_msg_bodies.hs | 25 ++-- .../Store/SQLite/Migrations/agent_schema.sql | 8 ++ src/Simplex/Messaging/Util.hs | 46 ++++++- tests/AgentTests/FunctionalAPITests.hs | 21 ++- tests/AgentTests/SQLiteTests.hs | 5 +- 13 files changed, 294 insertions(+), 95 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250203_msg_bodies.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 7d2b6a59e..680bf3e91 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -152,6 +152,7 @@ library Simplex.Messaging.Agent.Store.Postgres.DB Simplex.Messaging.Agent.Store.Postgres.Migrations Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies if !flag(client_library) exposed-modules: Simplex.Messaging.Agent.Store.Postgres.Util diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 1f10c4c73..d98fd5858 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -35,6 +35,8 @@ module Simplex.Messaging.Agent AE, SubscriptionsInfo (..), MsgReq, + ValueOrRef (..), + vrValue, getSMPAgentClient, getSMPAgentClient_, disconnectAgentClient, @@ -140,6 +142,9 @@ import Data.Either (isRight, partitionEithers, rights) import Data.Foldable (foldl', toList) import Data.Functor (($>)) import Data.Functor.Identity +import Data.Int (Int64) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IM import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L @@ -409,11 +414,25 @@ sendMessage :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> A sendMessage c = withAgentEnv c .:: sendMessage' c {-# INLINE sendMessage #-} +data ValueOrRef a = VRValue (Maybe Int) a | VRRef Int + +instance Functor ValueOrRef where + fmap f = \case + VRValue i_ a -> VRValue i_ (f a) + VRRef i -> VRRef i + +vrValue :: a -> ValueOrRef a +vrValue = VRValue Nothing + -- When sending multiple messages to the same connection, -- only the first MsgReq for this connection should have non-empty ConnId. -- All subsequent MsgReq in traversable for this connection must be empty. -- This is done to optimize processing by grouping all messages to one connection together. -type MsgReq = (ConnId, PQEncryption, MsgFlags, MsgBody) +-- Also, repeated msg bodies should us MBRef constructor to reference previously used body. +-- It is an error: +-- - to use MBBody with the same Int +-- - to use MBRef with Int that wasn't previously used in MBBody +type MsgReq = (ConnId, PQEncryption, MsgFlags, ValueOrRef MsgBody) -- | Send multiple messages to different connections (SEND command) sendMessages :: AgentClient -> [MsgReq] -> AE [Either AgentErrorType (AgentMsgId, PQEncryption)] @@ -1125,7 +1144,7 @@ getNotificationConns' c nonce encNtfInfo = -- | Send message to the connection (SEND command) in Reader monad sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption) -sendMessage' c connId pqEnc msgFlags msg = ExceptT $ runIdentity <$> sendMessagesB_ c (Identity (Right (connId, pqEnc, msgFlags, msg))) (S.singleton connId) +sendMessage' c connId pqEnc msgFlags msg = ExceptT $ runIdentity <$> sendMessagesB_ c (Identity (Right (connId, pqEnc, msgFlags, vrValue msg))) (S.singleton connId) {-# INLINE sendMessage' #-} -- | Send multiple messages to different connections (SEND command) in Reader monad @@ -1160,14 +1179,14 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do else do conn <- first storeError <$> getConn db connId conn <$ atomically (writeTVar prev $ Just conn) - prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, SomeConn) -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) + prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, SomeConn) -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) prepareConn s (Left e) = (s, Left e) - prepareConn s (Right ((_, pqEnc, msgFlags, msg), SomeConn _ conn)) = case conn of + prepareConn s (Right ((_, pqEnc, msgFlags, msgOrRef), SomeConn _ conn)) = case conn of DuplexConnection cData _ sqs -> prepareMsg cData sqs SndConnection cData sq -> prepareMsg cData [sq] _ -> (s, Left $ CONN SIMPLEX) where - prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) + prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) prepareMsg cData@ConnData {connId, pqSupport} sqs | ratchetSyncSendProhibited cData = (s, Left $ CMD PROHIBITED "sendMessagesB: send prohibited") -- connection is only updated if PQ encryption was disabled, and now it has to be enabled. @@ -1177,7 +1196,7 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do in (S.insert connId s, mkReq cData') | otherwise = (s, mkReq cData) where - mkReq cData' = Right (cData', sqs, Just pqEnc, msgFlags, A_MSG msg) + mkReq cData' = Right (cData', sqs, Just pqEnc, msgFlags, A_MSG <$> msgOrRef) -- / async command processing v v v @@ -1361,10 +1380,10 @@ enqueueMessages c cData sqs msgFlags aMessage = do enqueueMessages' :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, CR.PQEncryption) enqueueMessages' c cData sqs msgFlags aMessage = - ExceptT $ runIdentity <$> enqueueMessagesB c (Identity (Right (cData, sqs, Nothing, msgFlags, aMessage))) + ExceptT $ runIdentity <$> enqueueMessagesB c (Identity (Right (cData, sqs, Nothing, msgFlags, vrValue aMessage))) {-# INLINE enqueueMessages' #-} -enqueueMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption))) +enqueueMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption))) enqueueMessagesB c reqs = do reqs' <- enqueueMessageB c reqs enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs' @@ -1376,40 +1395,62 @@ isActiveSndQ SndQueue {status} = status == Secured || status == Active enqueueMessage :: AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption) enqueueMessage c cData sq msgFlags aMessage = - ExceptT $ fmap fst . runIdentity <$> enqueueMessageB c (Identity (Right (cData, [sq], Nothing, msgFlags, aMessage))) + ExceptT $ fmap fst . runIdentity <$> enqueueMessageB c (Identity (Right (cData, [sq], Nothing, msgFlags, vrValue aMessage))) {-# INLINE enqueueMessage #-} --- TODO [save once] IntMap of msg bodies. -- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries -enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) +enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) enqueueMessageB c reqs = do cfg <- asks config - reqMids <- withStoreBatch c $ \db -> fmap (bindRight $ storeSentMsg db cfg) reqs + (_, reqMids) <- unsafeWithStore c $ \db -> do + mapAccumLM (\ids r -> storeSentMsg db cfg ids r `E.catchAny` \e -> (ids,) <$> handleInternal e) IM.empty reqs forME reqMids $ \((cData, sq :| sqs, _, _, _), InternalId msgId, pqSecr) -> do submitPendingMsg c cData sq let sqs' = filter isActiveSndQ sqs pure $ Right ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId)) where - storeSentMsg :: DB.Connection -> AgentConfig -> (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage), InternalId, PQEncryption)) - storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do - let AgentConfig {e2eEncryptVRange} = cfg - internalTs <- liftIO getCurrentTime - (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId - let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash - agentMsg = AgentMessage privHeader aMessage - agentMsgStr = smpEncode agentMsg - internalHash = C.sha256Hash agentMsgStr - currentE2EVersion = maxVersion e2eEncryptVRange - -- TODO [save once] Save single MsgBody / enveloped body agentMsgStr (outside of withStoreBatch ... storeSentMsg). - -- TODO Link messages to it, save encryption data per message. - -- TODO 'msg_body' field is not nullable - use default empty strings? - (mek, paddedLen, pqEnc) <- agentRatchetEncryptHeader db cData e2eEncAgentMsgLength pqEnc_ currentE2EVersion - withExceptT (SEAgentError . cryptoError) $ CR.rcCheckCanPad paddedLen agentMsgStr - let msgType = agentMessageType agentMsg - msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody = agentMsgStr, pqEncryption = pqEnc, internalHash, prevMsgHash, encryptKey_ = Just mek, paddedLen_ = Just paddedLen} - liftIO $ createSndMsg db connId msgData - liftIO $ createSndMsgDelivery db connId sq internalId - pure (req, internalId, pqEnc) + storeSentMsg :: DB.Connection -> AgentConfig -> IntMap (Int64, AMessage) -> Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage) -> IO (IntMap (Int64, AMessage), Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage), InternalId, PQEncryption)) + storeSentMsg db cfg aMessageIds = \case + Left e -> pure (aMessageIds, Left e) + Right req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, mbr) -> case mbr of + VRValue i_ aMessage -> case i_ >>= (`IM.lookup` aMessageIds) of + Just _ -> pure (aMessageIds, Left $ INTERNAL "enqueueMessageB: storeSentMsg duplicate saved message body") + Nothing -> do + mbId <- createSndMsgBody db aMessage + let aMessageIds' = maybe id (`IM.insert` (mbId, aMessage)) i_ aMessageIds + (aMessageIds',) <$> storeSentMsg_ mbId aMessage + VRRef i -> (aMessageIds,) <$> case IM.lookup i aMessageIds of + Just (mbId, aMessage) -> storeSentMsg_ mbId aMessage + Nothing -> pure $ Left $ INTERNAL "enqueueMessageB: storeSentMsg missing saved message body id" + where + storeSentMsg_ sndMsgBodyId aMessage = fmap (first storeError) $ runExceptT $ do + let AgentConfig {e2eEncryptVRange} = cfg + internalTs <- liftIO getCurrentTime + (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId + -- We need to do pre-flight encoding that is not stored in database + -- to calculate its hash and remember it on connection (createSndMsg -> updateSndMsgHash) + -- to enable next enqueue. + -- (As encoding is different per connection, we can't store shared body, so it's repeated on delivery) + let agentMsgStr = encodeAgentMsgStr aMessage internalSndId prevMsgHash + internalHash = C.sha256Hash agentMsgStr + currentE2EVersion = maxVersion e2eEncryptVRange + (mek, paddedLen, pqEnc) <- agentRatchetEncryptHeader db cData e2eEncAgentMsgLength pqEnc_ currentE2EVersion + withExceptT (SEAgentError . cryptoError) $ CR.rcCheckCanPad paddedLen agentMsgStr + let msgType = aMessageType aMessage + -- msgBody is empty, because snd_messages record is linked to snd_message_bodies + msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody = "", pqEncryption = pqEnc, internalHash, prevMsgHash, sndMsgPrepData_ = Just SndMsgPrepData {encryptKey = mek, paddedLen, sndMsgBodyId}} + liftIO $ createSndMsg db connId msgData + liftIO $ createSndMsgDelivery db connId sq internalId + pure (req, internalId, pqEnc) + handleInternal :: E.SomeException -> IO (Either AgentErrorType b) + handleInternal = pure . Left . INTERNAL . show + + +encodeAgentMsgStr :: AMessage -> InternalSndId -> PrevSndMsgHash -> ByteString +encodeAgentMsgStr aMessage internalSndId prevMsgHash = do + let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash + agentMsg = AgentMessage privHeader aMessage + in smpEncode agentMsg enqueueSavedMessage :: AgentClient -> ConnData -> AgentMsgId -> SndQueue -> AM' () enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData, [sq], msgId) @@ -1454,7 +1495,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI liftIO $ throwWhenNoDelivery c sq atomically $ beginAgentOperation c AOSndNetwork withWork c doWork (\db -> getPendingQueueMsg db connId sq) $ - \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs, encryptKey_, paddedLen_}) -> do + \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs, internalSndId, prevMsgHash, pendingMsgPrepData_}) -> do atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in submitPendingMsg let mId = unId msgId ri' = maybe id updateRetryInterval2 msgRetryState ri @@ -1464,15 +1505,15 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI resp <- tryError $ case msgType of AM_CONN_INFO -> sendConfirmation c sq msgBody AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody - _ -> case (encryptKey_, paddedLen_) of - (Nothing, Nothing) -> sendAgentMessage c sq msgFlags msgBody - (Just mek, Just paddedLen) -> do + _ -> case pendingMsgPrepData_ of + Nothing -> sendAgentMessage c sq msgFlags msgBody + Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} -> do + let agentMsgStr = encodeAgentMsgStr sndMsgBody internalSndId prevMsgHash AgentConfig {smpAgentVRange} <- asks config - encAgentMessage <- liftError cryptoError $ CR.rcEncryptMsg mek paddedLen msgBody + encAgentMessage <- liftError cryptoError $ CR.rcEncryptMsg encryptKey paddedLen agentMsgStr let agentVersion = maxVersion smpAgentVRange msgBody' = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage} sendAgentMessage c sq msgFlags msgBody' - _ -> throwE $ INTERNAL "runSmpQueueMsgDelivery: missing encryption data" case resp of Left e -> do let err = if msgType == AM_A_MSG_ then MERR mId e else ERR e @@ -2963,7 +3004,7 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq (encConnInfo, pqEncryption) <- agentRatchetEncrypt db cData agentMsgStr e2eEncConnInfoLength (Just pqEnc) currentE2EVersion let msgBody = smpEncode $ AgentConfirmation {agentVersion = v, e2eEncryption_, encConnInfo} msgType = agentMessageType agentMsg - msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, encryptKey_ = Nothing, paddedLen_ = Nothing} + msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, sndMsgPrepData_ = Nothing} liftIO $ createSndMsg db connId msgData liftIO $ createSndMsgDelivery db connId sq internalId @@ -2989,7 +3030,7 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do let msgBody = smpEncode $ AgentRatchetKey {agentVersion, e2eEncryption, info = agentMsgStr} msgType = agentMessageType agentMsg -- this message is e2e encrypted with queue key, not with double ratchet - msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption = PQEncOff, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, encryptKey_ = Nothing, paddedLen_ = Nothing} + msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption = PQEncOff, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash, sndMsgPrepData_ = Nothing} liftIO $ createSndMsg db connId msgData liftIO $ createSndMsgDelivery db connId sq internalId pure internalId diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 5d5e6fcaf..37f01752f 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -146,6 +146,7 @@ module Simplex.Messaging.Agent.Client withStore', withStoreBatch, withStoreBatch', + unsafeWithStore, storeError, userServers, pickServer, @@ -2009,6 +2010,11 @@ withStore c action = do ] #endif +unsafeWithStore :: AgentClient -> (DB.Connection -> IO a) -> AM' a +unsafeWithStore c action = do + st <- asks store + liftIO $ agentOperationBracket c AODatabase (\_ -> pure ()) $ withTransaction st action + withStoreBatch :: Traversable t => AgentClient -> (DB.Connection -> t (IO (Either AgentErrorType a))) -> AM' (t (Either AgentErrorType a)) withStoreBatch c actions = do st <- asks store diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index c5219ab22..365ef0766 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -140,6 +140,7 @@ module Simplex.Messaging.Agent.Protocol serializeQueueStatus, queueStatusT, agentMessageType, + aMessageType, extraSMPServerHosts, updateSMPServerHosts, ) @@ -167,7 +168,7 @@ import Data.Time.Clock.System (SystemTime) import Data.Type.Equality import Data.Typeable () import Data.Word (Word16, Word32) -import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..)) import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Transport (XFTPErrorType) @@ -855,20 +856,7 @@ agentMessageType = \case AgentConnInfo _ -> AM_CONN_INFO AgentConnInfoReply {} -> AM_CONN_INFO_REPLY AgentRatchetInfo _ -> AM_RATCHET_INFO - AgentMessage _ aMsg -> case aMsg of - -- HELLO is used both in v1 and in v2, but differently. - -- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times, - -- until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it. - -- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured. - HELLO -> AM_HELLO_ - A_MSG _ -> AM_A_MSG_ - A_RCVD {} -> AM_A_RCVD_ - A_QCONT _ -> AM_QCONT_ - QADD _ -> AM_QADD_ - QKEY _ -> AM_QKEY_ - QUSE _ -> AM_QUSE_ - QTEST _ -> AM_QTEST_ - EREADY _ -> AM_EREADY_ + AgentMessage _ aMsg -> aMessageType aMsg data APrivHeader = APrivHeader { -- | sequential ID assigned by the sending agent @@ -946,6 +934,22 @@ data AMessage EREADY AgentMsgId deriving (Show) +aMessageType :: AMessage -> AgentMessageType +aMessageType = \case + -- HELLO is used both in v1 and in v2, but differently. + -- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times, + -- until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it. + -- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured. + HELLO -> AM_HELLO_ + A_MSG _ -> AM_A_MSG_ + A_RCVD {} -> AM_A_RCVD_ + A_QCONT _ -> AM_QCONT_ + QADD _ -> AM_QADD_ + QKEY _ -> AM_QKEY_ + QUSE _ -> AM_QUSE_ + QTEST _ -> AM_QTEST_ + EREADY _ -> AM_EREADY_ + -- | this type is used to send as part of the protocol between different clients -- TODO possibly, rename fields and types referring to external and internal IDs to make them different data AMessageReceipt = AMessageReceipt @@ -1010,6 +1014,10 @@ instance Encoding AMessage where QTEST_ -> QTEST <$> smpP EREADY_ -> EREADY <$> smpP +instance ToField AMessage where toField = toField . Binary . smpEncode + +instance FromField AMessage where fromField = blobFieldParser smpP + instance Encoding AMessageReceipt where smpEncode AMessageReceipt {agentMsgId, msgHash, rcptInfo} = smpEncode (agentMsgId, msgHash, Large rcptInfo) diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index dbd22f9fa..b29acc6a6 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -543,10 +543,16 @@ data SndMsgData = SndMsgData pqEncryption :: PQEncryption, internalHash :: MsgHash, prevMsgHash :: MsgHash, - encryptKey_ :: Maybe MsgEncryptKeyX448, - paddedLen_ :: Maybe Int + sndMsgPrepData_ :: Maybe SndMsgPrepData } +data SndMsgPrepData = SndMsgPrepData + { encryptKey :: MsgEncryptKeyX448, + paddedLen :: Int, + sndMsgBodyId :: Int64 + } + deriving (Show) + data SndMsg = SndMsg { internalId :: InternalId, internalSndId :: InternalSndId, @@ -563,8 +569,16 @@ data PendingMsgData = PendingMsgData pqEncryption :: PQEncryption, msgRetryState :: Maybe RI2State, internalTs :: InternalTs, - encryptKey_ :: Maybe MsgEncryptKeyX448, - paddedLen_ :: Maybe Int + internalSndId :: InternalSndId, + prevMsgHash :: PrevSndMsgHash, + pendingMsgPrepData_ :: Maybe PendingMsgPrepData + } + deriving (Show) + +data PendingMsgPrepData = PendingMsgPrepData + { encryptKey :: MsgEncryptKeyX448, + paddedLen :: Int, + sndMsgBody :: AMessage } deriving (Show) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 1f6101f60..bf602627b 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -92,6 +92,7 @@ module Simplex.Messaging.Agent.Store.AgentStore updateRcvIds, createRcvMsg, updateRcvMsgHash, + createSndMsgBody, updateSndIds, createSndMsg, updateSndMsgHash, @@ -770,6 +771,14 @@ createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta = updateRcvMsgHash db connId sndMsgId internalRcvId internalHash DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId) +createSndMsgBody :: DB.Connection -> AMessage -> IO Int64 +createSndMsgBody db aMessage = + fromOnly . head <$> + DB.query + db + "INSERT INTO snd_message_bodies (agent_msg) VALUES (?) RETURNING snd_message_body_id" + (Only aMessage) + updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) updateSndIds db connId = runExceptT $ do (lastInternalId, lastInternalSndId, prevSndHash) <- ExceptT $ retrieveLastIdsAndHashSnd_ db connId @@ -836,7 +845,7 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} = (connId, dbQueueId) getMsgData :: InternalId -> IO (Either StoreError (Maybe RcvQueue, PendingMsgData)) getMsgData msgId = runExceptT $ do - msg <- ExceptT $ firstRow pendingMsgData err getMsgData_ + msg <- ExceptT $ firstRow' pendingMsgData err getMsgData_ rq_ <- liftIO $ L.head <$$> getRcvQueuesByConnId_ db connId pure (rq_, msg) where @@ -844,18 +853,25 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} = DB.query db [sql| - SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast, s.msg_encrypt_key, s.padded_msg_len + SELECT + m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, m.internal_snd_id, s.previous_msg_hash, + s.retry_int_slow, s.retry_int_fast, s.msg_encrypt_key, s.padded_msg_len, sb.agent_msg FROM messages m JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id + LEFT JOIN snd_message_bodies sb ON sb.snd_message_body_id = s.snd_message_body_id WHERE m.conn_id = ? AND m.internal_id = ? |] (connId, msgId) err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []" - pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, Maybe Int64, Maybe Int64, Maybe CR.MsgEncryptKeyX448, Maybe Int) -> PendingMsgData - pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_, encryptKey_, paddedLen_) = + pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, PQEncryption, InternalTs, InternalSndId, PrevSndMsgHash, Maybe Int64, Maybe Int64, Maybe CR.MsgEncryptKeyX448, Maybe Int, Maybe AMessage) -> Either StoreError PendingMsgData + pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, internalSndId, prevMsgHash, riSlow_, riFast_, encryptKey_, paddedLen_, sndMsgBody_) = do let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_ msgRetryState = RI2State <$> riSlow_ <*> riFast_ - in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs, encryptKey_, paddedLen_} + result pendingMsgPrepData_ = PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs, internalSndId, prevMsgHash, pendingMsgPrepData_} + in result <$> case (encryptKey_, paddedLen_, sndMsgBody_) of + (Nothing, Nothing, Nothing) -> Right Nothing + (Just encryptKey, Just paddedLen, Just sndMsgBody) -> Right $ Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} + _ -> Left $ SEInternal "unexpected snd msg data" markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId) getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a)) @@ -997,7 +1013,6 @@ deleteDeliveredSndMsg db connId msgId = do cnt <- countPendingSndDeliveries_ db connId msgId when (cnt == 0) $ deleteMsg db connId msgId --- TODO [save once] Delete from shared message bodies if no deliveries reference it. (`when (cnt == 0)`) deleteSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> Bool -> IO () deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do DB.execute @@ -1006,11 +1021,19 @@ deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do (connId, dbQueueId, msgId) cnt <- countPendingSndDeliveries_ db connId msgId when (cnt == 0) $ do - del <- - maybeFirstRow id (DB.query db "SELECT rcpt_internal_id, rcpt_status FROM snd_messages WHERE conn_id = ? AND internal_id = ?" (connId, msgId)) >>= \case - Just (Just (_ :: Int64), Just MROk) -> pure deleteMsg - _ -> pure $ if keepForReceipt then deleteMsgContent else deleteMsg - del db connId msgId + maybeFirstRow id (DB.query db "SELECT rcpt_internal_id, rcpt_status, snd_message_body_id FROM snd_messages WHERE conn_id = ? AND internal_id = ?" (connId, msgId)) >>= \case + Just (Just (_ :: Int64), Just MROk, sndMsgBodyId_) -> do + forM_ sndMsgBodyId_ deleteSndMsgBody + deleteMsg db connId msgId + Just (_, _, Just (sndMsgBodyId :: Int64)) -> do + deleteSndMsgBody sndMsgBodyId + delKeepForReceipt + _ -> + delKeepForReceipt + where + delKeepForReceipt = if keepForReceipt then deleteMsgContent db connId msgId else deleteMsg db connId msgId + deleteSndMsgBody sndMsgBodyId = + DB.execute db "DELETE FROM snd_message_bodies WHERE snd_message_body_id = ?" (Only sndMsgBodyId) countPendingSndDeliveries_ :: DB.Connection -> ConnId -> InternalId -> IO Int countPendingSndDeliveries_ db connId msgId = do @@ -2207,11 +2230,15 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} = dbConn [sql| INSERT INTO snd_messages - ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash, msg_encrypt_key, padded_msg_len) + ( conn_id, internal_snd_id, internal_id, internal_hash, previous_msg_hash, msg_encrypt_key, padded_msg_len, snd_message_body_id) VALUES - (?,?,?,?,?,?,?) + (?,?,?,?,?,?,?,?) |] - (connId, internalSndId, internalId, Binary internalHash, Binary prevMsgHash, encryptKey_, paddedLen_) + (connId, internalSndId, internalId, Binary internalHash, Binary prevMsgHash, encryptKey_, paddedLen_, sndMsgBodyId_) + where + (encryptKey_, paddedLen_, sndMsgBodyId_) = case sndMsgPrepData_ of + Nothing -> (Nothing, Nothing, Nothing) + Just SndMsgPrepData {encryptKey, paddedLen, sndMsgBodyId} -> (Just encryptKey, Just paddedLen, Just sndMsgBodyId) updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () updateSndMsgHash db connId internalSndId internalHash = diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs index 857d64d04..6eb01dc4f 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs @@ -25,12 +25,14 @@ import Database.PostgreSQL.Simple.Internal (Connection (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Store.Postgres.Common import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies import Simplex.Messaging.Agent.Store.Shared import UnliftIO.MVar schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = - [ ("20241210_initial", m20241210_initial, Nothing) + [ ("20241210_initial", m20241210_initial, Nothing), + ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250203_msg_bodies.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250203_msg_bodies.hs new file mode 100644 index 000000000..848566b77 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250203_msg_bodies.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.RawString.QQ (r) + +m20250203_msg_bodies :: Text +m20250203_msg_bodies = + T.pack + [r| +ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BYTEA; +ALTER TABLE snd_messages ADD COLUMN padded_msg_len BIGINT; + + +CREATE TABLE snd_message_bodies ( + snd_message_body_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + agent_msg BYTEA NOT NULL DEFAULT ''::BYTEA +); +ALTER TABLE snd_messages ADD COLUMN snd_message_body_id BIGINT REFERENCES snd_message_bodies ON DELETE SET NULL; +CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(snd_message_body_id); +|] + + +down_m20250203_msg_bodies :: Text +down_m20250203_msg_bodies = + T.pack + [r| +DROP INDEX idx_snd_messages_snd_message_body_id; +ALTER TABLE snd_messages DROP COLUMN snd_message_body_id; +DROP TABLE snd_message_bodies; + + +ALTER TABLE snd_messages DROP COLUMN msg_encrypt_key; +ALTER TABLE snd_messages DROP COLUMN padded_msg_len; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs index 209c4c0b8..622758cfe 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250203_msg_bodies.hs @@ -12,25 +12,22 @@ ALTER TABLE snd_messages ADD COLUMN msg_encrypt_key BLOB; ALTER TABLE snd_messages ADD COLUMN padded_msg_len INTEGER; --- CREATE TABLE msg_bodies ( --- msg_body_id INTEGER PRIMARY KEY, --- msg_body BLOB NOT NULL DEFAULT x'' --- ) - --- ALTER TABLE snd_messages ADD COLUMN msg_body_id INTEGER REFERENCES msg_bodies ON DELETE CASCADE; - --- fkey to msg_bodies --- on each delivery check if other deliveries reference the same msg_body_id, if not delete it +CREATE TABLE snd_message_bodies ( + snd_message_body_id INTEGER PRIMARY KEY, + agent_msg BLOB NOT NULL DEFAULT x'' +); +ALTER TABLE snd_messages ADD COLUMN snd_message_body_id INTEGER REFERENCES snd_message_bodies ON DELETE SET NULL; +CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(snd_message_body_id); |] down_m20250203_msg_bodies :: Query down_m20250203_msg_bodies = [sql| +DROP INDEX idx_snd_messages_snd_message_body_id; +ALTER TABLE snd_messages DROP COLUMN snd_message_body_id; +DROP TABLE snd_message_bodies; + + ALTER TABLE snd_messages DROP COLUMN msg_encrypt_key; ALTER TABLE snd_messages DROP COLUMN padded_msg_len; - - --- ALTER TABLE snd_messages DROP COLUMN msg_body_id; - --- DROP TABLE msg_bodies; |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 858ad7628..3f9a468e1 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -129,6 +129,7 @@ CREATE TABLE snd_messages( rcpt_status TEXT, msg_encrypt_key BLOB, padded_msg_len INTEGER, + snd_message_body_id INTEGER REFERENCES snd_message_bodies ON DELETE SET NULL, PRIMARY KEY(conn_id, internal_snd_id), FOREIGN KEY(conn_id, internal_id) REFERENCES messages ON DELETE CASCADE @@ -417,6 +418,10 @@ CREATE TABLE ntf_tokens_to_delete( del_failed INTEGER DEFAULT 0, created_at TEXT NOT NULL DEFAULT(datetime('now')) ); +CREATE TABLE snd_message_bodies( + snd_message_body_id INTEGER PRIMARY KEY, + agent_msg BLOB NOT NULL DEFAULT x'' +); CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id); CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id); @@ -543,3 +548,6 @@ CREATE INDEX idx_snd_message_deliveries_expired ON snd_message_deliveries( internal_id ); CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id); +CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages( + snd_message_body_id +); diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index b467c5ea9..1fdc33577 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,6 +9,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except +import Control.Monad.Trans.State.Strict (StateT (..)) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import Data.Bifunctor (first) @@ -17,7 +19,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.IORef import Data.Int (Int64) import Data.List (groupBy, sortOn) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -25,6 +27,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Time (NominalDiffTime) +import Data.Tuple (swap) import GHC.Conc (labelThread, myThreadId, threadDelay) import UnliftIO hiding (atomicModifyIORef') import qualified UnliftIO.Exception as UE @@ -100,6 +103,47 @@ forME :: (Monad m, Traversable t) => t (Either e a) -> (a -> m (Either e b)) -> forME = flip mapME {-# INLINE forME #-} + +-- | Monadic version of mapAccumL +-- Copied from ghc-9.6.3 package: https://hackage.haskell.org/package/ghc-9.12.1/docs/GHC-Utils-Monad.html#v:mapAccumLM +-- for backward compatibility with 8.10.7. +mapAccumLM :: (Monad m, Traversable t) + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> t x -- ^ inputs + -> m (acc, t y) -- ^ final state, outputs +{-# INLINE [1] mapAccumLM #-} +-- INLINE pragma. mapAccumLM is called in inner loops. Like 'map', +-- we inline it so that we can take advantage of knowing 'f'. +-- This makes a few percent difference (in compiler allocations) +-- when compiling perf/compiler/T9675 +mapAccumLM f s = fmap swap . flip runStateT s . traverse f' + where + f' = StateT . (fmap . fmap) swap . flip f +{-# RULES "mapAccumLM/List" mapAccumLM = mapAccumLM_List #-} +{-# RULES "mapAccumLM/NonEmpty" mapAccumLM = mapAccumLM_NonEmpty #-} + +mapAccumLM_List + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> [x] -> m (acc, [y]) +{-# INLINE mapAccumLM_List #-} +mapAccumLM_List f = go + where + go s (x : xs) = do + (s1, x') <- f s x + (s2, xs') <- go s1 xs + return (s2, x' : xs') + go s [] = return (s, []) + +mapAccumLM_NonEmpty + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> NonEmpty x -> m (acc, NonEmpty y) +{-# INLINE mapAccumLM_NonEmpty #-} +mapAccumLM_NonEmpty f s (x :| xs) = + [(s2, x' :| xs') | (s1, x') <- f s x, (s2, xs') <- mapAccumLM_List f s1 xs] + catchAll :: IO a -> (E.SomeException -> IO a) -> IO a catchAll = E.catch {-# INLINE catchAll #-} diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 1f7d9f1cc..80fff1dbb 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1971,7 +1971,7 @@ testBatchedPendingMessages nCreate nMsgs = testSendMessagesB :: IO () testSendMessagesB = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - let msg cId body = Right (cId, PQEncOn, SMP.noMsgFlags, body) + let msg cId body = Right (cId, PQEncOn, SMP.noMsgFlags, vrValue body) [SentB 2, SentB 3, SentB 4] <- sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3"] :: [Either AgentErrorType MsgReq]) get a ##> ("", bId, SENT 2) get a ##> ("", bId, SENT 3) @@ -1984,7 +1984,7 @@ testSendMessagesB2 :: IO () testSendMessagesB2 = withAgentClients3 $ \a b c -> runRight_ $ do (abId, bId) <- makeConnection a b (acId, cId) <- makeConnection a c - let msg connId body = Right (connId, PQEncOn, SMP.noMsgFlags, body) + let msg connId body = msgVR connId $ vrValue body [SentB 2, SentB 3, SentB 4, SentB 2, SentB 3] <- sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3", msg cId "msg 4", msg "" "msg 5"] :: [Either AgentErrorType MsgReq]) liftIO $ @@ -2001,6 +2001,23 @@ testSendMessagesB2 = withAgentClients3 $ \a b c -> runRight_ $ do receiveMsg b abId 4 "msg 3" receiveMsg c acId 2 "msg 4" receiveMsg c acId 3 "msg 5" + let msg' connId i body = msgVR connId $ VRValue (Just i) body + [SentB 5, SentB 6, SentB 4, SentB 5] <- + sendMessagesB a ([msg' bId 0 "msg 5", msg' "" 1 "msg 6", msgVR cId (VRRef 0), msgVR "" (VRRef 1)] :: [Either AgentErrorType MsgReq]) + liftIO $ + getInAnyOrder + a + [ \case ("", cId', AEvt SAEConn (SENT 5)) -> cId' == bId; _ -> False, + \case ("", cId', AEvt SAEConn (SENT 6)) -> cId' == bId; _ -> False, + \case ("", cId', AEvt SAEConn (SENT 4)) -> cId' == cId; _ -> False, + \case ("", cId', AEvt SAEConn (SENT 5)) -> cId' == cId; _ -> False + ] + receiveMsg b abId 5 "msg 5" + receiveMsg b abId 6 "msg 6" + receiveMsg c acId 4 "msg 5" + receiveMsg c acId 5 "msg 6" + where + msgVR connId mbr = Right (connId, PQEncOn, SMP.noMsgFlags, mbr) pattern SentB :: AgentMsgId -> Either AgentErrorType (AgentMsgId, PQEncryption) pattern SentB msgId <- Right (msgId, PQEncOn) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index a901727eb..04c530d97 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -45,8 +45,6 @@ import Simplex.Messaging.Agent.Store.AgentStore import Simplex.Messaging.Agent.Store.SQLite import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction') import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB -import Simplex.Messaging.Agent.Store.SQLite.Migrations (appMigrations, getCurrentMigrations) -import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -555,8 +553,7 @@ mkSndMsgData internalId internalSndId internalHash = pqEncryption = CR.PQEncOn, internalHash, prevMsgHash = internalHash, - encryptKey_ = Nothing, - paddedLen_ = Nothing + sndMsgPrepData_ = Nothing } testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndQueue -> SndMsgData -> Expectation From 560b257af7e1b6efa595ab77bc2cf22635c6eef9 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Sat, 15 Feb 2025 10:31:19 +0000 Subject: [PATCH 34/51] scripts: simplex-servers-update menu to update only server binaries etc. (#1445) * scripts/simplex-servers-update: refactor * simplex-servers-update: don't check empty variable * simplex-servers-update: minor decoration change * simplex-servers-update: add new line when reexecuting script * simplex-servers-update: refactor menus * simplex-servers-update: fix re-executing * simplex-servers-update: fix menus * simplex-servers-update: do not rerended menu every time * simplex-servers-update: update menus logic * simplex-servers-update: ask permission to update only if versions differ * simplex-servers-update: skip empty variable * simplex-servers-update: include while loop * simplex-servers-update: update re-executing skip logic * simplex-servers-update: ignore empty * simplex-servers-update: s/while/if * simplex-servers-update: ignore empty variable * simplex-servers-update: update skipping scripts * simplex-servers-update: minor fixes * simplex-servers-update: add spaces * simplex-servers-update: safeguard files and add cleanup logic * simplex-servers-update: update menus * simplex-servers-update: fix binary check * simplex-servers-update: adjust erasing lines * simplex-servers-update: simplify bin update logic * simplex-servers-update: fix binary path * simplex-servers-update: format errors * scripts/main/simplex-servers-update: initial refactor2 * simplex-servers-update: incr update * simplex-servers-update: initial dynamic menu * simplex-servers-update: misc fixes * simplex-servers-update: fix VER * simplex-servers-update: add VER check * simplex-servers-update: abort early if there's no options available * simplex-servers-update: add new helper function and update_misc * simplex-servers-update: pass selection * simplex-servers-update: non-interactive usage * simplex-servers-update: add help menu * simplex-servers-update: misc fixes and new binary update logic * simplex-servers-update: local path check * simplex-servers-update: fix change check * simplex-servers-update: OLF -> OLD * simplex-servers-update: always return code from functions * simplex-servers-update: new menu flow * simplex-servers-update: fixes * simplex-servers-update: download function + fixes * simplex-servers-update: s/bins/binaries * simplex-servers-update: download message * simplex-servers-update: cleanup --- scripts/main/simplex-servers-update | 677 +++++++++++++++++++++------- 1 file changed, 509 insertions(+), 168 deletions(-) diff --git a/scripts/main/simplex-servers-update b/scripts/main/simplex-servers-update index dad3c25b9..a3c6cc2bf 100755 --- a/scripts/main/simplex-servers-update +++ b/scripts/main/simplex-servers-update @@ -1,13 +1,16 @@ #!/usr/bin/env sh set -eu +# Make sure that PATH variable contains /usr/local/bin +PATH="/usr/local/bin:$PATH" + # Links to scripts/configs -scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main" -scripts_systemd_smp="$scripts/smp-server.service" -scripts_systemd_xftp="$scripts/xftp-server.service" -scripts_update="$scripts/simplex-servers-update" -scripts_uninstall="$scripts/simplex-servers-uninstall" -scripts_stopscript="$scripts/simplex-servers-stopscript" +scripts_url="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main" +scripts_url_systemd_smp="$scripts_url/smp-server.service" +scripts_url_systemd_xftp="$scripts_url/xftp-server.service" +scripts_url_update="$scripts_url/simplex-servers-update" +scripts_url_uninstall="$scripts_url/simplex-servers-uninstall" +scripts_url_stopscript="$scripts_url/simplex-servers-stopscript" # Default installation paths path_bin="/usr/local/bin" @@ -22,7 +25,9 @@ path_systemd_smp="$path_systemd/smp-server.service" path_systemd_xftp="$path_systemd/xftp-server.service" # Temporary paths -path_tmp_bin="$(mktemp -d)" +path_tmp_bin="/tmp/simplex-servers" +path_tmp_bin_smp="$path_tmp_bin/smp-server" +path_tmp_bin_xftp="$path_tmp_bin/xftp-server" path_tmp_bin_update="$path_tmp_bin/simplex-servers-update" path_tmp_bin_uninstall="$path_tmp_bin/simplex-servers-uninstall" path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript" @@ -37,203 +42,539 @@ BLU='\033[1;36m' YLW='\033[1;33m' RED='\033[0;31m' NC='\033[0m' +BLD='\033[1m' +UNDRL='\033[4m' + +NL=' +' + +# Set VER globally and only once +VER="${VER:-latest}" # Currently, XFTP default to v0.1.0, so it doesn't make sense to check its version -os_test() { - . /etc/os-release +###################### +### Misc functions ### +###################### - case "$VERSION_ID" in - 20.04|22.04) : ;; - 24.04) VERSION_ID='22.04' ;; - *) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;; - esac +# Checks "sanity" of downloaded thing, e.g. if it's really a script or binary +check_sanity() { + path="$1" + criteria="$2" - version="$(printf '%s' "$VERSION_ID" | tr '.' '_')" - arch="$(uname -p)" + case "$criteria" in + string:*) + pattern="$(printf '%s' "$criteria" | awk '{print $2}')" + + if grep -q "$pattern" "$path"; then + sane=0 + else + sane=1 + fi + ;; + file:*) + pattern="$(printf '%s' "$criteria" | awk '{print $2}')" - case "$arch" in - x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;; - *) printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;; - esac + if file "$path" | grep -q "$pattern"; then + sane=0 + else + sane=1 + fi + ;; + *) printf 'Unknown criteria.\n'; sane=1 ;; + esac - bin_smp="$bin/smp-server-ubuntu-${version}-${arch}" - bin_xftp="$bin/xftp-server-ubuntu-${version}-${arch}" + unset path string + + return "$sane" } -installed_test() { +# Checks if old thing and new thing is different +change_check() { + old="$1" + new="$2" + + if [ -x "$new" ] || [ -f "$new" ]; then + type="$(file $new)" + else + type='string' + fi + + case "$type" in + *script*|*text*) + if diff -q "$old" "$new" > /dev/null 2>&1; then + changed=1 + else + changed=0 + fi + ;; + string) + if [ "$old" = "$new" ]; then + changed=1 + else + changed=0 + fi + ;; + esac + + return "$changed" +} + +########################## +### Misc functions END ### +########################## + +######################### +### Support functions ### +######################### + +# Sets local/remote versions and "apps" variables +check_versions() { + # Sets: + # - ver + # - bin_url + # - remote_version + # - local_version + # - apps + + case "$VER" in + latest) + bin_url="https://github.com/simplex-chat/simplexmq/releases/latest/download" + remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest 2>/dev/null | grep -i "tag_name" | awk -F \" '{print $4}')" + + if [ -z "$remote_version" ]; then + printf "${RED}Something went wrong when ${YLW}resolving the lastest version${NC}: either you don't have connection to Github or you're rate-limited.\n" + exit 1 + fi + ;; + *) + # Check if this version really exist + ver_check="https://github.com/simplex-chat/simplexmq/releases/tag/${VER}" + + if curl -o /dev/null --proto '=https' --tlsv1.2 -sf -L "${ver_check}"; then + bin_url="https://github.com/simplex-chat/simplexmq/releases/download/${VER}" + remote_version="${VER}" + else + printf "Provided version ${BLU}%s${NC} ${RED}doesn't exist${NC}! Switching to ${BLU}latest${NC}.\n" "${VER}" + VER='latest' + + # Re-execute check + check_versions + + # Everything has been done, so return from the function + return 0 + fi + ;; + esac + set +u - for i in $path_conf_etc/*; do - if [ -d "$i" ]; then - case "$i" in - *simplex) apps="smp $apps" ;; - *simplex-xftp) apps="xftp $apps" ;; - esac + for i in smp xftp; do + # Only check local directory where binaries are installed by the script + if command -v "/usr/local/bin/$i-server" >/dev/null; then + apps="$i $apps" fi done set -u -} -set_version() { - ver="${VER:-latest}" - - case "$ver" in - latest) - bin="https://github.com/simplex-chat/simplexmq/releases/latest/download" - remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')" - ;; - *) - bin="https://github.com/simplex-chat/simplexmq/releases/download/${ver}" - remote_version="${ver}" - ;; - esac -} - -update_scripts() { - curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update" - curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_uninstall" -o "$path_tmp_bin_uninstall" && chmod +x "$path_tmp_bin_uninstall" - curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_stopscript" -o "$path_tmp_bin_stopscript" && chmod +x "$path_tmp_bin_stopscript" - - if diff -q "$path_bin_uninstall" "$path_tmp_bin_uninstall" > /dev/null 2>&1; then - printf -- "- ${YLW}Uninstall script is up-to-date${NC}.\n" - rm "$path_tmp_bin_uninstall" - else - printf -- "- Updating uninstall script..." - mv "$path_tmp_bin_uninstall" "$path_bin_uninstall" - printf "${GRN}Done!${NC}\n" + if [ -z "$apps" ]; then + printf "${RED}No simplex servers installed! Aborting.${NC}\n" + exit 1 fi - if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then - printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n" - rm "$path_tmp_bin_stopscript" - else - printf -- "- Updating stopscript script..." - mv "$path_tmp_bin_stopscript" "$path_bin_stopscript" - printf "${GRN}Done!${NC}\n" - fi + for server in $apps; do + # Check if info file is present + if [ -f "$path_conf_info/release" ]; then + # If present, source it + . "$path_conf_info/release" 2>/dev/null - if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then - printf -- "- ${YLW}Update script is up-to-date${NC}.\n" - rm "$path_tmp_bin_update" - else - printf -- "- Updating update script..." - mv "$path_tmp_bin_update" "$path_bin_update" - printf "${GRN}Done!${NC}\n" - printf -- "- Re-executing Update script with latest updates..." - exec sh "$path_bin_update" "continue" - fi -} - -update_systemd() { - service="${1}-server" - eval "scripts_systemd=\$scripts_systemd_${1}" - eval "path_systemd=\$path_systemd_${1}" - eval "path_tmp_systemd=\$path_tmp_systemd_${1}" - - curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd" -o "$path_tmp_systemd" - - if diff -q "$path_systemd" "$path_tmp_systemd" > /dev/null 2>&1; then - printf -- "- ${YLW}%s service is up-to-date${NC}.\n" "$service" - rm "$path_tmp_systemd" - else - printf -- "- Updating %s service..." "$service" - mv "$path_tmp_systemd" "$path_systemd" - systemctl daemon-reload - printf "${GRN}Done!${NC}\n" - fi - - unset service scripts_systemd path_systemd path_tmp_systemd -} - -update_bins() { - service="${1}-server" - eval "bin=\$bin_${1}" - eval "path_bin=\$path_bin_${1}" - - set_ver() { - local_version='unset' - sed -i -- "s/local_version_${1}=.*/local_version_${1}='${remote_version}'/" "$path_conf_info/release" - } - - if [ -f "$path_conf_info/release" ]; then - . "$path_conf_info/release" 2>/dev/null - - set +u - eval "local_version=\$local_version_${1}" - set -u - - if [ -z "${local_version}" ]; then - set_ver "$1" - fi - else - printf 'local_version_xftp=\nlocal_version_smp=\n' > "$path_conf_info/release" - set_ver "$1" - fi - - if [ "$local_version" != "$remote_version" ]; then - if systemctl is-active --quiet "$service"; then - printf -- "- Stopping %s service..." "$service" - systemctl stop "$service" - printf "${GRN}Done!${NC}\n" - - printf -- "- Updating %s to %s..." "$service" "$remote_version" - curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin" - printf "${GRN}Done!${NC}\n" - - printf -- "- Starting %s service..." "$service" - systemctl start "$service" - printf "${GRN}Done!${NC}\n" + # Check if line containing local version exists in file + if grep -q "local_version_${server}" "$path_conf_info/release"; then + # if exists, set the var + eval "local_version=\$local_version_${server}" + else + # If it doesn't, append it to file + printf "local_version_${server}=unset\n" >> "$path_conf_info/release" + # And set it in script (so we don't have to re-source the file) + eval "local_version_${server}=unset" + fi else - printf -- "- Updating %s to %s..." "$service" "$remote_version" - curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin" - printf "${GRN}Done!${NC}\n" + # If there isn't info file, populate it + printf "local_version_${server}=unset\n" >> "$path_conf_info/release" fi - else - printf -- "- ${YLW}%s is up-to-date${NC}.\n" "$service" - fi + done - set_ver "$1" - - unset service bin path_bin local_version + # Return + return 0 } +# Checks the distro and sets the urls variables +check_distro() { + . /etc/os-release + + case "$VERSION_ID" in + 20.04|22.04) : ;; + 24.04) VERSION_ID='22.04' ;; + *) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;; + esac + + version="$(printf '%s' "$VERSION_ID" | tr '.' '_')" + arch="$(uname -p)" + + case "$arch" in + x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;; + *) printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;; + esac + + bin_url_smp="$bin_url/smp-server-ubuntu-${version}-${arch}" + bin_url_xftp="$bin_url/xftp-server-ubuntu-${version}-${arch}" + + return 0 +} + +# General checks that must be performed on the initial execution of script checks() { if [ "$(id -u)" -ne 0 ]; then printf "This script is intended to be run with root privileges. Please re-run script using sudo.\n" exit 1 fi - set_version - os_test - installed_test + check_versions + check_distro - mkdir -p $path_conf_info + mkdir -p $path_conf_info $path_tmp_bin + + return 0 } -main() { - checks +############################# +### Support functions END ### +############################# - set +u - if [ "$1" != "continue" ]; then - set -u - printf "Updating scripts...\n" - update_scripts - else - set -u +###################### +### Main functions ### +###################### + +# Downloads thing to directory and checks its sanity +download_thing() { + thing="$1" + path="$2" + check_pattern="$3" + err_msg="$4" + + curl --proto '=https' --tlsv1.2 -sSf -L "$thing" -o "$path" + + type="$(file "$path")" + + case "$type" in + *script*|*executable*) chmod +x "$path" ;; + esac + + if ! check_sanity "$path" "$check_pattern"; then + printf "${RED}Something went wrong when downloading ${YLW}%s${NC}: either you don't have connection to Github or you're rate-limited.\n" "$err_msg" + exit 1 + fi + + return 0 +} + +# Downloads all necessary files to temp dir and set update messages for the menu +download_all() { + download_thing "$scripts_url_update" "$path_tmp_bin_update" 'string: /usr/bin/env' 'Update script' + if change_check "$path_tmp_bin_update" "$path_bin_update"; then + msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-update${NC}" + msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}update" + fi + + download_thing "$scripts_url_stopscript" "$path_tmp_bin_stopscript" 'string: /usr/bin/env' 'Stop script' + if change_check "$path_tmp_bin_stopscript" "$path_bin_stopscript"; then + msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-stopscript${NC}" + msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}stop" + fi + + download_thing "$scripts_url_uninstall" "$path_tmp_bin_uninstall" 'string: /usr/bin/env' 'Uninstall script' + if change_check "$path_tmp_bin_uninstall" "$path_bin_uninstall"; then + msg_scripts="${msg_scripts+$msg_scripts, }${YLW}simplex-servers-uninstall${NC}" + msg_scripts_raw="${msg_scripts_raw+$msg_scripts_raw/}uninstall" + fi + + for i in $apps; do + service="${i}-server" + eval "scripts_url_systemd_final=\$scripts_url_systemd_${i}" + eval "path_tmp_systemd_final=\$path_tmp_systemd_${i}" + eval "path_systemd_final=\$path_systemd_${i}" + + download_thing "$scripts_url_systemd_final" "$path_tmp_systemd_final" 'string: [Unit]' "$service systemd service" + if change_check "$path_tmp_systemd_final" "$path_systemd_final"; then + msg_services="${msg_services+$msg_services, }${YLW}$service.service${NC}" + msg_services_raw="${msg_services_raw+$msg_services_raw/}$service" + fi + done + + for i in $apps; do + service="${i}-server" + eval "local_version=\$local_version_${i}" + + if change_check "$local_version" "$remote_version"; then + msg_bins="${msg_bins+$msg_bins$NL} - ${YLW}$service${NC}: from ${BLU}$local_version${NC} to ${BLU}$remote_version${NC}" + msg_bins_alt="${msg_bins_alt+$msg_bins_alt, }${YLW}$service${NC}" + msg_bins_raw="${msg_bins_raw+$msg_bins_raw/}$service" + fi + done + + return 0 +} + +# Updates systemd and scripts. This function depends om variables from "download_all" +update_misc() { + OLD_IFS="$IFS" + + IFS='/' + for script in $msg_scripts_raw; do + case "$script" in + update) + printf -- "- Updating update script..." + mv "$path_tmp_bin_update" "$path_bin_update" + printf "${GRN}Done!${NC}\n" + printf -- "- Re-executing Update script..." + exec env UPDATE_SCRIPT_DONE=1 "$path_bin_update" "${selection}" + ;; + stop) + printf -- "- Updating stopscript script..." + mv "$path_tmp_bin_stopscript" "$path_bin_stopscript" + printf "${GRN}Done!${NC}\n" + ;; + uninstall) + printf -- "- Updating uninstall script..." + mv "$path_tmp_bin_uninstall" "$path_bin_uninstall" + printf "${GRN}Done!${NC}\n" + ;; + esac + done + + for service in $msg_services_raw; do + app="${service%%-*}" + eval "path_systemd=\$path_systemd_${app}" + eval "path_tmp_systemd=\$path_tmp_systemd_${app}" + + printf -- "- Updating %s service..." "$service" + mv "$path_tmp_systemd" "$path_systemd" + systemctl daemon-reload + printf "${GRN}Done!${NC}\n" + done + + IFS="$OLD_IFS" + return 0 +} + +# Updates binaries. This function depends on variables from "download_all" +update_bins() { + OLD_IFS="$IFS" + + IFS='/' + for service in $msg_bins_raw; do + app="${service%%-*}" + eval "local_version=\$local_version_${app}" + eval "bin_url_final=\$bin_url_${app}" + eval "path_tmp_bin_final=\$path_tmp_bin_${app}" + eval "path_bin_final=\$path_bin_${app}" + + # If systemd service is active + if systemctl is-active --quiet "$service"; then + printf -- "- Stopping %s service..." "$service" + systemctl stop "$service" + printf "${GRN}Done!${NC}\n" + + printf -- "- Updating ${YLW}%s${NC} from ${BLU}%s${NC} to ${BLU}%s${NC}..." "$service" "$local_version" "$remote_version" + download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service" + mv "$path_tmp_bin_final" "$path_bin_final" + printf "${GRN}Done!${NC}\n" + + printf -- "- Starting %s service..." "$service" + systemctl start "$service" + printf "${GRN}Done!${NC}\n" + else + # If systemd service is NOT active + printf -- "- Updating ${YLW}%s${NC} from ${BLU}%s${NC} to ${BLU}%s${NC}..." "$service" "$local_version" "$remote_version" + download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service" + mv "$path_tmp_bin_final" "$path_bin_final" + printf "${GRN}Done!${NC}\n" + fi + + # Don't forget to set version + sed -i -- "s|local_version_${app}=.*|local_version_${app}='${remote_version}'|" "$path_conf_info/release" + done + + IFS="$OLD_IFS" + return 0 +} + +# Just download binaries +download_bins() { + OLD_IFS="$IFS" + + IFS='/' + for service in $msg_bins_raw; do + app="${service%%-*}" + eval "local_version=\$local_version_${app}" + eval "bin_url_final=\$bin_url_${app}" + eval "path_tmp_bin_final=\$path_tmp_bin_${app}" + eval "path_bin_final=\$path_bin_${app}" + + printf -- "- Downloading ${YLW}%s${NC} binary..." "$service" + download_thing "$bin_url_final" "$path_tmp_bin_final" 'file: ELF' "$service" + printf "${GRN}Done!${NC}\n" + done + + IFS="$OLD_IFS" + return 0 +} + +menu_init_help() { + menu_help="Update script for SimpleX servers and scripts.${NL}${NL}" + menu_help="${menu_help}${BLD}${UNDRL}Usage:${NC} [] ${BLD}simplex-servers-update${NC}${NL} [] ${BLD}simplex-servers-update${NC} []${NL}${NL}" + menu_help="${menu_help}${BLD}${UNDRL}Subcommands:${NC}${NL}" + menu_help_sub=" ${BLD}[a]ll${NC} Update everything without confirmation${NL}" + menu_help_sub="${menu_help_sub} ${BLD}[b]inaries${NC} Update binaries only without confirmation${NL}" + menu_help_sub="${menu_help_sub} ${BLD}[d]ownload${NC} Download everything without updating${NL}" + menu_help_sub="${menu_help_sub} ${BLD}[h]elp${NC} Print this message${NL}${NL}" + menu_help="${menu_help}${menu_help_sub}" + menu_help="${menu_help}${BLD}${UNDRL}Variables:${NC}${NL}" + menu_help="${menu_help} ${BLD}VER=v3.2.1-beta.0${NC} Update binaries to specified version${NL}" + + return 0 +} + +menu_init() { + menu_end="${RED}x${NC}) Exit${NL}${NL}Selection: " + menu_option_download="${GRN}d${NC}) Download files only${NL}" + + if [ -n "${msg_scripts:-}" ]; then + menu_option_misc_raw="${menu_option_misc_raw+${menu_option_misc_raw}${NL}} - script(s): ${msg_scripts}" + fi + + if [ -n "${msg_services:-}" ]; then + menu_option_misc_raw="${menu_option_misc_raw+${menu_option_misc_raw}${NL}} - systemd service file(s): ${msg_services}" + fi + + menu_option_all="${GRN}a${NC}) Update all: ${BLU}(recommended)${NC}${NL}${menu_option_misc_raw+${menu_option_misc_raw}${NL}}${msg_bins+${msg_bins}${NL}}" + + if [ -n "${msg_bins:-}" ]; then + menu_option_bins="${GRN}b${NC}) Update server binaries: ${msg_bins_alt}${NL}" + fi + + # Abort early if there's neither update binaries, nor update scripts options + if [ -z "${menu_option_bins:-}" ] && [ -z "${menu_option_misc_raw:-}" ]; then + printf "${YLW}Everything is up-to-date${NC}.\n" + exit 0 + fi + + menu="${menu_option_all}${menu_option_bins:-}${menu_option_download}${menu_end}" + + return 0 +} + +options_parse() { + selection="$1" + + case "$selection" in + a|all) + check=0 + if [ -z "${menu_option_misc_raw:-}" ] && [ -z "${menu_option_bins:-}" ]; then + printf "${YLW}Everything is up-to-date${NC}.\n" + else + if [ -n "${menu_option_misc_raw:-}" ]; then + update_misc + fi + if [ -n "${menu_option_bins:-}" ]; then + update_bins + fi + fi + ;; + b|binaries) + check=0 + if [ -n "${menu_option_bins:-}" ]; then + update_bins + else + printf "${YLW}Binaries is up-to-date${NC}.\n" + fi + ;; + d|download) + check=0 + if [ -n "${menu_option_bins:-}" ]; then + download_bins + fi + + printf "\n${YLW}Scripts${NC}/${YLW}services${NC}/${YLW}binaries${NC} has been downloaded to ${BLU}%s${NC}\n" "$path_tmp_bin" + ;; + x) + check=0 + ;; + *) + check=1 + ;; + esac + + return "$check" +} + +########################## +### Main functions END ### +########################## + +############ +### Init ### +############ + +main() { + # Early hook to print Done after script re-execution + if [ -n "${UPDATE_SCRIPT_DONE:-}" ]; then printf "${GRN}Done!${NC}\n" fi - printf "Updating systemd services...\n" - for i in $apps; do - update_systemd "$i" - done - - printf "Updating simplex servers...\n" - for i in $apps; do - update_bins "$i" - done + # Early help menu + menu_init_help - rm -rf "$path_tmp_bin" + case "${1:-}" in + h|help) + printf '%b' "$menu_help" + exit 0 + ;; + esac + + checks + download_all + menu_init + + onetime=0 + while true; do + if [ "$onetime" = 0 ]; then + onetime=1 + + if [ -n "${1:-}" ]; then + selection="$1" + else + printf '%b' "$menu" + read selection + fi + else + read selection + fi + + if options_parse "$selection"; then + break + else + # Rerender whole menu if the first non-interactive option was bogus + if [ -n "${1:-}" ]; then + onetime=0 + shift 1 + else + # Erase last line + printf '\e[A\e[K' + # Only rerended selection + printf 'Selection: ' + fi + fi + done } main "$@" From 55ff58165568da126bfcca5365e6ed8daea303b9 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 15 Feb 2025 11:31:05 +0000 Subject: [PATCH 35/51] SMP client: dont block on writing to sending queues (#1454) * SMP client: dont block on writing to sending queues * only fork if full --- src/Simplex/Messaging/Client.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index bde663b32..b1b5bfa53 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -105,7 +105,7 @@ module Simplex.Messaging.Client where import Control.Applicative ((<|>)) -import Control.Concurrent (ThreadId, forkFinally, killThread, mkWeakThreadId) +import Control.Concurrent (ThreadId, forkFinally, forkIO, killThread, mkWeakThreadId) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception @@ -1086,11 +1086,11 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do pure [Response entityId $ Left $ PCETransportError e] TBTransmissions s n rs | n > 0 -> do - atomically $ writeTBQueue sndQ (Nothing, s) -- do not expire batched responses + nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses mapConcurrently (getResponse c Nothing) rs | otherwise -> pure [] TBTransmission s r -> do - atomically $ writeTBQueue sndQ (Nothing, s) + nonBlockingWriteTBQueue sndQ (Nothing, s) (: []) <$> getResponse c Nothing r -- | Send Protocol command @@ -1112,13 +1112,18 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan Right t | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg | otherwise -> do - atomically $ writeTBQueue sndQ (Just r, s) + nonBlockingWriteTBQueue sndQ (Just r, s) response <$> getResponse c tOut r where s | batch = tEncodeBatch1 t | otherwise = tEncode t +nonBlockingWriteTBQueue :: TBQueue a -> a -> IO () +nonBlockingWriteTBQueue q x = do + sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q x $> True) + unless sent $ void $ forkIO $ atomically $ writeTBQueue q x + getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg) getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar) From fa67d128d1d1c3edb3c49886f096c36e3f4da0d0 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 15 Feb 2025 12:40:10 +0000 Subject: [PATCH 36/51] agent: fix deleting messages after delivery to avoid deleting shared message bodies (#1455) * agent: fix deleting messages after delivery to avoid deleting shared message bodies * fix, comments * rename * comment --- .../Messaging/Agent/Store/AgentStore.hs | 49 +++++++++++++------ 1 file changed, 34 insertions(+), 15 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index bf602627b..33beab129 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -1001,12 +1001,13 @@ deleteMsg db connId msgId = DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId) deleteMsgContent :: DB.Connection -> ConnId -> InternalId -> IO () -deleteMsgContent db connId msgId = +deleteMsgContent db connId msgId = do #if defined(dbPostgres) DB.execute db "UPDATE messages SET msg_body = ''::BYTEA WHERE conn_id = ? AND internal_id = ?" (connId, msgId) #else DB.execute db "UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?" (connId, msgId) #endif + DB.execute db "UPDATE snd_messages SET snd_message_body_id = NULL WHERE conn_id = ? AND internal_id = ?" (connId, msgId) deleteDeliveredSndMsg :: DB.Connection -> ConnId -> InternalId -> IO () deleteDeliveredSndMsg db connId msgId = do @@ -1019,21 +1020,39 @@ deleteSndMsgDelivery db connId SndQueue {dbQueueId} msgId keepForReceipt = do db "DELETE FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? AND internal_id = ?" (connId, dbQueueId, msgId) - cnt <- countPendingSndDeliveries_ db connId msgId - when (cnt == 0) $ do - maybeFirstRow id (DB.query db "SELECT rcpt_internal_id, rcpt_status, snd_message_body_id FROM snd_messages WHERE conn_id = ? AND internal_id = ?" (connId, msgId)) >>= \case - Just (Just (_ :: Int64), Just MROk, sndMsgBodyId_) -> do - forM_ sndMsgBodyId_ deleteSndMsgBody - deleteMsg db connId msgId - Just (_, _, Just (sndMsgBodyId :: Int64)) -> do - deleteSndMsgBody sndMsgBodyId - delKeepForReceipt - _ -> - delKeepForReceipt + getRcptAndBodyId >>= mapM_ deleteMsgAndBody where - delKeepForReceipt = if keepForReceipt then deleteMsgContent db connId msgId else deleteMsg db connId msgId - deleteSndMsgBody sndMsgBodyId = - DB.execute db "DELETE FROM snd_message_bodies WHERE snd_message_body_id = ?" (Only sndMsgBodyId) + getRcptAndBodyId :: IO (Maybe (Maybe MsgReceiptStatus, Maybe Int64)) + getRcptAndBodyId = + -- Get receipt status and message body ID if there are no pending deliveries. + -- The current delivery is deleted above. + maybeFirstRow id $ + DB.query + db + [sql| + SELECT rcpt_status, snd_message_body_id FROM snd_messages + WHERE NOT EXISTS (SELECT 1 FROM snd_message_deliveries WHERE conn_id = ? AND internal_id = ? AND failed = 0) + AND conn_id = ? AND internal_id = ? + |] + (connId, msgId, connId, msgId) + deleteMsgAndBody :: (Maybe MsgReceiptStatus, Maybe Int64) -> IO () + deleteMsgAndBody (rcptStatus_, sndMsgBodyId_) = do + let del = case rcptStatus_ of + -- we are not deleting message if receipt is not received or had incorrect hash (for debugging). + Just MROk -> deleteMsg + _ -> if keepForReceipt then deleteMsgContent else deleteMsg + del db connId msgId + forM_ sndMsgBodyId_ $ \bodyId -> + -- Delete message body if it is not used by any snd message. + -- The current snd message is already deleted by deleteMsg or cleared by deleteMsgContent. + DB.execute + db + [sql| + DELETE FROM snd_message_bodies + WHERE NOT EXISTS (SELECT 1 FROM snd_messages WHERE snd_message_body_id = ?) + AND snd_message_body_id = ? + |] + (bodyId, bodyId) countPendingSndDeliveries_ :: DB.Connection -> ConnId -> InternalId -> IO Int countPendingSndDeliveries_ db connId msgId = do From c192339af9e9342902731f2d49ff380359be0dec Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 15 Feb 2025 15:36:44 +0000 Subject: [PATCH 37/51] 6.3.0.5 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 680bf3e91..334dcbcfe 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.4 +version: 6.3.0.5 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From fa319d798ab17c02f0d8206605a19b4f30eeea2b Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 17 Feb 2025 23:11:34 +0000 Subject: [PATCH 38/51] smp server: remove empty journals when opening message queue (#1456) * smp server: remove empty journals when opening message queue * update, do not backup state * test * version * do not close queue state when queue is opened for writing * comment * quota = 4 * refactor openMsgQueue to prevent extra state backups * use interval in config * version, expire backups after 5 min * refactor * test --- cabal.project | 1 + simplexmq.cabal | 1 + src/Simplex/Messaging/Server/Env/STM.hs | 20 +- src/Simplex/Messaging/Server/Main.hs | 5 +- .../Messaging/Server/MsgStore/Journal.hs | 183 ++++++++++++------ src/Simplex/Messaging/Server/MsgStore/STM.hs | 6 +- .../Messaging/Server/MsgStore/Types.hs | 4 +- tests/AgentTests/FunctionalAPITests.hs | 1 + tests/CoreTests/MsgStoreTests.hs | 140 ++++++++++++-- tests/README.md | 7 + 10 files changed, 280 insertions(+), 88 deletions(-) create mode 100644 tests/README.md diff --git a/cabal.project b/cabal.project index b26c04055..924f09c9e 100644 --- a/cabal.project +++ b/cabal.project @@ -4,6 +4,7 @@ packages: . -- packages: . ../http2 -- packages: . ../network-transport +-- uncomment two sections below to run tests with coverage -- package * -- coverage: True -- library-coverage: True diff --git a/simplexmq.cabal b/simplexmq.cabal index 334dcbcfe..40da60b49 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -457,6 +457,7 @@ test-suite simplexmq-test apps/smp-server/web default-extensions: StrictData + -- add -fhpc to ghc-options to run tests with coverage ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1 build-depends: base diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 4044e0d22..58d57a4c5 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -25,7 +25,7 @@ import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (isJust, isNothing) import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (getCurrentTime, nominalDay) import Data.Time.Clock.System (SystemTime) import qualified Data.X509 as X import Data.X509.Validation (Fingerprint (..)) @@ -297,8 +297,8 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt msgStore@(AMS _ store) <- case msgStoreType of AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota} AMSType SMSJournal -> case storeMsgsFile of - Just storePath -> - let cfg = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval} + Just storePath -> + let cfg = mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval in AMS SMSJournal <$> newMsgStore cfg Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure ntfStore <- NtfStore <$> TM.emptyIO @@ -357,6 +357,20 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt | isJust storeMsgsFile = SPMMessages | otherwise = SPMQueues +mkJournalStoreConfig :: FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig +mkJournalStoreConfig storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval = + JournalStoreConfig + { storePath, + quota = msgQueueQuota, + pathParts = journalMsgStoreDepth, + maxMsgCount = maxJournalMsgCount, + maxStateLines = maxJournalStateLines, + stateTailSize = defaultStateTailSize, + idleInterval = idleQueueInterval, + expireBackupsAfter = 14 * nominalDay, + keepMinBackups = 2 + } + newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent newSMPProxyAgent smpAgentCfg random = do smpAgent <- newSMPClientAgent smpAgentCfg random diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 1d21ffa6a..a03aaa68d 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -44,7 +44,6 @@ import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information -import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.QueueStore.STM (readQueueStore) import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, supportedServerSMPRelayVRange) @@ -147,7 +146,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = doesFileExist iniFile >>= \case True -> readIniFile iniFile >>= either exitError a _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration} + newJournalMsgStore = + let cfg = mkJournalStoreConfig storeMsgsJournalDir defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration + in newMsgStore cfg iniFile = combine cfgPath "smp-server.ini" serverVersion = "SMP server v" <> simplexMQVersion defaultServerPorts = "5223,443" diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 0834ad1d9..3b897de37 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -15,7 +15,7 @@ {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Server.MsgStore.Journal - ( JournalMsgStore (queueStore, random), + ( JournalMsgStore (queueStore, random, expireBackupsBefore), JournalQueue, JournalMsgQueue (queue, state), JMQueue (queueDirectory, statePath), @@ -28,7 +28,7 @@ module Simplex.Messaging.Server.MsgStore.Journal SJournalType (..), msgQueueDirectory, msgQueueStatePath, - readWriteQueueState, + readQueueState, newMsgQueueState, newJournalId, appendState, @@ -48,12 +48,13 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (intercalate) -import Data.Maybe (catMaybes, fromMaybe, isNothing) +import Data.List (intercalate, sort) +import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe) +import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) -import Data.Time.Format.ISO8601 (iso8601Show) +import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) import GHC.IO (catchAny) import Simplex.Messaging.Agent.Client (getMapLock, withLockMap) import Simplex.Messaging.Agent.Lock @@ -65,10 +66,10 @@ import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$>)) +import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=), (<$$>)) import System.Directory import System.Exit -import System.FilePath (()) +import System.FilePath (takeFileName, ()) import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout) import qualified System.IO as IO import System.Random (StdGen, genByteString, newStdGen) @@ -77,7 +78,8 @@ data JournalMsgStore = JournalMsgStore { config :: JournalStoreConfig, random :: TVar StdGen, queueLocks :: TMap RecipientId Lock, - queueStore :: STMQueueStore JournalQueue + queueStore :: STMQueueStore JournalQueue, + expireBackupsBefore :: UTCTime } data JournalStoreConfig = JournalStoreConfig @@ -91,7 +93,10 @@ data JournalStoreConfig = JournalStoreConfig maxStateLines :: Int, stateTailSize :: Int, -- time in seconds after which the queue will be closed after message expiration - idleInterval :: Int64 + idleInterval :: Int64, + -- expire state backup files + expireBackupsAfter :: NominalDiffTime, + keepMinBackups :: Int } data JournalQueue = JournalQueue @@ -238,7 +243,8 @@ instance MsgStoreClass JournalMsgStore where random <- newTVarIO =<< newStdGen queueLocks <- TM.emptyIO queueStore <- newQueueStore - pure JournalMsgStore {config, random, queueLocks, queueStore} + expireBackupsBefore <- addUTCTime (- expireBackupsAfter config) <$> getCurrentTime + pure JournalMsgStore {config, random, queueLocks, queueStore, expireBackupsBefore} setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO () setStoreLog st sl = atomically $ writeTVar (storeLog $ queueStore st) (Just sl) @@ -265,7 +271,7 @@ instance MsgStoreClass JournalMsgStore where r' <- case strDecode $ B.pack queueId of Right rId -> getQueue ms SRecipient rId >>= \case - Right q -> unStoreIO (getMsgQueue ms q) *> action q <* closeMsgQueue q + Right q -> unStoreIO (getMsgQueue ms q False) *> action q <* closeMsgQueue q Left AUTH -> do logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir removeQueueDirectory_ dir @@ -307,15 +313,15 @@ instance MsgStoreClass JournalMsgStore where queueRec' = queueRec {-# INLINE queueRec' #-} - getMsgQueue :: JournalMsgStore -> JournalQueue -> StoreIO JournalMsgQueue - getMsgQueue ms@JournalMsgStore {random} JournalQueue {recipientId = rId, msgQueue_} = + getMsgQueue :: JournalMsgStore -> JournalQueue -> Bool -> StoreIO JournalMsgQueue + getMsgQueue ms@JournalMsgStore {random} JournalQueue {recipientId = rId, msgQueue_} forWrite = StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure where newQ = do let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir $ B.unpack (strEncode rId) queue = JMQueue {queueDirectory = dir, statePath} - q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue) + q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue) atomically $ writeTVar msgQueue_ $ Just q pure q where @@ -342,7 +348,7 @@ instance MsgStoreClass JournalMsgStore where pure r where peek = do - mq <- getMsgQueue ms q + mq <- getMsgQueue ms q False (mq,) <$$> tryPeekMsg_ q mq -- only runs action if queue is not empty @@ -390,7 +396,7 @@ instance MsgStoreClass JournalMsgStore where writeMsg :: JournalMsgStore -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms q' logState msg = isolateQueue q' "writeMsg" $ do - q <- getMsgQueue ms q' + q <- getMsgQueue ms q' True StoreIO $ (`E.finally` updateActiveAt q') $ do st@MsgQueueState {canWrite, size} <- readTVarIO (state q) let empty = size == 0 @@ -425,7 +431,6 @@ instance MsgStoreClass JournalMsgStore where createQueueDir = do createDirectoryIfMissing True queueDirectory sh <- openFile statePath AppendMode - B.hPutStr sh "" rh <- createNewJournal queueDirectory $ journalId rs let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing} atomically $ writeTVar handles $ Just hs @@ -488,12 +493,65 @@ tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure isolateQueueId :: String -> JournalMsgStore -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op -openMsgQueue :: JournalMsgStore -> JMQueue -> IO JournalMsgQueue -openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do - (st, sh) <- readWriteQueueState ms statePath - (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh - let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} - mkJournalQueue q st' (Just hs) +openMsgQueue :: JournalMsgStore -> JMQueue -> Bool -> IO JournalMsgQueue +openMsgQueue ms@JournalMsgStore {config} q@JMQueue {queueDirectory = dir, statePath} forWrite = do + (st_, shouldBackup) <- readQueueState ms statePath + case st_ of + Nothing -> do + st <- newMsgQueueState <$> newJournalId (random ms) + when shouldBackup $ backupQueueState statePath -- rename invalid state file + mkJournalQueue q st Nothing + Just st + | size st == 0 -> do + (st', hs_) <- removeJournals st shouldBackup + mkJournalQueue q st' hs_ + | otherwise -> do + sh <- openBackupQueueState st shouldBackup + (st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh + let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_} + mkJournalQueue q st' (Just hs) + where + -- If the queue is empty, journals are deleted. + -- New journal is created if queue is written to. + -- canWrite is set to True. + removeJournals MsgQueueState {readState = rs, writeState = ws} shouldBackup = E.uninterruptibleMask_ $ do + rjId <- newJournalId $ random ms + let st = newMsgQueueState rjId + hs_ <- + if forWrite + then Just <$> newJournalHandles st rjId + else Nothing <$ backupQueueState statePath + removeJournalIfExists dir rs + unless (journalId ws == journalId rs) $ removeJournalIfExists dir ws + pure (st, hs_) + where + newJournalHandles st rjId = do + sh <- openBackupQueueState st shouldBackup + appendState_ sh st + rh <- closeOnException sh $ createNewJournal dir rjId + pure MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing} + openBackupQueueState st shouldBackup + | shouldBackup = do + -- State backup is made in two steps to mitigate the crash during the backup. + -- Temporary backup file will be used when it is present. + let tempBackup = statePath <> ".bak" + renameFile statePath tempBackup -- 1) temp backup + sh <- openFile statePath AppendMode + closeOnException sh $ appendState sh st -- 2) save state to new file + backupQueueState tempBackup -- 3) timed backup + pure sh + | otherwise = openFile statePath AppendMode + backupQueueState path = do + ts <- getCurrentTime + renameFile path $ stateBackupPath statePath ts + -- remove old backups + times <- sort . mapMaybe backupPathTime <$> listDirectory dir + let toDelete = filter (< expireBackupsBefore ms) $ take (length times - keepMinBackups config) times + mapM_ (safeRemoveFile "removeBackups" . stateBackupPath statePath) toDelete + where + backupPathTime :: FilePath -> Maybe UTCTime + backupPathTime = iso8601ParseM . T.unpack <=< T.stripSuffix ".bak" <=< T.stripPrefix statePathPfx . T.pack + statePathPfx = T.pack $ takeFileName statePath <> "." mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO JournalMsgQueue mkJournalQueue queue st hs_ = do @@ -527,7 +585,11 @@ updateQueueState q log' hs st a = do atomically $ writeTVar (state q) st >> a appendState :: Handle -> MsgQueueState -> IO () -appendState h st = E.uninterruptibleMask_ $ B.hPutStr h $ strEncode st `B.snoc` '\n' +appendState h = E.uninterruptibleMask_ . appendState_ h +{-# INLINE appendState #-} + +appendState_ :: Handle -> MsgQueueState -> IO () +appendState_ h st = B.hPutStr h $ strEncode st `B.snoc` '\n' updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () updateReadPos q log' len hs = do @@ -628,62 +690,57 @@ fixFileSize h pos = do | otherwise -> pure () removeJournal :: FilePath -> JournalState t -> IO () -removeJournal dir JournalState {journalId} = do +removeJournal dir JournalState {journalId} = + safeRemoveFile "removeJournal" $ journalFilePath dir journalId + +removeJournalIfExists :: FilePath -> JournalState t -> IO () +removeJournalIfExists dir JournalState {journalId} = do let path = journalFilePath dir journalId - removeFile path `catchAny` (\e -> logError $ "STORE: removeJournal, " <> T.pack path <> ", " <> tshow e) + handleError "removeJournalIfExists" path $ + whenM (doesFileExist path) $ removeFile path + +safeRemoveFile :: Text -> FilePath -> IO () +safeRemoveFile cxt path = handleError cxt path $ removeFile path + +handleError :: Text -> FilePath -> IO () -> IO () +handleError cxt path a = + a `catchAny` \e -> logError $ "STORE: " <> cxt <> ", " <> T.pack path <> ", " <> tshow e -- This function is supposed to be resilient to crashes while updating state files, -- and also resilient to crashes during its execution. -readWriteQueueState :: JournalMsgStore -> FilePath -> IO (MsgQueueState, Handle) -readWriteQueueState JournalMsgStore {random, config} statePath = +readQueueState :: JournalMsgStore -> FilePath -> IO (Maybe MsgQueueState, Bool) +readQueueState JournalMsgStore {config} statePath = ifM (doesFileExist tempBackup) - (renameFile tempBackup statePath >> readQueueState) - (ifM (doesFileExist statePath) readQueueState writeNewQueueState) + (renameFile tempBackup statePath >> readState) + (ifM (doesFileExist statePath) readState $ pure (Nothing, False)) where tempBackup = statePath <> ".bak" - readQueueState = do + readState = do ls <- B.lines <$> readFileTail case ls of - [] -> writeNewQueueState + [] -> do + logWarn $ "STORE: readWriteQueueState, empty queue state, " <> T.pack statePath + pure (Nothing, False) _ -> do - r@(st, _) <- useLastLine (length ls) True ls - unless (validQueueState st) $ E.throwIO $ userError $ "readWriteQueueState inconsistent state: " <> show st + r <- useLastLine (length ls) True ls + forM_ (fst r) $ \st -> + unless (validQueueState st) $ E.throwIO $ userError $ "readWriteQueueState inconsistent state: " <> show st pure r - writeNewQueueState = do - logWarn $ "STORE: readWriteQueueState, empty queue state - initialized, " <> T.pack statePath - st <- newMsgQueueState <$> newJournalId random - writeQueueState st useLastLine len isLastLine ls = case strDecode $ last ls of - Right st - | len > maxStateLines config || not isLastLine -> - backupWriteQueueState st - | otherwise -> do - -- when state file has fewer than maxStateLines, we don't compact it - sh <- openFile statePath AppendMode - pure (st, sh) + Right st -> + -- when state file has fewer than maxStateLines, we don't compact it + let shouldBackup = len > maxStateLines config || not isLastLine + in pure (Just st, shouldBackup) Left e -- if the last line failed to parse | isLastLine -> case init ls of -- or use the previous line [] -> do logWarn $ "STORE: readWriteQueueState, invalid 1-line queue state - initialized, " <> T.pack statePath - st <- newMsgQueueState <$> newJournalId random - backupWriteQueueState st + pure (Nothing, True) -- backup state file, because last line was invalid ls' -> do logWarn $ "STORE: readWriteQueueState, invalid last line in queue state - using the previous line, " <> T.pack statePath useLastLine len False ls' | otherwise -> E.throwIO $ userError $ "readWriteQueueState invalid state " <> statePath <> ": " <> show e - backupWriteQueueState st = do - -- State backup is made in two steps to mitigate the crash during the backup. - -- Temporary backup file will be used when it is present. - renameFile statePath tempBackup -- 1) temp backup - r <- writeQueueState st -- 2) save state - ts <- getCurrentTime - renameFile tempBackup (statePath <> "." <> iso8601Show ts <> ".bak") -- 3) timed backup - pure r - writeQueueState st = do - sh <- openFile statePath AppendMode - closeOnException sh $ appendState sh st - pure (st, sh) readFileTail = IO.withFile statePath ReadMode $ \h -> do size <- IO.hFileSize h @@ -693,6 +750,9 @@ readWriteQueueState JournalMsgStore {random, config} statePath = then IO.hSeek h AbsoluteSeek (size - sz') >> B.hGet h sz else B.hGet h (fromIntegral size) +stateBackupPath :: FilePath -> UTCTime -> FilePath +stateBackupPath statePath ts = statePath <> "." <> iso8601Show ts <> ".bak" + validQueueState :: MsgQueueState -> Bool validQueueState MsgQueueState {readState = rs, writeState = ws, size} | journalId rs == journalId ws = @@ -739,8 +799,7 @@ removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st removeQueueDirectory_ :: FilePath -> IO () removeQueueDirectory_ dir = - removePathForcibly dir `catchAny` \e -> - logError $ "STORE: removeQueueDirectory, " <> T.pack dir <> ", " <> tshow e + handleError "removeQueueDirectory" dir $ removePathForcibly dir hAppend :: Handle -> Int64 -> ByteString -> IO () hAppend h pos s = do diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 2df41a9f1..05ab31475 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -89,8 +89,8 @@ instance MsgStoreClass STMMsgStore where queueRec' = queueRec {-# INLINE queueRec' #-} - getMsgQueue :: STMMsgStore -> STMQueue -> STM STMMsgQueue - getMsgQueue _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure + getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue + getMsgQueue _ STMQueue {msgQueue_} _ = readTVar msgQueue_ >>= maybe newQ pure where newQ = do msgQueue <- newTQueue @@ -131,7 +131,7 @@ instance MsgStoreClass STMMsgStore where writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) writeMsg ms q' _logState msg = liftIO $ atomically $ do - STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms q' + STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms q' True canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 7317a0fab..679945f55 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -54,7 +54,7 @@ class Monad (StoreMonad s) => MsgStoreClass s where recipientId' :: StoreQueue s -> RecipientId queueRec' :: StoreQueue s -> TVar (Maybe QueueRec) getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message)) - getMsgQueue :: s -> StoreQueue s -> StoreMonad s (MsgQueue s) + getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s) -- the journal queue will be closed after action if it was initially closed or idle longer than interval in config withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) @@ -119,7 +119,7 @@ withPeekMsgQueue st q op a = isolateQueue q op $ getPeekMsgQueue st q >>= a deleteExpiredMsgs :: MsgStoreClass s => s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int deleteExpiredMsgs st q old = isolateQueue q "deleteExpiredMsgs" $ - getMsgQueue st q >>= deleteExpireMsgs_ old q + getMsgQueue st q False >>= deleteExpireMsgs_ old q -- closed and idle queues will be closed after expiration -- returns (expired count, queue size after expiration) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 80fff1dbb..027b4cff3 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -364,6 +364,7 @@ functionalAPITests t = do it "should suspend agent on timeout, even if pending messages not sent" $ testSuspendingAgentTimeout t describe "Batching SMP commands" $ do + -- disable this and enable the following test to run tests with coverage it "should subscribe to multiple (200) subscriptions with batching" $ testBatchedSubscriptions 200 10 t skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $ diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index f97930b52..342b5b25f 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -15,6 +15,7 @@ module CoreTests.MsgStoreTests where import AgentTests.FunctionalAPITests (runRight, runRight_) +import Control.Concurrent (threadDelay) import Control.Concurrent.STM import Control.Exception (bracket) import Control.Monad @@ -24,7 +25,9 @@ import Crypto.Random (ChaChaDRG) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64.URL as B64 +import Data.List (isPrefixOf, isSuffixOf) import Data.Maybe (fromJust) +import Data.Time.Clock (addUTCTime) import Data.Time.Clock.System (getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C @@ -40,7 +43,7 @@ import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue) import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2) import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile) import System.FilePath (()) -import System.IO (IOMode (..), hClose, withFile) +import System.IO (IOMode (..), withFile) import Test.Hspec msgStoreTests :: Spec @@ -52,11 +55,14 @@ msgStoreTests = do describe "queue state" $ do it "should restore queue state from the last line" testQueueState it "should recover when message is written and state is not" testMessageState + it "should remove journal files when queue is empty" testRemoveJournals describe "missing files" $ do it "should create read file when missing" testReadFileMissing it "should switch to write file when read file missing" testReadFileMissingSwitch it "should create write file when missing" testWriteFileMissing it "should create read file when read and write files are missing" testReadAndWriteFilesMissing + describe "Journal message store: queue state backup expiration" $ do + it "should remove old queue state backups" testRemoveQueueStateBackups where someMsgStoreTests :: STMStoreClass s => SpecWith s someMsgStoreTests = do @@ -78,7 +84,9 @@ testJournalStoreCfg = maxMsgCount = 4, maxStateLines = 2, stateTailSize = 256, - idleInterval = 21600 + idleInterval = 21600, + expireBackupsAfter = 0, + keepMinBackups = 1 } mkMessage :: MonadIO m => ByteString -> m Message @@ -235,7 +243,7 @@ testQueueState ms = do state <- newMsgQueueState <$> newJournalId (random ms) withFile statePath WriteMode (`appendState` state) length . lines <$> readFile statePath `shouldReturn` 1 - readQueueState statePath `shouldReturn` state + readQueueState ms statePath `shouldReturn` (Just state, False) length <$> listDirectory dir `shouldReturn` 1 -- no backup let state1 = @@ -246,7 +254,7 @@ testQueueState ms = do } withFile statePath AppendMode (`appendState` state1) length . lines <$> readFile statePath `shouldReturn` 2 - readQueueState statePath `shouldReturn` state1 + readQueueState ms statePath `shouldReturn` (Just state1, False) length <$> listDirectory dir `shouldReturn` 1 -- no backup let state2 = @@ -258,28 +266,26 @@ testQueueState ms = do withFile statePath AppendMode (`appendState` state2) length . lines <$> readFile statePath `shouldReturn` 3 copyFile statePath (statePath <> ".2") - readQueueState statePath `shouldReturn` state2 - length <$> listDirectory dir `shouldReturn` 3 -- new state, copy + backup - length . lines <$> readFile statePath `shouldReturn` 1 + readQueueState ms statePath `shouldReturn` (Just state2, True) + length <$> listDirectory dir `shouldReturn` 2 -- new state + copy + ls <- lines <$> readFile statePath + length ls `shouldBe` 3 + -- mock compacting file + writeFile statePath $ last ls -- corrupt the only line corruptFile statePath - newState <- readQueueState statePath - newState `shouldBe` newMsgQueueState (journalId $ writeState newState) + (Nothing, True) <- readQueueState ms statePath -- corrupt the last line renameFile (statePath <> ".2") statePath removeOtherFiles dir statePath length . lines <$> readFile statePath `shouldReturn` 3 corruptFile statePath - readQueueState statePath `shouldReturn` state1 - length <$> listDirectory dir `shouldReturn` 2 - length . lines <$> readFile statePath `shouldReturn` 1 + readQueueState ms statePath `shouldReturn` (Just state1, True) + length <$> listDirectory dir `shouldReturn` 1 + length . lines <$> readFile statePath `shouldReturn` 3 where - readQueueState statePath = do - (state, h) <- readWriteQueueState ms statePath - hClose h - pure state corruptFile f = do s <- readFile f removeFile f @@ -315,6 +321,108 @@ testMessageState ms = do (Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3 liftIO $ closeMsgQueue q +testRemoveJournals :: JournalMsgStore -> IO () +testRemoveJournals ms = do + g <- C.newRandom + (rId, qr) <- testNewQueueRec g True + let dir = msgQueueDirectory ms rId + statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) + write q s = writeMsg ms q True =<< mkMessage s + + runRight $ do + q <- ExceptT $ addQueue ms rId qr + Just (Message {msgId = mId1}, True) <- write q "message 1" + Just (Message {msgId = mId2}, False) <- write q "message 2" + (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 + (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 + liftIO $ closeMsgQueue q + + ls <- B.lines <$> B.readFile statePath + length ls `shouldBe` 4 + journalFilesCount dir `shouldReturn` 1 + stateBackupCount dir `shouldReturn` 0 + + runRight $ do + q <- ExceptT $ getQueue ms SRecipient rId + -- not removed yet + liftIO $ journalFilesCount dir `shouldReturn` 1 + liftIO $ stateBackupCount dir `shouldReturn` 0 + Nothing <- tryPeekMsg ms q + -- still not removed, queue is empty and not opened + liftIO $ journalFilesCount dir `shouldReturn` 1 + _mq <- isolateQueue q "test" $ getMsgQueue ms q False + -- journal is removed + liftIO $ journalFilesCount dir `shouldReturn` 0 + liftIO $ stateBackupCount dir `shouldReturn` 1 + Just (Message {msgId = mId3}, True) <- write q "message 3" + -- journal is created + liftIO $ journalFilesCount dir `shouldReturn` 1 + Just (Message {msgId = mId4}, False) <- write q "message 4" + (Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q mId3 + (Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4 + Just (Message {msgId = mId5}, True) <- write q "message 5" + Just (Message {msgId = mId6}, False) <- write q "message 6" + liftIO $ journalFilesCount dir `shouldReturn` 1 + Just (Message {msgId = mId7}, False) <- write q "message 7" + -- separate write journal is created + liftIO $ journalFilesCount dir `shouldReturn` 2 + Nothing <- write q "message 8" + (Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms q mId5 + liftIO $ journalFilesCount dir `shouldReturn` 2 + (Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms q mId6 + -- read journal is removed + liftIO $ journalFilesCount dir `shouldReturn` 1 + (Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms q mId7 + (Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId8 + liftIO $ closeMsgQueue q + + journalFilesCount dir `shouldReturn` 1 + runRight $ do + q <- ExceptT $ getQueue ms SRecipient rId + Just (Message {}, True) <- write q "message 8" + liftIO $ journalFilesCount dir `shouldReturn` 1 + liftIO $ stateBackupCount dir `shouldReturn` 2 + liftIO $ closeMsgQueue q + where + journalFilesCount dir = length . filter ("messages." `isPrefixOf`) <$> listDirectory dir + stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir + +testRemoveQueueStateBackups :: IO () +testRemoveQueueStateBackups = do + g <- C.newRandom + (rId, qr) <- testNewQueueRec g True + + ms' <- newMsgStore testJournalStoreCfg {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0} + -- set expiration time 1 second ahead + let ms = ms' {expireBackupsBefore = addUTCTime 1 $ expireBackupsBefore ms'} + + let dir = msgQueueDirectory ms rId + write q s = writeMsg ms q True =<< mkMessage s + + runRight $ do + q <- ExceptT $ addQueue ms rId qr + Just (Message {msgId = mId1}, True) <- write q "message 1" + Just (Message {msgId = mId2}, False) <- write q "message 2" + (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 + (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 + liftIO $ closeMsgQueue q + liftIO $ stateBackupCount dir `shouldReturn` 0 + + q1 <- ExceptT $ getQueue ms SRecipient rId + Just (Message {}, True) <- write q1 "message 3" + Just (Message {}, False) <- write q1 "message 4" + liftIO $ closeMsgQueue q1 + liftIO $ stateBackupCount dir `shouldReturn` 0 + + liftIO $ threadDelay 1000000 + q2 <- ExceptT $ getQueue ms SRecipient rId + Just (Message {}, False) <- write q2 "message 5" + Nothing <- write q2 "message 5" + liftIO $ closeMsgQueue q2 + liftIO $ stateBackupCount dir `shouldReturn` 1 + where + stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir + testReadFileMissing :: JournalMsgStore -> IO () testReadFileMissing ms = do g <- C.newRandom diff --git a/tests/README.md b/tests/README.md new file mode 100644 index 000000000..2a51e23cd --- /dev/null +++ b/tests/README.md @@ -0,0 +1,7 @@ +# Running tests with coverage + +1. Uncomment coverage sections in cabal.project file. +2. Add `-fhpc` to ghc-options of simplexmq-test in simplexmq.cabal file. +3. Disable (`xit`) test "should subscribe to multiple (200) subscriptions with batching", enable (comment `skip`) the next test instead. +4. Run `cabal test`. +5. Open generated coverage report in the browser. From a75e138965b51eb2714e5ccd52c801ca361a7154 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 18 Feb 2025 20:04:58 +0000 Subject: [PATCH 39/51] smp server: remove empty queues journals when expiring messages of idle queues (#1458) * smp server: remove empty queues journals when expiring messages of idle queues * remove unnecessary update * ci: update action * rename --- .github/workflows/build.yml | 2 +- .../Messaging/Server/MsgStore/Journal.hs | 97 ++++++++++++------- src/Simplex/Messaging/Server/MsgStore/STM.hs | 4 +- .../Messaging/Server/MsgStore/Types.hs | 4 +- tests/CoreTests/MsgStoreTests.hs | 37 ++++++- 5 files changed, 104 insertions(+), 40 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 385cd215d..be58c10b4 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -37,7 +37,7 @@ jobs: cabal-version: "3.10.1.0" - name: Cache dependencies - uses: actions/cache@v2 + uses: actions/cache@v3 with: path: | ~/.cabal/store diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 3b897de37..4498677af 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -108,8 +108,12 @@ data JournalQueue = JournalQueue msgQueue_ :: TVar (Maybe JournalMsgQueue), -- system time in seconds since epoch activeAt :: TVar Int64, - -- Just True - empty, Just False - non-empty, Nothing - unknown - isEmpty :: TVar (Maybe Bool) + queueState :: TVar (Maybe QState) -- Nothing - unknown + } + +data QState = QState + { hasPending :: Bool, + hasStored :: Bool } data JMQueue = JMQueue @@ -152,6 +156,12 @@ data JournalState t = JournalState } deriving (Show) +qState :: MsgQueueState -> QState +qState MsgQueueState {size, readState = rs, writeState = ws} = + let hasPending = size > 0 + in QState {hasPending, hasStored = hasPending || msgCount rs > 0 || msgCount ws > 0} +{-# INLINE qState #-} + data JournalType = JTRead | JTWrite data SJournalType (t :: JournalType) where @@ -224,12 +234,20 @@ newtype StoreIO a = StoreIO {unStoreIO :: IO a} instance STMStoreClass JournalMsgStore where stmQueueStore JournalMsgStore {queueStore} = queueStore mkQueue st rId qr = do - lock <- getMapLock (queueLocks st) rId - q <- newTVar $ Just qr - mq <- newTVar Nothing + queueLock <- getMapLock (queueLocks st) rId + queueRec <- newTVar $ Just qr + msgQueue_ <- newTVar Nothing activeAt <- newTVar 0 - isEmpty <- newTVar Nothing - pure $ JournalQueue rId lock q mq activeAt isEmpty + queueState <- newTVar Nothing + pure $ + JournalQueue + { recipientId = rId, + queueLock, + queueRec, + msgQueue_, + activeAt, + queueState + } msgQueue_' = msgQueue_ instance MsgStoreClass JournalMsgStore where @@ -314,7 +332,7 @@ instance MsgStoreClass JournalMsgStore where {-# INLINE queueRec' #-} getMsgQueue :: JournalMsgStore -> JournalQueue -> Bool -> StoreIO JournalMsgQueue - getMsgQueue ms@JournalMsgStore {random} JournalQueue {recipientId = rId, msgQueue_} forWrite = + getMsgQueue ms@JournalMsgStore {random} q'@JournalQueue {recipientId = rId, msgQueue_} forWrite = StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure where newQ = do @@ -323,6 +341,8 @@ instance MsgStoreClass JournalMsgStore where queue = JMQueue {queueDirectory = dir, statePath} q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue forWrite) (createQ queue) atomically $ writeTVar msgQueue_ $ Just q + st <- readTVarIO $ state q + atomically $ writeTVar (queueState q') $ Just $! qState st pure q where createQ :: JMQueue -> IO JournalMsgQueue @@ -333,10 +353,9 @@ instance MsgStoreClass JournalMsgStore where mkJournalQueue queue (newMsgQueueState journalId) Nothing getPeekMsgQueue :: JournalMsgStore -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message)) - getPeekMsgQueue ms q@JournalQueue {isEmpty} = - StoreIO (readTVarIO isEmpty) >>= \case - Just True -> pure Nothing - Just False -> peek + getPeekMsgQueue ms q@JournalQueue {queueState} = + StoreIO (readTVarIO queueState) >>= \case + Just QState {hasPending} -> if hasPending then peek else pure Nothing Nothing -> do -- We only close the queue if we just learnt it's empty. -- This is needed to reduce file descriptors and memory usage @@ -353,15 +372,15 @@ instance MsgStoreClass JournalMsgStore where -- only runs action if queue is not empty withIdleMsgQueue :: Int64 -> JournalMsgStore -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int) - withIdleMsgQueue now ms@JournalMsgStore {config} q action = + withIdleMsgQueue now ms@JournalMsgStore {config} q@JournalQueue {queueState} action = StoreIO $ readTVarIO (msgQueue_ q) >>= \case Nothing -> E.bracket - (unStoreIO $ getPeekMsgQueue ms q) + getNonEmptyMsgQueue (mapM_ $ \_ -> closeMsgQueue q) (maybe (pure (Nothing, 0)) (unStoreIO . run)) where - run (mq, _) = do + run mq = do r <- action mq sz <- getQueueSize_ mq pure (Just r, sz) @@ -372,6 +391,19 @@ instance MsgStoreClass JournalMsgStore where else pure Nothing sz <- unStoreIO $ getQueueSize_ mq pure (r, sz) + where + getNonEmptyMsgQueue :: IO (Maybe JournalMsgQueue) + getNonEmptyMsgQueue = + readTVarIO queueState >>= \case + Just QState {hasStored} + | hasStored -> Just <$> unStoreIO (getMsgQueue ms q False) + | otherwise -> pure Nothing + Nothing -> do + mq <- unStoreIO $ getMsgQueue ms q False + -- queueState was updated in getMsgQueue + readTVarIO queueState >>= \case + Just QState {hasStored} | not hasStored -> closeMsgQueue q $> Nothing + _ -> pure $ Just mq deleteQueue :: JournalMsgStore -> JournalQueue -> IO (Either ErrorType QueueRec) deleteQueue ms q = fst <$$> deleteQueue_ ms q @@ -383,15 +415,15 @@ instance MsgStoreClass JournalMsgStore where where getSize = maybe (pure (-1)) (fmap size . readTVarIO . state) - getQueueMessages_ :: Bool -> JournalMsgQueue -> StoreIO [Message] - getQueueMessages_ drainMsgs q = StoreIO (run []) + getQueueMessages_ :: Bool -> JournalQueue -> JournalMsgQueue -> StoreIO [Message] + getQueueMessages_ drainMsgs q' q = StoreIO (run []) where run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs) - getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg + getMsg msgs hs = chooseReadJournal q' q drainMsgs hs >>= maybe (pure msgs) readMsg where readMsg (rs, h) = do (msg, len) <- hGetMsgAt h $ bytePos rs - updateReadPos q drainMsgs len hs + updateReadPos q' q drainMsgs len hs (msg :) <$> run msgs writeMsg :: JournalMsgStore -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) @@ -402,7 +434,6 @@ instance MsgStoreClass JournalMsgStore where let empty = size == 0 if canWrite || empty then do - atomically $ writeTVar (isEmpty q') (Just False) let canWrt' = quota > size if canWrt' then writeToJournal q st canWrt' msg $> Just (msg, empty) @@ -424,7 +455,7 @@ instance MsgStoreClass JournalMsgStore where rs' = if journalId ws == journalId rs then rs {msgCount = msgPos', byteCount = bytePos'} else rs !st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1} hAppend wh (bytePos ws) msgStr - updateQueueState q logState hs st' $ + updateQueueState q' q logState hs st' $ when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen)) where JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} = q @@ -452,7 +483,7 @@ instance MsgStoreClass JournalMsgStore where tryPeekMsg_ :: JournalQueue -> JournalMsgQueue -> StoreIO (Maybe Message) tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} = - StoreIO $ (readTVarIO handles $>>= chooseReadJournal mq True $>>= peekMsg) >>= setEmpty + StoreIO $ (readTVarIO handles $>>= chooseReadJournal q mq True $>>= peekMsg) where peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst) where @@ -460,9 +491,6 @@ instance MsgStoreClass JournalMsgStore where ml@(msg, _) <- hGetMsgAt h $ bytePos rs atomically $ writeTVar tipMsg $ Just (Just ml) pure $ Just msg - setEmpty msg = do - atomically $ writeTVar (isEmpty q) (Just $ isNothing msg) - pure msg tryDeleteMsg_ :: JournalQueue -> JournalMsgQueue -> Bool -> StoreIO () tryDeleteMsg_ q mq@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ (`E.finally` when logState (updateActiveAt q)) $ @@ -470,7 +498,7 @@ instance MsgStoreClass JournalMsgStore where readTVarIO tipMsg -- if there is no cached tipMsg, do nothing $>>= (pure . fmap snd) $>>= \len -> readTVarIO handles - $>>= \hs -> updateReadPos mq logState len hs $> Just () + $>>= \hs -> updateReadPos q mq logState len hs $> Just () isolateQueue :: JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a isolateQueue JournalQueue {recipientId, queueLock} op = @@ -562,8 +590,8 @@ mkJournalQueue queue st hs_ = do -- to avoid map lookup on queue operations pure JournalMsgQueue {queue, state, tipMsg, handles} -chooseReadJournal :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) -chooseReadJournal q log' hs = do +chooseReadJournal :: JournalQueue -> JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle)) +chooseReadJournal q' q log' hs = do st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q) case writeHandle hs of Just wh | msgPos rs >= msgCount rs && journalId rs /= journalId ws -> do @@ -573,15 +601,16 @@ chooseReadJournal q log' hs = do when log' $ removeJournal (queueDirectory $ queue q) rs let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws} !st' = st {readState = rs'} - updateQueueState q log' hs st' $ pure () + updateQueueState q' q log' hs st' $ pure () pure $ Just (rs', wh) _ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing _ -> pure $ Just (rs, readHandle hs) -updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO () -updateQueueState q log' hs st a = do +updateQueueState :: JournalQueue -> JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO () +updateQueueState q' q log' hs st a = do unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st when log' $ appendState (stateHandle hs) st + atomically $ writeTVar (queueState q') $ Just $! qState st atomically $ writeTVar (state q) st >> a appendState :: Handle -> MsgQueueState -> IO () @@ -591,14 +620,14 @@ appendState h = E.uninterruptibleMask_ . appendState_ h appendState_ :: Handle -> MsgQueueState -> IO () appendState_ h st = B.hPutStr h $ strEncode st `B.snoc` '\n' -updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () -updateReadPos q log' len hs = do +updateReadPos :: JournalQueue -> JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO () +updateReadPos q' q log' len hs = do st@MsgQueueState {readState = rs, size} <- readTVarIO (state q) let JournalState {msgPos, bytePos} = rs let msgPos' = msgPos + 1 rs' = rs {msgPos = msgPos', bytePos = bytePos + len} st' = st {readState = rs', size = size - 1} - updateQueueState q log' hs st' $ writeTVar (tipMsg q) Nothing + updateQueueState q' q log' hs st' $ writeTVar (tipMsg q) Nothing msgQueueDirectory :: JournalMsgStore -> RecipientId -> FilePath msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId = diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index 05ab31475..ac462a71a 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -121,8 +121,8 @@ instance MsgStoreClass STMMsgStore where where getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size) - getQueueMessages_ :: Bool -> STMMsgQueue -> STM [Message] - getQueueMessages_ drainMsgs = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue + getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message] + getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue where snapshotTQueue q = do msgs <- flushTQueue q diff --git a/src/Simplex/Messaging/Server/MsgStore/Types.hs b/src/Simplex/Messaging/Server/MsgStore/Types.hs index 679945f55..ada1ca333 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Types.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Types.hs @@ -60,7 +60,7 @@ class Monad (StoreMonad s) => MsgStoreClass s where withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int) deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec) deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int)) - getQueueMessages_ :: Bool -> MsgQueue s -> StoreMonad s [Message] + getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue s -> StoreMonad s [Message] writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool)) setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running getQueueSize_ :: MsgQueue s -> StoreMonad s Int @@ -82,7 +82,7 @@ withActiveMsgQueues st f = readTVarIO (queues $ stmQueueStore st) >>= foldM run run !acc = fmap (acc <>) . f getQueueMessages :: MsgStoreClass s => Bool -> s -> StoreQueue s -> ExceptT ErrorType IO [Message] -getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs . fst) +getQueueMessages drainMsgs st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs q . fst) {-# INLINE getQueueMessages #-} getQueueSize :: MsgStoreClass s => s -> StoreQueue s -> ExceptT ErrorType IO Int diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 342b5b25f..72599f193 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -28,12 +28,13 @@ import qualified Data.ByteString.Base64.URL as B64 import Data.List (isPrefixOf, isSuffixOf) import Data.Maybe (fromJust) import Data.Time.Clock (addUTCTime) -import Data.Time.Clock.System (getSystemTime) +import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Simplex.Messaging.Crypto (pattern MaxLenBS) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (EntityId (..), Message (..), RecipientId, SParty (..), noMsgFlags) import Simplex.Messaging.Server (MessageStats (..), exportMessages, importMessages, printMessageStats) import Simplex.Messaging.Server.Env.STM (journalMsgStoreDepth, readWriteQueueStore) +import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types @@ -63,6 +64,7 @@ msgStoreTests = do it "should create read file when read and write files are missing" testReadAndWriteFilesMissing describe "Journal message store: queue state backup expiration" $ do it "should remove old queue state backups" testRemoveQueueStateBackups + it "should expire messages in idle queues" testExpireIdleQueues where someMsgStoreTests :: STMStoreClass s => SpecWith s someMsgStoreTests = do @@ -423,6 +425,39 @@ testRemoveQueueStateBackups = do where stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir +testExpireIdleQueues :: IO () +testExpireIdleQueues = do + g <- C.newRandom + (rId, qr) <- testNewQueueRec g True + + ms <- newMsgStore testJournalStoreCfg {idleInterval = 0} + + let dir = msgQueueDirectory ms rId + statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId) + write q s = writeMsg ms q True =<< mkMessage s + + q <- runRight $ do + q <- ExceptT $ addQueue ms rId qr + Just (Message {msgId = mId1}, True) <- write q "message 1" + Just (Message {msgId = mId2}, False) <- write q "message 2" + (Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1 + (Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2 + liftIO $ closeMsgQueue q + pure q + + (Just MsgQueueState {size = 0, readState = rs, writeState = ws}, True) <- readQueueState ms statePath + msgCount rs `shouldBe` 2 + msgCount ws `shouldBe` 2 + + old <- expireBeforeEpoch ExpirationConfig {ttl = 1, checkInterval = 1} -- no old messages + now <- systemSeconds <$> getSystemTime + + (expired_, stored) <- runRight $ idleDeleteExpiredMsgs now ms q old + expired_ `shouldBe` Just 0 + stored `shouldBe` 0 + (Nothing, False) <- readQueueState ms statePath + pure () + testReadFileMissing :: JournalMsgStore -> IO () testReadFileMissing ms = do g <- C.newRandom From 72c2ddcf57deceea68b07ea51569d36231a5e0c0 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 18 Feb 2025 23:39:29 +0000 Subject: [PATCH 40/51] agent: move migrations (#1459) --- simplexmq.cabal | 11 ++- src/Simplex/Messaging/Agent/Store.hs | 3 +- .../Messaging/Agent/Store/Migrations/App.hs | 14 +++ src/Simplex/Messaging/Agent/Store/Postgres.hs | 1 - .../Agent/Store/Postgres/Migrations.hs | 19 +--- .../Agent/Store/Postgres/Migrations/App.hs | 21 +++++ src/Simplex/Messaging/Agent/Store/SQLite.hs | 1 - .../Agent/Store/SQLite/Migrations.hs | 89 +----------------- .../Agent/Store/SQLite/Migrations/App.hs | 93 +++++++++++++++++++ tests/AgentTests/SQLiteTests.hs | 1 + tests/AgentTests/SchemaDump.hs | 1 + 11 files changed, 141 insertions(+), 113 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Migrations/App.hs create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 40da60b49..189c6d831 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -100,6 +100,7 @@ library Simplex.Messaging.Agent.Store.DB Simplex.Messaging.Agent.Store.Interface Simplex.Messaging.Agent.Store.Migrations + Simplex.Messaging.Agent.Store.Migrations.App Simplex.Messaging.Agent.Store.Shared Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client @@ -151,6 +152,7 @@ library Simplex.Messaging.Agent.Store.Postgres.Common Simplex.Messaging.Agent.Store.Postgres.DB Simplex.Messaging.Agent.Store.Postgres.Migrations + Simplex.Messaging.Agent.Store.Postgres.Migrations.App Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies if !flag(client_library) @@ -162,6 +164,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Common Simplex.Messaging.Agent.Store.SQLite.DB Simplex.Messaging.Agent.Store.SQLite.Migrations + Simplex.Messaging.Agent.Store.SQLite.Migrations.App Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications @@ -273,7 +276,6 @@ library , hourglass ==0.2.* , http-types ==0.12.* , http2 >=4.2.2 && <4.3 - , ini ==0.4.1 , iproute ==1.7.* , iso8601-time ==0.1.* , memory ==0.18.* @@ -282,13 +284,10 @@ library , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* - , optparse-applicative >=0.15 && <0.17 - , process ==1.6.* , random >=1.1 && <1.3 , simple-logger ==0.1.* , socks ==0.6.* , stm ==2.5.* - , temporary ==1.3.* , time ==1.12.* , time-manager ==0.0.* , tls >=1.9.0 && <1.10 @@ -304,6 +303,10 @@ library build-depends: case-insensitive ==1.2.* , hashable ==1.4.* + , ini ==0.4.1 + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , temporary ==1.3.* , websockets ==0.12.* if flag(client_postgres) build-depends: diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index b29acc6a6..5449ce848 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -30,7 +30,8 @@ import Data.Type.Equality import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State) import Simplex.Messaging.Agent.Store.Common -import Simplex.Messaging.Agent.Store.Interface (DBOpts, appMigrations, createDBStore) +import Simplex.Messaging.Agent.Store.Interface (DBOpts, createDBStore) +import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448) diff --git a/src/Simplex/Messaging/Agent/Store/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/Migrations/App.hs new file mode 100644 index 000000000..55b5cb8a5 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Migrations/App.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} + +module Simplex.Messaging.Agent.Store.Migrations.App +#if defined(dbPostgres) + ( module Simplex.Messaging.Agent.Store.Postgres.Migrations.App, + ) + where +import Simplex.Messaging.Agent.Store.Postgres.Migrations.App +#else + ( module Simplex.Messaging.Agent.Store.SQLite.Migrations.App, + ) + where +import Simplex.Messaging.Agent.Store.SQLite.Migrations.App +#endif diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index cda905a25..ec4527af3 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres.hs @@ -6,7 +6,6 @@ module Simplex.Messaging.Agent.Store.Postgres ( DBOpts (..), - Migrations.appMigrations, Migrations.getCurrentMigrations, createDBStore, closeDBStore, diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs index 6eb01dc4f..daa0c73f1 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs @@ -5,16 +5,13 @@ {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.Postgres.Migrations - ( appMigrations, - initialize, + ( initialize, run, getCurrentMigrations, ) where import Control.Monad (void) -import Data.List (sortOn) -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Time.Clock (getCurrentTime) @@ -24,23 +21,9 @@ import qualified Database.PostgreSQL.Simple as PSQL import Database.PostgreSQL.Simple.Internal (Connection (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) import Simplex.Messaging.Agent.Store.Postgres.Common -import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial -import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies import Simplex.Messaging.Agent.Store.Shared import UnliftIO.MVar -schemaMigrations :: [(String, Text, Maybe Text)] -schemaMigrations = - [ ("20241210_initial", m20241210_initial, Nothing), - ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) - ] - --- | The list of migrations in ascending order by date -appMigrations :: [Migration] -appMigrations = sortOn name $ map migration schemaMigrations - where - migration (name, up, down) = Migration {name, up, down = down} - initialize :: DBStore -> IO () initialize st = withTransaction' st $ \db -> void $ diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs new file mode 100644 index 000000000..e47fe432a --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.App (appMigrations) where + +import Data.List (sortOn) +import Data.Text (Text) +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies +import Simplex.Messaging.Agent.Store.Shared (Migration (..)) + +schemaMigrations :: [(String, Text, Maybe Text)] +schemaMigrations = + [ ("20241210_initial", m20241210_initial, Nothing), + ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) + ] + +-- | The list of migrations in ascending order by date +appMigrations :: [Migration] +appMigrations = sortOn name $ map migration schemaMigrations + where + migration (name, up, down) = Migration {name, up, down = down} diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 0f3e81273..72792ba65 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -26,7 +26,6 @@ module Simplex.Messaging.Agent.Store.SQLite ( DBOpts (..), - Migrations.appMigrations, Migrations.getCurrentMigrations, createDBStore, closeDBStore, diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 4d4e0d554..fb0523d08 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -8,15 +8,13 @@ {-# LANGUAGE TupleSections #-} module Simplex.Messaging.Agent.Store.SQLite.Migrations - ( appMigrations, - initialize, + ( initialize, run, getCurrentMigrations, ) where import Control.Monad (forM_, when) -import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import Data.Text (Text) @@ -29,96 +27,11 @@ import qualified Database.SQLite3 as SQLite3 import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.SQLite.Common -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies import Simplex.Messaging.Agent.Store.Shared import Simplex.Messaging.Encoding.String import Simplex.Messaging.Transport.Client (TransportHost) -schemaMigrations :: [(String, Query, Maybe Query)] -schemaMigrations = - [ ("20220101_initial", m20220101_initial, Nothing), - ("20220301_snd_queue_keys", m20220301_snd_queue_keys, Nothing), - ("20220322_notifications", m20220322_notifications, Nothing), - ("20220607_v2", m20220608_v2, Nothing), - ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode, Nothing), - ("m20220811_onion_hosts", m20220811_onion_hosts, Nothing), - ("m20220817_connection_ntfs", m20220817_connection_ntfs, Nothing), - ("m20220905_commands", m20220905_commands, Nothing), - ("m20220915_connection_queues", m20220915_connection_queues, Nothing), - ("m20230110_users", m20230110_users, Nothing), - ("m20230117_fkey_indexes", m20230117_fkey_indexes, Nothing), - ("m20230120_delete_errors", m20230120_delete_errors, Nothing), - ("m20230217_server_key_hash", m20230217_server_key_hash, Nothing), - ("m20230223_files", m20230223_files, Just down_m20230223_files), - ("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state), - ("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files), - ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes), - ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes), - ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status), - ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync), - ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts), - ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages), - ("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes), - ("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes), - ("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files), - ("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at), - ("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items), - ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes), - ("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect), - ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery), - ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem), - ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays), - ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure), - ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats), - ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete), - ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts), - ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params), - ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) - ] - --- | The list of migrations in ascending order by date -appMigrations :: [Migration] -appMigrations = sortOn name $ map migration schemaMigrations - where - migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} - getCurrentMigrations :: DB.Connection -> IO [Migration] getCurrentMigrations DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT name, down FROM migrations ORDER BY name ASC;" where diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs new file mode 100644 index 000000000..8c885a9e5 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.App (appMigrations) where + +import Data.List (sortOn) +import Database.SQLite.Simple (Query (..)) +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220625_v2_ntf_mode +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220811_onion_hosts +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220817_connection_ntfs +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220905_commands +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220915_connection_queues +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230320_retry_state +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230510_files_pending_replicas_indexes +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230516_encrypted_rcv_message_hashes +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230531_switch_status +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230615_ratchet_sync +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receipts +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231222_command_created_at +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_items +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies +import Simplex.Messaging.Agent.Store.Shared (Migration (..)) + +schemaMigrations :: [(String, Query, Maybe Query)] +schemaMigrations = + [ ("20220101_initial", m20220101_initial, Nothing), + ("20220301_snd_queue_keys", m20220301_snd_queue_keys, Nothing), + ("20220322_notifications", m20220322_notifications, Nothing), + ("20220607_v2", m20220608_v2, Nothing), + ("m20220625_v2_ntf_mode", m20220625_v2_ntf_mode, Nothing), + ("m20220811_onion_hosts", m20220811_onion_hosts, Nothing), + ("m20220817_connection_ntfs", m20220817_connection_ntfs, Nothing), + ("m20220905_commands", m20220905_commands, Nothing), + ("m20220915_connection_queues", m20220915_connection_queues, Nothing), + ("m20230110_users", m20230110_users, Nothing), + ("m20230117_fkey_indexes", m20230117_fkey_indexes, Nothing), + ("m20230120_delete_errors", m20230120_delete_errors, Nothing), + ("m20230217_server_key_hash", m20230217_server_key_hash, Nothing), + ("m20230223_files", m20230223_files, Just down_m20230223_files), + ("m20230320_retry_state", m20230320_retry_state, Just down_m20230320_retry_state), + ("m20230401_snd_files", m20230401_snd_files, Just down_m20230401_snd_files), + ("m20230510_files_pending_replicas_indexes", m20230510_files_pending_replicas_indexes, Just down_m20230510_files_pending_replicas_indexes), + ("m20230516_encrypted_rcv_message_hashes", m20230516_encrypted_rcv_message_hashes, Just down_m20230516_encrypted_rcv_message_hashes), + ("m20230531_switch_status", m20230531_switch_status, Just down_m20230531_switch_status), + ("m20230615_ratchet_sync", m20230615_ratchet_sync, Just down_m20230615_ratchet_sync), + ("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts), + ("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages), + ("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes), + ("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes), + ("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files), + ("m20231222_command_created_at", m20231222_command_created_at, Just down_m20231222_command_created_at), + ("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items), + ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes), + ("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect), + ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery), + ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem), + ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays), + ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure), + ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats), + ("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete), + ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts), + ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params), + ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies) + ] + +-- | The list of migrations in ascending order by date +appMigrations :: [Migration] +appMigrations = sortOn name $ map migration schemaMigrations + where + migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 04c530d97..5ead81613 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -42,6 +42,7 @@ import Simplex.Messaging.Agent.Client () import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.AgentStore +import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations) import Simplex.Messaging.Agent.Store.SQLite import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction') import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index ed8668de2..0b6f4ebc1 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -10,6 +10,7 @@ import Data.List (dropWhileEnd) import Data.Maybe (fromJust, isJust) import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL +import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations) import Simplex.Messaging.Agent.Store.SQLite import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') import Simplex.Messaging.Agent.Store.SQLite.DB (TrackQueries (..)) From dad7e1b60c2297a3aecca797e07eafbb28050407 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Thu, 20 Feb 2025 09:26:03 +0000 Subject: [PATCH 41/51] simplex-servers-update: download scripts from tag (#1457) * simplex-servers-update: download scripts from tag * set remote version when re-executing the update script * safeguard variables * additional checks --- scripts/main/simplex-servers-update | 36 +++++++++++++++-------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/scripts/main/simplex-servers-update b/scripts/main/simplex-servers-update index a3c6cc2bf..377223608 100755 --- a/scripts/main/simplex-servers-update +++ b/scripts/main/simplex-servers-update @@ -4,14 +4,6 @@ set -eu # Make sure that PATH variable contains /usr/local/bin PATH="/usr/local/bin:$PATH" -# Links to scripts/configs -scripts_url="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main" -scripts_url_systemd_smp="$scripts_url/smp-server.service" -scripts_url_systemd_xftp="$scripts_url/xftp-server.service" -scripts_url_update="$scripts_url/simplex-servers-update" -scripts_url_uninstall="$scripts_url/simplex-servers-uninstall" -scripts_url_stopscript="$scripts_url/simplex-servers-stopscript" - # Default installation paths path_bin="/usr/local/bin" path_bin_smp="$path_bin/smp-server" @@ -139,7 +131,6 @@ check_versions() { case "$VER" in latest) - bin_url="https://github.com/simplex-chat/simplexmq/releases/latest/download" remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest 2>/dev/null | grep -i "tag_name" | awk -F \" '{print $4}')" if [ -z "$remote_version" ]; then @@ -152,7 +143,6 @@ check_versions() { ver_check="https://github.com/simplex-chat/simplexmq/releases/tag/${VER}" if curl -o /dev/null --proto '=https' --tlsv1.2 -sf -L "${ver_check}"; then - bin_url="https://github.com/simplex-chat/simplexmq/releases/download/${VER}" remote_version="${VER}" else printf "Provided version ${BLU}%s${NC} ${RED}doesn't exist${NC}! Switching to ${BLU}latest${NC}.\n" "${VER}" @@ -167,6 +157,15 @@ check_versions() { ;; esac + # Links to scripts/configs + bin_url="https://github.com/simplex-chat/simplexmq/releases/download/${remote_version}" + scripts_url="https://raw.githubusercontent.com/simplex-chat/simplexmq/refs/tags/${remote_version}/scripts/main" + scripts_url_systemd_smp="$scripts_url/smp-server.service" + scripts_url_systemd_xftp="$scripts_url/xftp-server.service" + scripts_url_update="$scripts_url/simplex-servers-update" + scripts_url_uninstall="$scripts_url/simplex-servers-uninstall" + scripts_url_stopscript="$scripts_url/simplex-servers-stopscript" + set +u for i in smp xftp; do # Only check local directory where binaries are installed by the script @@ -261,7 +260,10 @@ download_thing() { check_pattern="$3" err_msg="$4" - curl --proto '=https' --tlsv1.2 -sSf -L "$thing" -o "$path" + if ! curl --proto '=https' --tlsv1.2 -sSf -L "$thing" -o "$path"; then + printf "${RED}Something went wrong when downloading ${YLW}%s${NC}: either you don't have connection to Github or you're rate-limited.\n" "$err_msg" + exit 1 + fi type="$(file "$path")" @@ -270,7 +272,7 @@ download_thing() { esac if ! check_sanity "$path" "$check_pattern"; then - printf "${RED}Something went wrong when downloading ${YLW}%s${NC}: either you don't have connection to Github or you're rate-limited.\n" "$err_msg" + printf "${RED}Something went wrong with downloaded ${YLW}%s${NC}: file is corrupted.\n" "$err_msg" exit 1 fi @@ -329,14 +331,14 @@ update_misc() { OLD_IFS="$IFS" IFS='/' - for script in $msg_scripts_raw; do + for script in ${msg_scripts_raw:-}; do case "$script" in update) printf -- "- Updating update script..." mv "$path_tmp_bin_update" "$path_bin_update" printf "${GRN}Done!${NC}\n" printf -- "- Re-executing Update script..." - exec env UPDATE_SCRIPT_DONE=1 "$path_bin_update" "${selection}" + exec env UPDATE_SCRIPT_DONE=1 VER="$remote_version" "$path_bin_update" "${selection}" ;; stop) printf -- "- Updating stopscript script..." @@ -351,7 +353,7 @@ update_misc() { esac done - for service in $msg_services_raw; do + for service in ${msg_services_raw:-}; do app="${service%%-*}" eval "path_systemd=\$path_systemd_${app}" eval "path_tmp_systemd=\$path_tmp_systemd_${app}" @@ -371,7 +373,7 @@ update_bins() { OLD_IFS="$IFS" IFS='/' - for service in $msg_bins_raw; do + for service in ${msg_bins_raw:-}; do app="${service%%-*}" eval "local_version=\$local_version_${app}" eval "bin_url_final=\$bin_url_${app}" @@ -413,7 +415,7 @@ download_bins() { OLD_IFS="$IFS" IFS='/' - for service in $msg_bins_raw; do + for service in ${msg_bins_raw:-}; do app="${service%%-*}" eval "local_version=\$local_version_${app}" eval "bin_url_final=\$bin_url_${app}" From 1b8110a3324f0c4bef41c91ac76399c052d3b1be Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Sat, 22 Feb 2025 02:43:56 +0400 Subject: [PATCH 42/51] xftp server: restore file status from log (#1461) * xftp server: restore file blocking info from log * fix parse * rework * update * rename --- src/Simplex/FileTransfer/Server.hs | 4 ++-- src/Simplex/FileTransfer/Server/Store.hs | 12 +++++------ src/Simplex/FileTransfer/Server/StoreLog.hs | 22 +++++++++++---------- 3 files changed, 20 insertions(+), 18 deletions(-) diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 407b65a70..9bdb9b28e 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -415,7 +415,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case sId <- ExceptT $ addFileRetry st file 3 ts rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks lift $ withFileLog $ \sl -> do - logAddFile sl sId file ts + logAddFile sl sId file ts EntityActive logAddRecipients sl sId rcps stats <- asks serverStats lift $ incFileStat filesCreated @@ -426,7 +426,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId) addFileRetry st file n ts = retryAdd n $ \sId -> runExceptT $ do - ExceptT $ addFile st sId file ts + ExceptT $ addFile st sId file ts EntityActive pure sId addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicAuthKey -> M (Either XFTPErrorType FileRecipient) addRecipientRetry st n sId rpk = diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index c4536a2b5..f59712fc0 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -70,18 +70,18 @@ newFileStore = do usedStorage <- newTVarIO 0 pure FileStore {files, recipients, usedStorage} -addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ()) -addFile FileStore {files} sId fileInfo createdAt = +addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM (Either XFTPErrorType ()) +addFile FileStore {files} sId fileInfo createdAt status = ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do - f <- newFileRec sId fileInfo createdAt + f <- newFileRec sId fileInfo createdAt status TM.insert sId f files pure $ Right () -newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec -newFileRec senderId fileInfo createdAt = do +newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> STM FileRec +newFileRec senderId fileInfo createdAt status = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing - fileStatus <- newTVar EntityActive + fileStatus <- newTVar status pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ()) diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index a229f62e7..c972da281 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -19,12 +19,13 @@ module Simplex.FileTransfer.Server.StoreLog ) where +import Control.Applicative ((<|>)) import Control.Concurrent.STM import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Composition ((.:), (.:.)) +import Data.Composition ((.:), (.::)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -33,13 +34,13 @@ import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.FileTransfer.Server.Store import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId) -import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, ServerEntityStatus (..)) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (bshow) import System.IO data FileStoreLogRecord - = AddFile SenderId FileInfo RoundedSystemTime + = AddFile SenderId FileInfo RoundedSystemTime ServerEntityStatus | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty FileRecipient) | DeleteFile SenderId @@ -49,7 +50,7 @@ data FileStoreLogRecord instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file createdAt -> strEncode (Str "FNEW", sId, file, createdAt) + AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) PutFile sId path -> strEncode (Str "FPUT", sId, path) AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps) DeleteFile sId -> strEncode (Str "FDEL", sId) @@ -57,7 +58,7 @@ instance StrEncoding FileStoreLogRecord where AckFile rId -> strEncode (Str "FACK", rId) strP = A.choice - [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP), + [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)), "FPUT " *> (PutFile <$> strP_ <*> strP), "FADD " *> (AddRecipients <$> strP_ <*> strP), "FDEL " *> (DeleteFile <$> strP), @@ -68,8 +69,8 @@ instance StrEncoding FileStoreLogRecord where logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () logFileStoreRecord = writeStoreLogRecord -logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO () -logAddFile s = logFileStoreRecord s .:. AddFile +logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> ServerEntityStatus -> IO () +logAddFile s = logFileStoreRecord s .:: AddFile logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () logPutFile s = logFileStoreRecord s .: PutFile @@ -99,7 +100,7 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s _ -> pure () addToStore = \case - AddFile sId file createdAt -> addFile st sId file createdAt + AddFile sId file createdAt status -> addFile st sId file createdAt status PutFile qId path -> setFilePath st qId path AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps DeleteFile sId -> deleteFile st sId @@ -113,8 +114,9 @@ writeFileStore s FileStore {files, recipients} = do readTVarIO files >>= mapM_ (logFile allRcps) where logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () - logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do - logAddFile s senderId fileInfo createdAt + logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do + status <- readTVarIO fileStatus + logAddFile s senderId fileInfo createdAt status (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs From 2286726d727f0056920e7baf045472d1097c0214 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 22 Feb 2025 19:26:03 +0000 Subject: [PATCH 43/51] smp server: start options `maintenance` and `skip-warnings` (#1465) * smp server: start options `maintenance` and `skip-warnings` * ignore invalid parsing of the last lines * parsingErr * fix --- src/Simplex/Messaging/Server.hs | 91 ++++++++++++------- src/Simplex/Messaging/Server/Env/STM.hs | 8 +- src/Simplex/Messaging/Server/Main.hs | 25 +++-- .../Messaging/Server/QueueStore/STM.hs | 17 ++-- src/Simplex/Messaging/Server/StoreLog.hs | 21 +++++ tests/CoreTests/MsgStoreTests.hs | 4 +- tests/SMPClient.hs | 3 +- 7 files changed, 118 insertions(+), 51 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 4fecc4bef..429903b70 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -69,6 +69,7 @@ import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) import Data.Semigroup (Sum (..)) +import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import qualified Data.Text.IO as T @@ -104,6 +105,7 @@ import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.QueueStore.STM import Simplex.Messaging.Server.Stats +import Simplex.Messaging.Server.StoreLog (foldLogLines) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport @@ -111,7 +113,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server import Simplex.Messaging.Util import Simplex.Messaging.Version -import System.Exit (exitFailure) +import System.Exit (exitFailure, exitSuccess) import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode) import System.Mem.Weak (deRefWeak) import UnliftIO (timeout) @@ -162,14 +164,18 @@ newMessageStats :: MessageStats newMessageStats = MessageStats 0 0 0 smpServer :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> M () -smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHTTP_ = do +smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOptions} attachHTTP_ = do s <- asks server pa <- asks proxyAgent - msgStats_ <- processServerMessages + msgStats_ <- processServerMessages startOptions ntfStats <- restoreServerNtfs liftIO $ mapM_ (printMessageStats "messages") msgStats_ liftIO $ printMessageStats "notifications" ntfStats restoreServerStats msgStats_ ntfStats + when (maintenance startOptions) $ do + liftIO $ putStrLn "Server started in 'maintenance' mode, exiting" + stopServer s + liftIO $ exitSuccess raceAny_ ( serverThread s "server subscribedQ" subscribedQ subscribers subClients pendingSubEvents subscriptions cancelSub : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubClients pendingNtfSubEvents ntfSubscriptions (\_ -> pure ()) @@ -1816,8 +1822,8 @@ exportMessages tty ms f drainMsgs = do exitFailure encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n') -processServerMessages :: M (Maybe MessageStats) -processServerMessages = do +processServerMessages :: StartOptions -> M (Maybe MessageStats) +processServerMessages StartOptions {skipWarnings} = do old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch) expire <- asks $ expireMessagesOnStart . config asks msgStore >>= liftIO . processMessages old_ expire @@ -1825,7 +1831,7 @@ processServerMessages = do processMessages :: Maybe Int64 -> Bool -> AMsgStore -> IO (Maybe MessageStats) processMessages old_ expire = \case AMS SMSMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of - Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_) (pure Nothing) + Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing) Nothing -> pure Nothing AMS SMSJournal ms | expire -> Just <$> case old_ of @@ -1858,44 +1864,56 @@ processServerMessages = do logError $ "STORE: processValidateQueue, failed opening message queue, " <> tshow e exitFailure --- TODO this function should be called after importing queues from store log -importMessages :: forall s. STMStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> IO MessageStats -importMessages tty ms f old_ = do +importMessages :: forall s. STMStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats +importMessages tty ms f old_ skipWarnings = do logInfo $ "restoring messages from file " <> T.pack f - LB.readFile f >>= runExceptT . foldM restoreMsg (0, Nothing, (0, 0, M.empty)) . LB.lines >>= \case - Left e -> do - when tty $ putStrLn "" - logError . T.pack $ "error restoring messages: " <> e - liftIO exitFailure - Right (lineCount, _, (storedMsgsCount, expiredMsgsCount, overQuota)) -> do - putStrLn $ progress lineCount - renameFile f $ f <> ".bak" - mapM_ setOverQuota_ overQuota - logQueueStates ms - storedQueues <- M.size <$> readTVarIO (queues $ stmQueueStore ms) - pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} + (lineCount, _, (storedMsgsCount, expiredMsgsCount, overQuota)) <- + foldLogLines tty f restoreMsg (0, Nothing, (0, 0, M.empty)) + putStrLn $ progress lineCount + renameFile f $ f <> ".bak" + mapM_ setOverQuota_ overQuota + logQueueStates ms + storedQueues <- M.size <$> readTVarIO (queues $ stmQueueStore ms) + pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where progress i = "Processed " <> show i <> " lines" - restoreMsg :: (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) -> LB.ByteString -> ExceptT String IO (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) - restoreMsg (!i, q_, (!stored, !expired, !overQuota)) s' = do - when (tty && i `mod` 1000 == 0) $ liftIO $ putStr (progress i <> "\r") >> hFlush stdout - MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s - liftError show $ addToMsgQueue rId msg + restoreMsg :: (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) + restoreMsg (!i, q_, counts@(!stored, !expired, !overQuota)) eof s = do + when (tty && i `mod` 1000 == 0) $ putStr (progress i <> "\r") >> hFlush stdout + case strDecode s of + Right (MLRv3 rId msg) -> runExceptT (addToMsgQueue rId msg) >>= either (exitErr . tshow) pure + Left e + | eof -> warnOrExit (parsingErr e) $> (i + 1, q_, counts) + | otherwise -> exitErr $ parsingErr e where - s = LB.toStrict s' + exitErr e = do + when tty $ putStrLn "" + logError $ "error restoring messages: " <> e + liftIO exitFailure + parsingErr :: String -> Text + parsingErr e = "parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s) addToMsgQueue rId msg = do - q <- case q_ of + qOrErr <- case q_ of -- to avoid lookup when restoring the next message to the same queue - Just (rId', q') | rId' == rId -> pure q' - _ -> ExceptT $ getQueue ms SRecipient rId + Just (rId', q') | rId' == rId -> pure $ Right q' + _ -> liftIO $ getQueue ms SRecipient rId + case qOrErr of + Right q -> addToQueue_ q rId msg + Left AUTH -> liftIO $ do + when tty $ putStrLn "" + warnOrExit $ "queue " <> safeDecodeUtf8 (encode $ unEntityId rId) <> " does not exist" + pure (i + 1, Nothing, counts) + Left e -> throwE e + addToQueue_ q rId msg = (i + 1,Just (rId, q),) <$> case msg of Message {msgTs} | maybe True (systemSeconds msgTs >=) old_ -> do writeMsg ms q False msg >>= \case Just _ -> pure (stored + 1, expired, overQuota) - Nothing -> do + Nothing -> liftIO $ do + when tty $ putStrLn "" logError $ decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) - pure (stored, expired, overQuota) + pure counts | otherwise -> pure (stored, expired + 1, overQuota) MessageQuota {} -> -- queue was over quota at some point, @@ -1907,8 +1925,13 @@ importMessages tty ms f old_ = do withPeekMsgQueue ms q "mergeQuotaMsgs" $ maybe (pure ()) $ \case (mq, MessageQuota {}) -> tryDeleteMsg_ q mq False _ -> pure () - msgErr :: Show e => String -> e -> String - msgErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s) + warnOrExit e + | skipWarnings = logWarn e' + | otherwise = do + logWarn $ e' <> ", start with --skip-warnings option to ignore this error" + exitFailure + where + e' = "warning restoring messages: " <> e printMessageStats :: T.Text -> MessageStats -> IO () printMessageStats name MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} = diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 58d57a4c5..005ce6d9b 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -116,7 +116,13 @@ data ServerConfig = ServerConfig allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth` serverClientConcurrency :: Int, -- | server public information - information :: Maybe ServerPublicInfo + information :: Maybe ServerPublicInfo, + startOptions :: StartOptions + } + +data StartOptions = StartOptions + { maintenance :: Bool, + skipWarnings :: Bool } defMsgExpirationDays :: Int64 diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index a03aaa68d..e35803171 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -73,7 +73,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`." _ -> initializeServer opts OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts - Start -> withIniFile runServer + Start opts -> withIniFile $ runServer opts Delete -> do confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" @@ -107,7 +107,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = "Messages not imported" ms <- newJournalMsgStore readQueueStore storeLogFile ms - msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration + msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration putStrLn "Import completed" printMessageStats "Messages" msgStats putStrLn $ case readMsgStoreType ini of @@ -322,7 +322,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = <> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n") where webDisabled = if disableWeb then "# " else "" - runServer ini = do + runServer startOptions ini = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering fp <- checkSavedFingerprint cfgPath defaultX509Config @@ -463,7 +463,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = }, allowSMPProxy = True, serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini, - information = serverPublicInfo ini + information = serverPublicInfo ini, + startOptions } textToOwnServers :: Text -> [ByteString] textToOwnServers = map encodeUtf8 . T.words @@ -635,7 +636,7 @@ printSourceCode = \case data CliCommand = Init InitOptions | OnlineCert CertOptions - | Start + | Start StartOptions | Delete | Journal JournalCmd @@ -669,7 +670,7 @@ cliCommandP cfgPath logPath iniFile = hsubparser ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files")) <> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")")) - <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) + <> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) <> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage")) ) @@ -811,6 +812,18 @@ cliCommandP cfgPath logPath iniFile = disableWeb, scripted } + startOptionsP = do + maintenance <- + switch + ( long "maintenance" + <> help "Do not start the server, only perform start and stop tasks" + ) + skipWarnings <- + switch + ( long "skip-warnings" + <> help "Start the server with non-critical start warnings" + ) + pure StartOptions {maintenance, skipWarnings} journalCmdP = hsubparser ( command "import" (info (pure JCImport) (progDesc "Import message log file into a new journal storage")) diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index f1347533a..2fd3e9912 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -38,7 +38,6 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Bitraversable (bimapM) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) @@ -48,7 +47,8 @@ import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.StoreLog import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$)) +import Simplex.Messaging.Util (ifM, safeDecodeUtf8, tshow, ($>>=), (<$$)) +import System.Exit (exitFailure) import System.IO import UnliftIO.STM @@ -196,12 +196,11 @@ withLog :: STMStoreClass s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> I withLog name = withLog' name . storeLog . stmQueueStore readQueueStore :: forall s. STMStoreClass s => FilePath -> s -> IO () -readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines +readQueueStore f st = readLogLines False f processLine where - processLine :: LB.ByteString -> IO () - processLine s' = either printError procLogRecord (strDecode s) + processLine :: Bool -> B.ByteString -> IO () + processLine eof s = either printError procLogRecord (strDecode s) where - s = LB.toStrict s' procLogRecord :: StoreLogRecord -> IO () procLogRecord = \case CreateQueue rId q -> addQueue st rId q >>= qError rId "CreateQueue" @@ -214,7 +213,11 @@ readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLin DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t printError :: String -> IO () - printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s + printError e + | eof = logWarn err + | otherwise = logError err >> exitFailure + where + err = "Error parsing log: " <> T.pack e <> " - " <> safeDecodeUtf8 s withQueue :: forall a. RecipientId -> T.Text -> (StoreQueue s -> IO (Either ErrorType a)) -> IO () withQueue qId op a = runExceptT go >>= qError qId op where diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index e676770f7..2d82014f7 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -28,6 +28,8 @@ module Simplex.Messaging.Server.StoreLog logUpdateQueueTime, readWriteStoreLog, writeQueueStore, + readLogLines, + foldLogLines, ) where @@ -35,6 +37,7 @@ import Control.Applicative (optional, (<|>)) import Control.Concurrent.STM import qualified Control.Exception as E import Control.Logger.Simple +import Control.Monad (when) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) @@ -254,3 +257,21 @@ writeQueueStore s st = readTVarIO qs >>= mapM_ writeQueue . M.assocs readTVarIO (queueRec' q) >>= \case Just q' -> logCreateQueue s rId q' Nothing -> atomically $ TM.delete rId qs + +readLogLines :: Bool -> FilePath -> (Bool -> B.ByteString -> IO ()) -> IO () +readLogLines tty f action = foldLogLines tty f (const action) () + +foldLogLines :: Bool -> FilePath -> (a -> Bool -> B.ByteString -> IO a) -> a -> IO a +foldLogLines tty f action initValue = do + (count :: Int, acc) <- withFile f ReadMode $ \h -> ifM (hIsEOF h) (pure (0, initValue)) (loop h 0 initValue) + putStrLn $ progress count + pure acc + where + loop h i acc = do + s <- B.hGetLine h + eof <- hIsEOF h + acc' <- action acc eof s + let i' = i + 1 + when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout + if eof then pure (i', acc') else loop h i' acc' + progress i = "Processed: " <> show i <> " lines" diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 72599f193..3484fceb4 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -222,7 +222,7 @@ testExportImportStore ms = do ms' <- newMsgStore cfg readWriteQueueStore testStoreLogFile ms' >>= closeStoreLog stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- - importMessages False ms' testStoreMsgsFile Nothing + importMessages False ms' testStoreMsgsFile Nothing False printMessageStats "Messages" stats length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2 length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 4 -- state file is backed up, 2 message files @@ -231,7 +231,7 @@ testExportImportStore ms = do stmStore <- newMsgStore testSMTStoreConfig readWriteQueueStore testStoreLogFile stmStore >>= closeStoreLog MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <- - importMessages False stmStore testStoreMsgsFile2 Nothing + importMessages False stmStore testStoreMsgsFile2 Nothing False exportMessages False stmStore testStoreMsgsFile False (B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak")) diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 5ce0eb7f6..3c732b7a5 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -163,7 +163,8 @@ cfgMS msType = smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds allowSMPProxy = False, serverClientConcurrency = 2, - information = Nothing + information = Nothing, + startOptions = StartOptions {maintenance = False, skipWarnings = False} } cfgV7 :: ServerConfig From ffbc733d588bc360aa7b4dd7b6414a56776b4408 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 23 Feb 2025 19:40:49 +0000 Subject: [PATCH 44/51] smp server: remove duplicate progress log (#1466) --- src/Simplex/Messaging/Server.hs | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 429903b70..8452a2eb6 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1867,24 +1867,20 @@ processServerMessages StartOptions {skipWarnings} = do importMessages :: forall s. STMStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats importMessages tty ms f old_ skipWarnings = do logInfo $ "restoring messages from file " <> T.pack f - (lineCount, _, (storedMsgsCount, expiredMsgsCount, overQuota)) <- - foldLogLines tty f restoreMsg (0, Nothing, (0, 0, M.empty)) - putStrLn $ progress lineCount + (_, (storedMsgsCount, expiredMsgsCount, overQuota)) <- + foldLogLines tty f restoreMsg (Nothing, (0, 0, M.empty)) renameFile f $ f <> ".bak" mapM_ setOverQuota_ overQuota logQueueStates ms storedQueues <- M.size <$> readTVarIO (queues $ stmQueueStore ms) pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues} where - progress i = "Processed " <> show i <> " lines" - restoreMsg :: (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Int, Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) - restoreMsg (!i, q_, counts@(!stored, !expired, !overQuota)) eof s = do - when (tty && i `mod` 1000 == 0) $ putStr (progress i <> "\r") >> hFlush stdout - case strDecode s of - Right (MLRv3 rId msg) -> runExceptT (addToMsgQueue rId msg) >>= either (exitErr . tshow) pure - Left e - | eof -> warnOrExit (parsingErr e) $> (i + 1, q_, counts) - | otherwise -> exitErr $ parsingErr e + restoreMsg :: (Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Maybe (RecipientId, StoreQueue s), (Int, Int, M.Map RecipientId (StoreQueue s))) + restoreMsg (q_, counts@(!stored, !expired, !overQuota)) eof s = case strDecode s of + Right (MLRv3 rId msg) -> runExceptT (addToMsgQueue rId msg) >>= either (exitErr . tshow) pure + Left e + | eof -> warnOrExit (parsingErr e) $> (q_, counts) + | otherwise -> exitErr $ parsingErr e where exitErr e = do when tty $ putStrLn "" @@ -1902,10 +1898,10 @@ importMessages tty ms f old_ skipWarnings = do Left AUTH -> liftIO $ do when tty $ putStrLn "" warnOrExit $ "queue " <> safeDecodeUtf8 (encode $ unEntityId rId) <> " does not exist" - pure (i + 1, Nothing, counts) + pure (Nothing, counts) Left e -> throwE e addToQueue_ q rId msg = - (i + 1,Just (rId, q),) <$> case msg of + (Just (rId, q),) <$> case msg of Message {msgTs} | maybe True (systemSeconds msgTs >=) old_ -> do writeMsg ms q False msg >>= \case From f9d7b1eebc7e825423ee0d3b995a69c4006ac99c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 23 Feb 2025 19:42:16 +0000 Subject: [PATCH 45/51] 6.3.0.6 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 189c6d831..400f2d29a 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.5 +version: 6.3.0.6 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 205d4ead1c63da8519347bce6fb53e1a42e3e79c Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 27 Feb 2025 07:39:05 +0000 Subject: [PATCH 46/51] smp server: remove store log backups when server starts (#1472) --- src/Simplex/Messaging/Server/StoreLog.hs | 33 +++++++++++++++++++++--- 1 file changed, 29 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 2d82014f7..5f38d6b3f 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -37,14 +37,16 @@ import Control.Applicative (optional, (<|>)) import Control.Concurrent.STM import qualified Control.Exception as E import Control.Logger.Simple -import Control.Monad (when) +import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) +import Data.List (sort, stripPrefix) import qualified Data.Map.Strict as M +import Data.Maybe (mapMaybe) import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Data.Time.Format.ISO8601 (iso8601Show) +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) +import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM) import GHC.IO (catchAny) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol @@ -53,8 +55,9 @@ import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.StoreLog.Types import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, tshow, unlessM, whenM) -import System.Directory (doesFileExist, renameFile) +import System.Directory (doesFileExist, listDirectory, removeFile, renameFile) import System.IO +import System.FilePath (takeDirectory, takeFileName) data StoreLogRecord = CreateQueue RecipientId QueueRec @@ -237,6 +240,7 @@ readWriteStoreLog readStore writeStore f st = renameFile f tempBackup -- 1) make temp backup s <- writeLog "compacting store log (do not terminate)..." -- 2) save state renameBackup -- 3) timed backup + removeStoreLogBackups f pure s writeLog msg = do s <- openWriteStoreLog f @@ -258,6 +262,27 @@ writeQueueStore s st = readTVarIO qs >>= mapM_ writeQueue . M.assocs Just q' -> logCreateQueue s rId q' Nothing -> atomically $ TM.delete rId qs +removeStoreLogBackups :: FilePath -> IO () +removeStoreLogBackups f = do + ts <- getCurrentTime + times <- sort . mapMaybe backupPathTime <$> listDirectory (takeDirectory f) + let new = addUTCTime (- nominalDay) ts + old = addUTCTime (- oldBackupTTL) ts + times1 = filter (< new) times -- exclude backups newer than 24 hours + times2 = take (length times1 - minOldBackups) times1 -- keep 3 backups older than 24 hours + toDelete = filter (< old) times2 -- remove all backups older than 21 day + mapM_ (removeFile . backupPath) toDelete + putStrLn $ "Removed " <> show (length toDelete) <> " backups:" + mapM_ (putStrLn . backupPath) toDelete + where + backupPathTime :: FilePath -> Maybe UTCTime + backupPathTime = iso8601ParseM <=< stripPrefix backupPathPfx + backupPath :: UTCTime -> FilePath + backupPath ts = f <> "." <> iso8601Show ts + backupPathPfx = takeFileName f <> "." + minOldBackups = 3 + oldBackupTTL = 21 * nominalDay + readLogLines :: Bool -> FilePath -> (Bool -> B.ByteString -> IO ()) -> IO () readLogLines tty f action = foldLogLines tty f (const action) () From 9fece9ce3df24d1b006d98e44a6b4e654861428b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 2 Mar 2025 22:45:07 +0000 Subject: [PATCH 47/51] 6.3.0.7 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 400f2d29a..79030d1d5 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.6 +version: 6.3.0.7 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 1a2afe8bfdfeb0709547dd277ede8a00962254dd Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 6 Mar 2025 08:02:27 +0000 Subject: [PATCH 48/51] agent: fix JSON encoding for protocol errors to be compatible with iOS (#1475) --- src/Simplex/Messaging/Protocol.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 679f077b7..122246868 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -1818,9 +1818,9 @@ tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \ca $(J.deriveJSON defaultJSON ''MsgFlags) -$(J.deriveJSON (taggedObjectJSON id) ''CommandError) +$(J.deriveJSON (sumTypeJSON id) ''CommandError) -$(J.deriveJSON (taggedObjectJSON id) ''BrokerErrorType) +$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType) $(J.deriveJSON defaultJSON ''BlockingInfo) From 36f5539b9a515c002936ab7b08dfb1ad1c7a1eb8 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Fri, 7 Mar 2025 14:15:18 +0000 Subject: [PATCH 49/51] ci: introduce reproducible builds (#1476) * ci: introduce reproducible builds * ci: return 20.04 * smp server: increase timing test threshold * ci: test outside docker * ci: fix test step --------- Co-authored-by: Evgeny Poberezkin --- .github/workflows/build.yml | 71 ++++++++++++++++++------------------- Dockerfile.build | 42 ++++++++++++++++++++++ tests/ServerTests.hs | 2 +- 3 files changed, 78 insertions(+), 37 deletions(-) create mode 100644 Dockerfile.build diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index be58c10b4..4da30d59b 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -11,61 +11,53 @@ on: jobs: build: - name: build-${{ matrix.os }}-${{ matrix.ghc }} - runs-on: ${{ matrix.os }} + name: "Ubuntu: ${{ matrix.os }}, GHC: ${{ matrix.ghc }}" + env: + apps: "smp-server xftp-server ntf-server xftp" + runs-on: ubuntu-${{ matrix.os }} strategy: fail-fast: false matrix: include: - - os: ubuntu-20.04 - platform_name: 20_04-x86-64 + - os: 22.04 ghc: "8.10.7" - - os: ubuntu-20.04 platform_name: 20_04-x86-64 + - os: 20.04 + ghc: "9.6.3" + platform_name: 20_04-x86-64 + - os: 22.04 ghc: "9.6.3" - - os: ubuntu-22.04 platform_name: 22_04-x86-64 + - os: 24.04 ghc: "9.6.3" + platform_name: 24_04-x86-64 steps: - name: Clone project uses: actions/checkout@v3 - - name: Setup Haskell - uses: haskell-actions/setup@v2 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: "3.10.1.0" - - - name: Cache dependencies - uses: actions/cache@v3 - with: - path: | - ~/.cabal/store - dist-newstyle - key: ${{ matrix.os }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }} - - - name: Build + - name: Prepare image shell: bash - run: cabal build --enable-tests + run: docker build -f Dockerfile.build --build-arg TAG=${{ matrix.os }} --build-arg GHC=${{ matrix.ghc }} -t local . - - name: Test - timeout-minutes: 40 + - name: Start container shell: bash - run: cabal test --test-show-details=direct + run: docker run -t -d --name builder local - - name: Prepare binaries + - name: Build binaries + shell: bash + run: docker exec -t -e apps="$apps" builder sh -c 'cabal build --enable-tests && mkdir /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/; done' + + - name: Copy binaries from container and prepare them if: startsWith(github.ref, 'refs/tags/v') shell: bash run: | - mv $(cabal list-bin smp-server) smp-server-ubuntu-${{ matrix.platform_name}} - mv $(cabal list-bin ntf-server) ntf-server-ubuntu-${{ matrix.platform_name}} - mv $(cabal list-bin xftp-server) xftp-server-ubuntu-${{ matrix.platform_name}} - mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}} + docker cp builder:/out . + for i in $apps; do mv ./out/$i ./$i-ubuntu-${{ matrix.platform_name }}; done - name: Build changelog if: startsWith(github.ref, 'refs/tags/v') id: build_changelog - uses: mikepenz/release-changelog-builder-action@v1 + uses: mikepenz/release-changelog-builder-action@v5 with: configuration: .github/changelog_conf.json failOnError: true @@ -76,7 +68,7 @@ jobs: - name: Create release if: startsWith(github.ref, 'refs/tags/v') && matrix.ghc != '8.10.7' - uses: softprops/action-gh-release@v1 + uses: softprops/action-gh-release@v2 with: body: | See full changelog [here](https://github.com/simplex-chat/simplexmq/blob/master/CHANGELOG.md). @@ -86,10 +78,17 @@ jobs: prerelease: true files: | LICENSE - smp-server-ubuntu-${{ matrix.platform_name}} - ntf-server-ubuntu-${{ matrix.platform_name}} - xftp-server-ubuntu-${{ matrix.platform_name}} - xftp-ubuntu-${{ matrix.platform_name}} + smp-server-ubuntu-${{ matrix.platform_name }} + ntf-server-ubuntu-${{ matrix.platform_name }} + xftp-server-ubuntu-${{ matrix.platform_name }} + xftp-ubuntu-${{ matrix.platform_name }} fail_on_unmatched_files: true env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + + - name: Test + shell: bash + run: | + docker exec -t builder sh -c 'mv $(find /project/dist-newstyle -name "simplexmq-test" -type f -executable) /out/' + docker cp builder:/out/simplexmq-test . + ./simplexmq-test diff --git a/Dockerfile.build b/Dockerfile.build new file mode 100644 index 000000000..fb7678f44 --- /dev/null +++ b/Dockerfile.build @@ -0,0 +1,42 @@ +# syntax=docker/dockerfile:1.7.0-labs +ARG TAG=24.04 +FROM ubuntu:${TAG} AS build + +### Build stage + +ARG GHC=9.6.3 +ARG CABAL=3.14.1.1 + +# Install curl, git and and simplexmq dependencies +RUN apt-get update && apt-get install -y curl git sqlite3 libsqlite3-dev build-essential libgmp3-dev zlib1g-dev llvm llvm-dev libnuma-dev libssl-dev + +# Specify bootstrap Haskell versions +ENV BOOTSTRAP_HASKELL_GHC_VERSION=${GHC} +ENV BOOTSTRAP_HASKELL_CABAL_VERSION=${CABAL} + +# Do not install Stack +ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK=true +ENV BOOTSTRAP_HASKELL_INSTALL_NO_STACK_HOOK=true + +# Install ghcup +RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 sh + +# Adjust PATH +ENV PATH="/root/.cabal/bin:/root/.ghcup/bin:$PATH" + +# Set both as default +RUN ghcup set ghc "${GHC}" && \ + ghcup set cabal "${CABAL}" + +# Copy only the source code +COPY apps /project/apps/ +COPY cbits /project/cbits/ +COPY src /project/src/ +COPY tests /project/tests/ + +COPY cabal.project Setup.hs simplexmq.cabal LICENSE /project + +WORKDIR /project + +# Compile app +RUN cabal update diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 088a7b977..986a214d7 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -869,7 +869,7 @@ testTiming = (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type ] timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 -- normally the difference between "no queue" and "wrong key" is less than 5% + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.30 -- normally the difference between "no queue" and "wrong key" is less than 5% testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do g <- C.newRandom From a491a1d8780054432542611f540317a6090b9360 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 7 Mar 2025 14:30:00 +0000 Subject: [PATCH 50/51] 6.3.0.8 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 79030d1d5..5dddd71af 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.3.0.7 +version: 6.3.0.8 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 6e505f5c0b8201e6bf97c4b74dd042e8ff2aa9ce Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Sat, 8 Mar 2025 20:51:20 +0000 Subject: [PATCH 51/51] scripts: add script to reproduce binaries locally (#1477) --- scripts/reproduce-builds.sh | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100755 scripts/reproduce-builds.sh diff --git a/scripts/reproduce-builds.sh b/scripts/reproduce-builds.sh new file mode 100755 index 000000000..eb35287ae --- /dev/null +++ b/scripts/reproduce-builds.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env sh +set -eu + +tag="$1" + +git clone https://github.com/simplex-chat/simplexmq && cd simplexmq + +git checkout "$tag" + +for os in 20.04 22.04 24.04; do + mkdir -p out-${os}-github; + + docker build -f Dockerfile.build --build-arg TAG=${os} -t repro-${os} . + docker run -t -d --name builder-${os} repro-${os} + + apps='smp-server xftp-server ntf-server xftp' + os_url="$(printf '%s' "$os" | tr '.' '_')" + + docker exec -t -e apps="$apps" builder-${os} sh -c 'cabal build && mkdir /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable); strip "$bin"; chmod +x "$bin"; mv "$bin" /out/; done' + + docker cp builder-${os}:/out out-${os} + + for app in $apps; do + curl -L "https://github.com/simplex-chat/simplexmq/releases/download/${tag}/${app}-ubuntu-${os_url}-x86-64" -o out-${os}-github/${app} + done + + docker stop builder-${os} + docker rm builder-${os} + docker image rm repro-${os} +done