diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 341869b85..f41a34291 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -128,9 +128,12 @@ run st = \case where runUp Migration {name, up, down} = withTransaction' st $ \db -> do when (name == "m20220811_onion_hosts") $ updateServers db - insert db >> execSQL db up + insert db >> execSQL db up' where insert db = DB.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) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs index 73758cdeb..49e6589b9 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230110_users.hs @@ -27,3 +27,24 @@ UPDATE connections SET user_id = 1; PRAGMA ignore_check_constraints=OFF; |] + +-- This is executed in the new database +-- It does not create new user record +new_m20230110_users :: Query +new_m20230110_users = + [sql| +PRAGMA ignore_check_constraints=ON; + +CREATE TABLE users ( + user_id INTEGER PRIMARY KEY AUTOINCREMENT +); + +ALTER TABLE connections ADD COLUMN user_id INTEGER CHECK (user_id NOT NULL) +REFERENCES users ON DELETE CASCADE; + +CREATE INDEX idx_connections_user ON connections(user_id); + +CREATE INDEX idx_commands_conn_id ON commands(conn_id); + +PRAGMA ignore_check_constraints=OFF; +|] diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index f332efcb9..8f5c97798 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -36,6 +36,7 @@ import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchet import Control.Concurrent (killThread, threadDelay) import Control.Monad import Control.Monad.Except +import Control.Monad.Reader import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (isRight) @@ -46,13 +47,15 @@ import qualified Data.Set as S import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Type.Equality +import qualified Database.SQLite.Simple as SQL import SMPAgentClient import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) import Simplex.Messaging.Agent.Protocol as Agent -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) +import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -73,7 +76,10 @@ type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e) a ##> t = withTimeout a (`shouldBe` t) (=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (a -> Bool) -> m () -a =##> p = withTimeout a (`shouldSatisfy` p) +a =##> p = + withTimeout a $ \r -> do + unless (p r) $ liftIO $ putStrLn $ "value failed predicate: " <> show r + r `shouldSatisfy` p withTimeout :: MonadUnliftIO m => m a -> (a -> Expectation) -> m () withTimeout a test = @@ -589,7 +595,7 @@ testAllowConnectionClientRestart t = do runRight_ $ do allowConnectionAsync alice "1" bobId confId "alice's connInfo" - ("1", _, OK) <- get alice + get alice =##> \case ("1", _, OK) -> True; _ -> False pure () threadDelay 100000 -- give time to enqueue confirmation (enqueueConfirmation) @@ -1289,7 +1295,7 @@ testAsyncCommands = liftIO $ aliceId' `shouldBe` aliceId ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnectionAsync alice "3" bobId confId "alice's connInfo" - ("3", _, OK) <- get alice + get alice =##> \case ("3", _, OK) -> True; _ -> False get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON) @@ -1300,20 +1306,20 @@ testAsyncCommands = get alice ##> ("", bobId, SENT $ baseId + 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False ackMessageAsync bob "4" aliceId (baseId + 1) Nothing - ("4", _, OK) <- get bob + get bob =##> \case ("4", _, OK) -> True; _ -> False get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False ackMessageAsync bob "5" aliceId (baseId + 2) Nothing - ("5", _, OK) <- get bob + get bob =##> \case ("5", _, OK) -> True; _ -> False 3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" get bob ##> ("", aliceId, SENT $ baseId + 3) 4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1" get bob ##> ("", aliceId, SENT $ baseId + 4) get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False ackMessageAsync alice "6" bobId (baseId + 3) Nothing - ("6", _, OK) <- get alice + get alice =##> \case ("6", _, OK) -> True; _ -> False get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False ackMessageAsync alice "7" bobId (baseId + 4) Nothing - ("7", _, OK) <- get alice + get alice =##> \case ("7", _, OK) -> True; _ -> False deleteConnectionAsync alice bobId get alice =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bobId; _ -> False get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False @@ -1332,7 +1338,7 @@ testAsyncCommandsRestore t = do withSmpServerStoreLogOn t testPort $ \_ -> do runRight_ $ do subscribeConnection alice' bobId - ("1", _, INV _) <- get alice' + get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () disconnectAgentClient alice' @@ -1343,8 +1349,7 @@ testAcceptContactAsync = aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, REQ invId _ "bob's connInfo") <- get alice bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" SMSubscribe - ("1", bobId', OK) <- get alice - liftIO $ bobId' `shouldBe` bobId + get alice =##> \case ("1", c, OK) -> c == bobId; _ -> False ("", _, CONF confId _ "alice's connInfo") <- get bob allowConnection bob aliceId confId "bob's connInfo" get alice ##> ("", bobId, INFO "bob's connInfo") @@ -1410,8 +1415,7 @@ testJoinConnectionAsyncReplyError t = do pure (aId, bId) nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False withSmpServerOn t testPort2 $ do - ("2", aId', OK) <- get b - liftIO $ aId' `shouldBe` aId + get b =##> \case ("2", c, OK) -> c == aId; _ -> False confId <- withSmpServerStoreLogOn t testPort $ \_ -> do pGet a >>= \case ("", "", APC _ (UP _ [_])) -> do @@ -2106,7 +2110,9 @@ testTwoUsers = withAgentClients2 $ \a b -> do getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> FilePath -> IO AgentClient getSMPAgentClient' clientId cfg' initServers dbPath = do Right st <- liftIO $ createAgentStore dbPath "" False MCError - getSMPAgentClient_ clientId cfg' initServers st False + c <- getSMPAgentClient_ clientId cfg' initServers st False + when (dbNew st) $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)") + pure c testServerMultipleIdentities :: HasCallStack => IO () testServerMultipleIdentities = diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 7dbaf3030..98fb47b80 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -34,6 +34,7 @@ import Simplex.Messaging.Agent.Client () import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite +import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import qualified Simplex.Messaging.Crypto as C @@ -69,6 +70,7 @@ createEncryptedStore key keepKey = do -- 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 + withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);") pure st removeStore :: SQLiteStore -> IO () diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 3c8246366..c32b69f10 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -7,7 +7,10 @@ import Control.DeepSeq import Control.Monad (unless, void) 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.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.Util (ifM) @@ -28,6 +31,8 @@ schemaDumpTest :: Spec schemaDumpTest = do it "verify and overwrite schema dump" testVerifySchemaDump it "verify schema down migrations" testSchemaMigrations + it "should NOT create user record for new database" testUsersMigrationNew + it "should create user record for old database" testUsersMigrationOld testVerifySchemaDump :: IO () testVerifySchemaDump = do @@ -61,6 +66,25 @@ testSchemaMigrations = do schema''' <- getSchema testDB testSchema schema''' `shouldBe` schema' +testUsersMigrationNew :: IO () +testUsersMigrationNew = do + Right st <- createSQLiteStore testDB "" False Migrations.app MCError + withTransaction' st (`SQL.query_` "SELECT user_id FROM users;") + `shouldReturn` ([] :: [Only Int]) + closeSQLiteStore st + +testUsersMigrationOld :: IO () +testUsersMigrationOld = do + let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app + Right st <- createSQLiteStore 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 + withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;") + `shouldReturn` ([Only (1 :: Int)]) + closeSQLiteStore st' + skipComparisonForDownMigrations :: [String] skipComparisonForDownMigrations = [ -- on down migration idx_messages_internal_snd_id_ts index moves down to the end of the file diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 74cea307a..1d280d4a4 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -10,12 +10,14 @@ module SMPAgentClient where +import Control.Monad import Control.Monad.IO.Unlift import Crypto.Random import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import qualified Database.SQLite.Simple as SQL import Network.Socket (ServiceName) import NtfClient (ntfTestPort) import SMPClient @@ -31,7 +33,8 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Server (runSMPAgentBlocking) -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) +import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (ProtoServerWithAuth) @@ -217,6 +220,7 @@ withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess = in serverBracket ( \started -> do Right st <- liftIO $ createAgentStore db' "" False MCError + when (dbNew st) . liftIO $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)") runSMPAgentBlocking t cfg' initServers' st started ) afterProcess