client service test WIP

Author: epoberezkin

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

@@ -402,29 +402,31 @@ deleteUsersWithoutConns db = do
   pure userIds
 
 createClientService :: DB.Connection -> UserId -> SMPServer -> (C.KeyHash, TLS.Credential) -> IO ()
-createClientService db userId srv (kh, (cert, pk)) =
+createClientService db userId srv (kh, (cert, pk)) = do
+  serverKeyHash_ <- createServer_ db srv
   DB.execute
     db
     [sql|
       INSERT INTO client_services
-        (user_id, host, port, service_cert_hash, service_cert, service_priv_key)
-      VALUES (?,?,?,?,?,?)
-      ON CONFLICT (user_id, host, port)
+        (user_id, host, port, server_key_hash, service_cert_hash, service_cert, service_priv_key)
+      VALUES (?,?,?,?,?,?,?)
+      ON CONFLICT (user_id, host, port, server_key_hash)
       DO UPDATE SET
         service_cert_hash = EXCLUDED.service_cert_hash,
         service_cert = EXCLUDED.service_cert,
         service_priv_key = EXCLUDED.service_priv_key,
-        rcv_service_id = NULL
+        service_id = NULL
     |]
-    (userId, host srv, port srv, kh, cert, pk)
+    (userId, host srv, port srv, serverKeyHash_, kh, cert, pk)
 
+-- TODO [certs rcv] get correct service based on key hash of the server
 getClientService :: DB.Connection -> UserId -> SMPServer -> IO (Maybe ((C.KeyHash, TLS.Credential), Maybe ServiceId))
 getClientService db userId srv =
   maybeFirstRow toService $
     DB.query
       db
       [sql|
-        SELECT service_cert_hash, service_cert, service_priv_key, rcv_service_id
+        SELECT service_cert_hash, service_cert, service_priv_key, service_id
         FROM client_services
         WHERE user_id = ? AND host = ? AND port = ?
       |]
@@ -438,7 +440,7 @@ getClientServiceServers db userId =
     <$> DB.query
       db
       [sql|
-        SELECT c.host, c.port, s.key_hash, c.rcv_service_id, c.rcv_service_queue_count, c.rcv_service_queue_ids_hash
+        SELECT c.host, c.port, s.key_hash, c.service_id, c.rcv_service_queue_count, c.rcv_service_queue_ids_hash
         FROM client_services c
         JOIN servers s ON s.host = c.host AND s.port = c.port
       |]
@@ -453,7 +455,7 @@ setClientServiceId db userId srv serviceId =
     db
     [sql|
       UPDATE client_services
-      SET rcv_service_id = ?
+      SET service_id = ?
       WHERE user_id = ? AND host = ? AND port = ?
     |]
     (serviceId, userId, host srv, port srv)

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20251020_service_certs.hs

@@ -14,6 +14,7 @@ CREATE TABLE client_services(
   user_id BIGINT NOT NULL REFERENCES users ON UPDATE RESTRICT ON DELETE CASCADE,
   host TEXT NOT NULL,
   port TEXT NOT NULL,
+  server_key_hash BYTEA,
   service_cert BYTEA NOT NULL,
   service_cert_hash BYTEA NOT NULL,
   service_priv_key BYTEA NOT NULL,
@@ -23,7 +24,7 @@ CREATE TABLE client_services(
   FOREIGN KEY(host, port) REFERENCES servers ON UPDATE CASCADE ON DELETE RESTRICT
 );
 
-CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON client_services(user_id, host, port);
+CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON client_services(user_id, host, port, server_key_hash);
 CREATE INDEX idx_server_certs_host_port ON client_services(host, port);
 
 ALTER TABLE rcv_queues ADD COLUMN rcv_service_assoc SMALLINT NOT NULL DEFAULT 0;

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Messaging.Agent.Store.SQLite.Common
@@ -53,6 +54,12 @@ withConnectionPriority DBStore {dbSem, dbConnection} priority action
   | priority = E.bracket_ signal release $ withMVar dbConnection action
   | otherwise = lowPriority
   where
+    -- To debug FK errors, set foreign_keys = OFF in Simplex.Messaging.Agent.Store.SQLite and use action' instead of action
+    -- action' conn = do
+    --   r <- action conn
+    --   violations <- DB.query_ conn "PRAGMA foreign_key_check" :: IO [ (String, Int, String, Int)]
+    --   unless (null violations) $ print violations
+    --   pure r
     lowPriority = wait >> withMVar dbConnection (\db -> ifM free (Just <$> action db) (pure Nothing)) >>= maybe lowPriority pure
     signal = atomically $ modifyTVar' dbSem (+ 1)
     release = atomically $ modifyTVar' dbSem $ \sem -> if sem > 0 then sem - 1 else 0

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

@@ -12,6 +12,7 @@ CREATE TABLE client_services(
   user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
   host TEXT NOT NULL,
   port TEXT NOT NULL,
+  server_key_hash BLOB,
   service_cert BLOB NOT NULL,
   service_cert_hash BLOB NOT NULL,
   service_priv_key BLOB NOT NULL,
@@ -21,7 +22,7 @@ CREATE TABLE client_services(
   FOREIGN KEY(host, port) REFERENCES servers ON UPDATE CASCADE ON DELETE RESTRICT
 );
 
-CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON client_services(user_id, host, port);
+CREATE UNIQUE INDEX idx_server_certs_user_id_host_port ON client_services(user_id, host, port, server_key_hash);
 CREATE INDEX idx_server_certs_host_port ON client_services(host, port);
 
 ALTER TABLE rcv_queues ADD COLUMN rcv_service_assoc INTEGER NOT NULL DEFAULT 0;

src/Simplex/Messaging/Server.hs

@@ -1807,7 +1807,7 @@ client
             deliverServiceMessages expectedCnt = do
               (qCnt, _msgCnt, _dupCnt, _errCnt) <- foldRcvServiceMessages ms serviceId deliverQueueMsg (0, 0, 0, 0)
               atomically $ writeTBQueue msgQ [(NoCorrId, NoEntity, SALL)]
-              -- TODO [cert rcv] compare with expected
+              -- TODO [certs rcv] compare with expected
               logNote $ "Service subscriptions for " <> tshow serviceId <> " (" <> tshow qCnt <> " queues)"
             deliverQueueMsg :: (Int, Int, Int, Int) -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO (Int, Int, Int, Int)
             deliverQueueMsg (!qCnt, !msgCnt, !dupCnt, !errCnt) rId = \case

tests/AgentTests/FunctionalAPITests.hs

@@ -476,6 +476,9 @@ functionalAPITests ps = do
       testUsersNoServer ps
     it "should connect two users and switch session mode" $
       withSmpServer ps testTwoUsers
+  describe "Client service certificates" $ do
+    fit "should connect, subscribe and reconnect as a service" $
+      withSmpServer ps testClientServiceConnection
   describe "Connection switch" $ do
     describe "should switch delivery to the new queue" $
       testServerMatrix2 ps testSwitchConnection
@@ -2295,9 +2298,13 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
 
 makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
+  liftIO $ print 1
   (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive aliceUserId True True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
+  liftIO $ print 2
   aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
+  liftIO $ print 3
   sqSecured' <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
+  liftIO $ print 4
   liftIO $ sqSecured' `shouldBe` sqSecured
   ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
   liftIO $ pqSup' `shouldBe` pqSupport
@@ -3664,6 +3671,14 @@ testTwoUsers = withAgentClients2 $ \a b -> do
     hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
     hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
 
+testClientServiceConnection :: HasCallStack => IO ()
+testClientServiceConnection =
+  withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
+    r <- runExceptT $ makeConnection service user
+    print r
+    Right (sId, uId) <- pure r
+    pure ()
+
 getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> String -> IO AgentClient
 getSMPAgentClient' clientId cfg' initServers dbPath = do
   Right st <- liftIO $ createStore dbPath

tests/SMPAgentClient.hs

@@ -83,6 +83,9 @@ initAgentServersProxy_ smpProxyMode smpProxyFallback =
 initAgentServersProxy2 :: InitialAgentServers
 initAgentServersProxy2 = initAgentServersProxy {smp = userServers [testSMPServer2]}
 
+initAgentServersClientService :: InitialAgentServers
+initAgentServersClientService = initAgentServers {useServices = M.fromList [(1, True)]}
+
 agentCfg :: AgentConfig
 agentCfg =
   defaultAgentConfig

tests/Test.hs

@@ -150,7 +150,7 @@ main = do
             before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests
 #endif
         -- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal)
-        describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
+        xdescribe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
         describe "SMP proxy, jornal message store" $
           before (pure $ ASType SQSMemory SMSJournal) smpProxyTests
         describe "XFTP" $ do