Add basic Sandbox data continuity tests (#5826)

* Add basic Sandbox data continuity tests

This adds some basic tests that check that data migrations work
properly. For now, I use DAML Script to create and query contracts at
each step. This isn’t perfect since queries can only use the active
contract service but not things like the transaction stream but it’s
clearly better than nothing.

The runner for executing the tests is a simple Haskell executable. It
didn’t really seem useful to throw tasty at this.

I’ve added two sets of tests, one that runs only through stable
versions and one that includes snapshots since migrating through
snapshots is not necessarily equivalent.

Sadly these tests use sandbox-classic since I discovered while writing
these tests that sandbox-next does not actually support migrating data
between SDK versions.

changelog_begin
changelog_end

* Use the sandbox module instead of a custom withSandbox

changelog_begin
changelog_end

* Update compatibility/sandbox-migration/SandboxMigrationRunner.hs

Co-authored-by: Andreas Herrmann <42969706+aherrmann-da@users.noreply.github.com>

Co-authored-by: Andreas Herrmann <42969706+aherrmann-da@users.noreply.github.com>

compatibility/BUILD

@@ -9,6 +9,7 @@ load(
     "daml_script_dar",
     "daml_script_test",
 )
+load("//sandbox-migration:util.bzl", "migration_test")
 
 config_setting(
     name = "ghci_data",
@@ -31,12 +32,18 @@ platform_versions = [
     "0.0.0",
 ]
 
+# TODO Generate this automatically.
+stable_platform_versions = [
+    "1.0.0",
+    "0.0.0",
+]
+
 [
     sh_binary(
         name = "sandbox-with-postgres-{}".format(version),
         srcs = ["@//bazel_tools:sandbox-with-postgres.sh"],
         data = [
-            "@//bazel_tools/client_server:with-postgres",
+            "@//bazel_tools/client_server/with-postgres:with-postgres-exe",
             "@daml-sdk-{}//:daml".format(version),
         ],
         deps = ["@bazel_tools//tools/bash/runfiles"],
@@ -76,3 +83,17 @@ test_suite(
     name = "head-quick",
     tags = ["head-quick"],
 )
+
+# We have two migration tests: migration-stable runs through all stable releases
+# including current HEAD. migration-all includes snapshot releases.
+
+migration_test(
+    name = "migration-stable",
+    tags = ["head-quick"],
+    versions = stable_platform_versions,
+) if not is_windows else None
+
+migration_test(
+    name = "migration-all",
+    versions = platform_versions,
+) if not is_windows else None

compatibility/bazel-haskell-deps.bzl

@@ -56,6 +56,7 @@ def daml_haskell_deps():
             "tasty",
             "tasty-hunit",
             "text",
+            "optparse-applicative",
         ] + (["unix"] if not is_windows else ["Win32"]),
         stack = "@stack_windows//:stack.exe" if is_windows else None,
         tools = [

compatibility/bazel_tools/client_server/BUILD

@@ -13,23 +13,3 @@ da_haskell_binary(
     ],
     visibility = ["//visibility:public"],
 )
-
-da_haskell_binary(
-    name = "with-postgres",
-    srcs = ["WithPostgres.hs"],
-    data = [
-        "@postgresql_nix//:all",
-    ],
-    hackage_deps = [
-        "base",
-        "directory",
-        "extra",
-        "filepath",
-        "process",
-        "text",
-    ],
-    visibility = ["//visibility:public"],
-    deps = [
-        "@rules_haskell//tools/runfiles",
-    ],
-)

compatibility/bazel_tools/client_server/with-postgres/BUILD

@@ -0,0 +1,32 @@
+load("@daml//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library")
+
+da_haskell_library(
+    name = "with-postgres",
+    srcs = ["lib/WithPostgres.hs"],
+    data = [
+        "@postgresql_nix//:all",
+    ],
+    hackage_deps = [
+        "base",
+        "directory",
+        "extra",
+        "filepath",
+        "process",
+        "text",
+    ],
+    visibility = ["//visibility:public"],
+)
+
+da_haskell_binary(
+    name = "with-postgres-exe",
+    srcs = ["exe/Main.hs"],
+    hackage_deps = [
+        "base",
+        "process",
+        "text",
+    ],
+    visibility = ["//visibility:public"],
+    deps = [
+        ":with-postgres",
+    ],
+)

compatibility/bazel_tools/client_server/with-postgres/exe/Main.hs

@@ -0,0 +1,16 @@
+-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module Main (main) where
+
+import qualified Data.Text as T
+import System.Environment
+import System.Process
+
+import WithPostgres
+
+main :: IO ()
+main = do
+    (arg : args) <- getArgs
+    withPostgres $ \jdbcUrl ->
+        callProcess arg (args <> ["--jdbcurl=" <> T.unpack jdbcUrl])

compatibility/bazel_tools/client_server/with-postgres/lib/WithPostgres.hs

@@ -1,13 +1,12 @@
 -- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
-module Main (main) where
+module WithPostgres (withPostgres) where
 
 import Control.Exception
 import Data.Text (Text)
 import qualified Data.Text as T
 import System.Directory.Extra
-import System.Environment
 import System.FilePath
 import System.IO.Extra
 import System.Process
@@ -76,8 +75,3 @@ withPostgres f =
             callProcess
                 "external/postgresql_nix/bin/createdb"
                 ["-h", "localhost", "-U", T.unpack dbUser, "-p", show dbPort, T.unpack dbName]
-main :: IO ()
-main = do
-    (arg : args) <- getArgs
-    withPostgres $ \jdbcUrl ->
-        callProcess arg (args <> ["--jdbcurl=" <> T.unpack jdbcUrl])

compatibility/bazel_tools/daml_ledger/BUILD.bazel

@@ -21,6 +21,7 @@ da_haskell_library(
         "tasty",
         "text",
     ],
+    visibility = ["//visibility:public"],
 )
 
 da_haskell_binary(

compatibility/bazel_tools/daml_ledger/Sandbox.hs

@@ -10,11 +10,14 @@ module Sandbox
   , withSandbox
   , createSandbox
   , destroySandbox
+  , readPortFile
+  , maxRetries
+  , nullDevice
   ) where
 
 import Control.Concurrent (threadDelay)
 import Control.Exception.Safe (catchJust, mask, onException)
-import Control.Monad (guard)
+import Control.Monad
 import qualified Data.Text.IO as T
 import Safe (readMay)
 import System.Environment (getEnvironment)
@@ -101,7 +104,7 @@ createSandbox :: FilePath -> Handle -> SandboxConfig -> IO SandboxResource
 createSandbox portFile sandboxOutput conf = do
     sandboxProc <- getSandboxProc conf portFile
     mask $ \unmask -> do
-        ph <- createProcess sandboxProc { std_out = UseHandle sandboxOutput }
+        ph <- createProcess sandboxProc { std_out = UseHandle sandboxOutput, create_group = True }
         let waitForStart = do
                 port <- readPortFile maxRetries portFile
                 pure (SandboxResource ph port)
@@ -125,7 +128,12 @@ data SandboxResource = SandboxResource
     }
 
 destroySandbox :: SandboxResource -> IO ()
-destroySandbox = cleanupProcess . sandboxProcess
+destroySandbox SandboxResource{..} = do
+    let (_, _, _, ph) = sandboxProcess
+    -- This is a shell script so we kill the whole process group.
+    interruptProcessGroupOf ph
+    cleanupProcess sandboxProcess
+    void $ waitForProcess ph
 
 nullDevice :: FilePath
 nullDevice

compatibility/bazel_tools/sandbox-with-postgres.sh

@@ -15,9 +15,9 @@ source "${RUNFILES_DIR:-/dev/null}/$f" 2>/dev/null || \
 set -eou pipefail
 version=$1
 extra_args="${@:2}"
-WITH_POSTGRES=$(rlocation compatibility/bazel_tools/client_server/with-postgres)
+WITH_POSTGRES=$(rlocation compatibility/bazel_tools/client_server/with-postgres/with-postgres-exe)
 if [ -z "$WITH_POSTGRES" ]; then
-    WITH_POSTGRES=$(rlocation compatibility/bazel_tools/client_server/with-postgres.exe)
+    WITH_POSTGRES=$(rlocation compatibility/bazel_tools/client_server/with-postgres/with-postgres.exe)
 fi
 if [ -z "$WITH_POSTGRES" ]; then
     echo "Faild to find with-postgres wrapper"

compatibility/sandbox-migration/BUILD

@@ -0,0 +1,78 @@
+load("@daml//bazel_tools:haskell.bzl", "da_haskell_binary", "da_haskell_library")
+load(":util.bzl", "migration_test")
+
+genrule(
+    name = "migration-model",
+    srcs = ["daml/Model.daml"],
+    outs = ["migration-model.dar"],
+    cmd = """
+TMP=$$(mktemp -d)
+trap "rm -rf $$TMP" EXIT
+LOCS=($(locations @daml-sdk-1.0.0//:daml))
+DAML=$${LOCS[0]}
+
+cat > $$TMP/daml.yaml <<EOF
+sdk-version: 1.0.0
+source: .
+name: migration-model
+version: 1.0.0
+dependencies: [daml-stdlib, daml-prim]
+EOF
+
+cp $(location :daml/Model.daml) $$TMP/Model.daml
+$$DAML build --project-root $$TMP -o $$PWD/$(location :migration-model.dar)
+""",
+    tools = ["@daml-sdk-1.0.0//:daml"],
+    visibility = ["//visibility:public"],
+)
+
+genrule(
+    name = "migration-script",
+    srcs = [
+        "daml/Script.daml",
+        ":migration-model.dar",
+    ],
+    outs = ["migration-script.dar"],
+    cmd = """
+set -eou pipefail
+TMP=$$(mktemp -d)
+trap "rm -rf $$TMP" EXIT
+LOCS=($(locations @daml-sdk-1.0.0//:daml))
+DAML=$${LOCS[0]}
+
+cat > $$TMP/daml.yaml <<EOF
+sdk-version: 1.0.0
+source: .
+name: migration-script
+version: 1.0.0
+dependencies: [daml-stdlib, daml-prim, daml-script, migration-model.dar]
+EOF
+
+cp -L $(location :migration-model.dar) $$TMP
+cp -L $(location :daml/Script.daml) $$TMP/Script.daml
+$$DAML build --project-root $$TMP -o $$PWD/$(location :migration-script.dar)
+""",
+    tools = ["@daml-sdk-1.0.0//:daml"],
+    visibility = ["//visibility:public"],
+)
+
+da_haskell_binary(
+    name = "sandbox-migration-runner",
+    srcs = ["SandboxMigrationRunner.hs"],
+    hackage_deps = [
+        "aeson",
+        "base",
+        "extra",
+        "filepath",
+        "optparse-applicative",
+        "process",
+        "text",
+    ],
+    visibility = ["//visibility:public"],
+    deps = [
+        "//bazel_tools/client_server/with-postgres",
+        "//bazel_tools/daml_ledger:sandbox-helper",
+    ],
+)
+
+exports_files(["test.sh"])

compatibility/sandbox-migration/SandboxMigrationRunner.hs

@@ -0,0 +1,181 @@
+-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+module Main (main) where
+
+-- This test runs through the following steps:
+-- 1. Start postgres
+-- 2. Start the oldest version of sandbox.
+-- 3. Upload a DAR using the same SDK version.
+-- 4. Stop sandbox.
+-- 5. In a loop over all versions:
+--    1. Start sandbox of the given version.
+--    2. Run a script for querying and creating new contracts.
+--    3. Stop sandbox.
+-- 6. Stop postgres.
+
+import Control.Exception
+import Control.Monad
+import qualified Data.Aeson as A
+import Data.Foldable
+import qualified Data.Text as T
+import GHC.Generics
+import Options.Applicative
+import Sandbox
+    ( createSandbox
+    , defaultSandboxConf
+    , destroySandbox
+    , nullDevice
+    , sandboxPort
+    , SandboxConfig(..)
+    )
+import System.Environment.Blank
+import System.FilePath
+import System.IO.Extra
+import System.Process
+import WithPostgres (withPostgres)
+
+data Options = Options
+  { scriptDar :: FilePath
+  , modelDar :: FilePath
+  , scriptAssistant :: FilePath
+  -- ^ Assistant binary used to run DAML Script
+  , platformAssistants :: [FilePath]
+  -- ^ Ordered list of assistant binaries that will be used to run sandbox.
+  -- We run through migrations in the order of the list
+  }
+
+optsParser :: Parser Options
+optsParser = Options
+    <$> strOption (long "script-dar")
+    <*> strOption (long "model-dar")
+    <*> strOption (long "script-assistant")
+    <*> many (strArgument mempty)
+
+main :: IO ()
+main = do
+    -- Limit sandbox and DAML Script memory.
+    setEnv "_JAVA_OPTIONS" "-Xms128m -Xmx1g" True
+    Options{..} <- execParser (info optsParser fullDesc)
+    withPostgres $ \jdbcUrl -> do
+        initialPlatform : _ <- pure platformAssistants
+        hPutStrLn stderr "--> Uploading model DAR"
+        withSandbox initialPlatform jdbcUrl $ \p ->
+            callProcess initialPlatform
+                [ "ledger"
+                , "upload-dar", modelDar
+                , "--host=localhost", "--port=" <> show p
+                ]
+        hPutStrLn stderr "<-- Uploaded model DAR"
+        void $ foldlM (testVersion scriptAssistant scriptDar jdbcUrl) [] platformAssistants
+
+testVersion :: FilePath -> FilePath -> T.Text -> [Tuple2 (ContractId T) T] -> FilePath -> IO [Tuple2 (ContractId T) T]
+testVersion scriptAssistant scriptDar jdbcUrl prevTs assistant = do
+    let note = takeFileName (takeDirectory assistant)
+    hPutStrLn stderr ("--> Testing " <> note)
+    withSandbox assistant jdbcUrl $ \port ->
+        withTempFile $ \inputFile ->
+        withTempFile $ \outputFile -> do
+        A.encodeFile inputFile (ScriptInput testProposer testAccepter note)
+        callProcess scriptAssistant
+            [ "script"
+            , "--dar"
+            , scriptDar
+            , "--ledger-host=localhost"
+            , "--ledger-port=" <> show port
+            , "--input-file", inputFile
+            , "--output-file", outputFile
+            , "--script-name=Script:run"
+            ]
+        Just Result{..} <- A.decodeFileStrict' outputFile
+        -- Test that all proposals are archived.
+        unless (null oldTProposals) $
+            fail ("Expected no old TProposals but got " <> show oldTProposals)
+        unless (null newTProposals) $
+            fail ("Expected no new TProposals but got " <> show newTProposals)
+        unless (prevTs == oldTs) $
+            fail ("Active ts should not have changed after migration: " <> show (prevTs, oldTs))
+        -- Test that no T contracts got archived.
+        let missingTs = filter (`notElem` newTs) oldTs
+        unless (null missingTs) $
+            fail ("The following contracts got lost during the migration: " <> show missingTs)
+        -- Test that only one new T contract is not archived.
+        let addedTs = filter (`notElem` oldTs) newTs
+        case addedTs of
+            [Tuple2 _ t] -> do
+                let expected = T testProposer testAccepter note
+                unless (t == expected) $
+                    fail ("Expected " <> show expected <> " but got " <> show t)
+            _ -> fail ("Expected 1 new T contract but got: " <> show addedTs)
+        hPutStrLn stderr ("<-- Tested " <> note)
+        pure newTs
+
+testProposer :: Party
+testProposer = Party "proposer"
+
+testAccepter :: Party
+testAccepter = Party "accepter"
+
+-- The datatypes are defined such that the autoderived Aeson instances
+-- match the DAML-LF JSON encoding.
+
+newtype ContractId t = ContractId T.Text
+  deriving newtype A.FromJSON
+  deriving stock (Eq, Show)
+newtype Party = Party T.Text
+  deriving newtype (A.FromJSON, A.ToJSON)
+  deriving stock (Eq, Show)
+
+data T = T
+  { proposer :: Party
+  , accepter :: Party
+  , note :: String
+  } deriving (Eq, Generic, Show)
+
+instance A.FromJSON T
+
+data TProposal = TProposal
+  { proposer :: Party
+  , accepter :: Party
+  , note :: T.Text
+  } deriving (Generic, Show)
+
+instance A.FromJSON TProposal
+
+data ScriptInput = ScriptInput
+  { _1 :: Party
+  , _2 :: Party
+  , _3 :: String
+  } deriving Generic
+
+instance A.ToJSON ScriptInput
+
+data Tuple2 a b = Tuple2
+  { _1 :: a
+  , _2 :: b
+  } deriving (Eq, Generic, Show)
+
+instance (A.FromJSON a, A.FromJSON b) => A.FromJSON (Tuple2 a b)
+
+data Result = Result
+  { oldTProposals :: [Tuple2 (ContractId TProposal) TProposal]
+  , newTProposals :: [Tuple2 (ContractId TProposal) TProposal]
+  , oldTs :: [Tuple2 (ContractId T) T]
+  , newTs :: [Tuple2 (ContractId T) T]
+  } deriving Generic
+
+instance A.FromJSON Result
+
+withSandbox :: FilePath -> T.Text -> (Int -> IO a) -> IO a
+withSandbox assistant jdbcUrl f =
+    withBinaryFile nullDevice ReadWriteMode $ \handle ->
+    withTempFile $ \portFile ->
+    bracket (createSandbox portFile handle sandboxConfig) destroySandbox $ \resource ->
+      f (sandboxPort resource)
+  where
+    sandboxConfig = defaultSandboxConf
+        { sandboxBinary = assistant
+        , sandboxArgs = ["sandbox-classic", "--jdbcurl=" <> T.unpack jdbcUrl]
+        }

compatibility/sandbox-migration/daml/Model.daml

@@ -0,0 +1,28 @@
+-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module Model where
+
+template TProposal
+  with
+    proposer : Party
+    accepter : Party
+    note : Text
+  where
+    signatory proposer
+    observer accepter
+    choice Accept : ContractId T
+      controller accepter
+      do create T with ..
+
+template T
+  with
+    proposer : Party
+    accepter : Party
+    note : Text
+  where
+    signatory [proposer, accepter]
+    choice UnilateralArchive : ()
+      controller proposer
+      do pure ()
+

compatibility/sandbox-migration/daml/Script.daml

@@ -0,0 +1,30 @@
+-- Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module Script where
+
+import Daml.Script
+import Model
+
+data Result = Result with
+  oldTProposals : [(ContractId TProposal, TProposal)]
+  newTProposals : [(ContractId TProposal, TProposal)]
+  oldTs : [(ContractId T, T)]
+  newTs : [(ContractId T, T)]
+
+-- We create two proposal contracts, accept both of them
+-- and then archive one of the newly created T contracts.
+-- We query before and after and return the results in `Result`.
+run : (Party, Party, Text) -> Script Result
+run (proposer, accepter, note) = do
+  oldTProposals <- query @TProposal proposer
+  oldTs <- query @T proposer
+  proposal0 <- submit proposer (createCmd TProposal with ..)
+  proposal1 <- submit proposer (createCmd TProposal with ..)
+  t0 <- submit accepter (exerciseCmd proposal0 Accept)
+  t1 <- submit accepter (exerciseCmd proposal1 Accept)
+  submit proposer (exerciseCmd t0 UnilateralArchive)
+  newTProposals <- query @TProposal proposer
+  newTs <- query @T proposer
+  pure Result with ..
+

compatibility/sandbox-migration/test.sh

@@ -0,0 +1,30 @@
+#!/usr/bin/env bash
+# Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+# SPDX-License-Identifier: Apache-2.0
+
+
+# Copy-pasted from the Bazel Bash runfiles library v2.
+set -uo pipefail; f=bazel_tools/tools/bash/runfiles/runfiles.bash
+source "${RUNFILES_DIR:-/dev/null}/$f" 2>/dev/null || \
+  source "$(grep -sm1 "^$f " "${RUNFILES_MANIFEST_FILE:-/dev/null}" | cut -f2- -d' ')" 2>/dev/null || \
+  source "$0.runfiles/$f" 2>/dev/null || \
+  source "$(grep -sm1 "^$f " "$0.runfiles_manifest" | cut -f2- -d' ')" 2>/dev/null || \
+  source "$(grep -sm1 "^$f " "$0.exe.runfiles_manifest" | cut -f2- -d' ')" 2>/dev/null || \
+  { echo>&2 "ERROR: cannot find $f"; exit 1; }; f=; set -e
+# --- end runfiles.bash initialization v2 ---
+set -euox pipefail
+
+RUNNER="$(rlocation $TEST_WORKSPACE/sandbox-migration/sandbox-migration-runner)"
+SCRIPT_DAR="$(rlocation $TEST_WORKSPACE/sandbox-migration/migration-script.dar)"
+MODEL_DAR="$(rlocation $TEST_WORKSPACE/sandbox-migration/migration-model.dar)"
+SCRIPT_ASSISTANT="$(rlocation daml-sdk-0.0.0/daml)"
+SANDBOX_ARGS=""
+for PLATFORM in $@; do
+    SANDBOX_ARGS="$SANDBOX_ARGS $(rlocation daml-sdk-$PLATFORM/daml)"
+done
+$RUNNER \
+    --script-dar $SCRIPT_DAR \
+    --model-dar $MODEL_DAR \
+    --script-assistant $SCRIPT_ASSISTANT \
+    $SANDBOX_ARGS
+

compatibility/sandbox-migration/util.bzl

@@ -0,0 +1,16 @@
+# Copyright (c) 2020 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+# SPDX-License-Identifier: Apache-2.0
+
+def migration_test(name, versions, **kwargs):
+    native.sh_test(
+        name = name,
+        srcs = ["//sandbox-migration:test.sh"],
+        deps = ["@bazel_tools//tools/bash/runfiles"],
+        data = [
+            "//sandbox-migration:sandbox-migration-runner",
+            "//sandbox-migration:migration-script.dar",
+            "//sandbox-migration:migration-model.dar",
+        ] + ["@daml-sdk-{}//:daml".format(ver) for ver in versions],
+        args = versions,
+        **kwargs
+    )