content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  {-# LANGUAGE QuasiQuotes #-}
  module Schema.Basic (main) where
  
  import Control.Concurrent
  import Control.Exception
  import Control.Monad
  import Data.Default
  import Data.Either
  import qualified Data.HashMap.Strict as HashMap
  import Data.List
  import qualified Data.Map as Map
  import Data.Maybe
  import Data.Text (Text, pack)
  import qualified Data.Text as Text
  import System.Directory
  import System.FilePath
  import System.IO.Temp
  import Test.HUnit
  
  import System.Timeout
  import TestRunner
  import Util.Control.Exception (tryAll)
  import Util.EventBase
  import Util.String.Quasi
  import Thrift.Util (saveJSON)
  
  import Glean.Angle.Types (latestAngleVersion)
  import Glean.Backend.Types
  import Glean.Database.Config
  import Glean.Database.Env
  import Glean.Database.Schema (validateNewSchemaInstance)
  import Glean.Database.Test
  import Glean.Derive
  import Glean.Display
  import Glean.Impl.ConfigProvider ()
  import Glean.Impl.TestConfigProvider
  import Glean.Init
  import qualified Glean.Internal.Types as Internal
  import qualified Glean.ServerConfig.Types as ServerConfig
  import Glean.Schema.Util
  import Glean.Types as Thrift
  import Glean.Util.ConfigProvider
  import qualified Glean.Util.ThriftSource as ThriftSource
  import Glean.Write.JSON
  
  import TestDB
  import Schema.Lib
  
  -- Test that we can extend the schema with a derived predicate after
  -- the DB has been created, and make a query using the new predicate.
  
  mergeSchemaTest :: Test
  mergeSchemaTest = TestCase $
    withSystemTempDirectory "glean-dbtest" $ \root -> do
      -- create the DB with the default schema
      repo <- withTestDB [setRoot root] $ \_ -> return
  
      -- create an extended schema
      let newSchemaFile = root </> "schema"
      SchemaIndex{..} <- parseSchemaDir schemaSourceDir
      writeFile newSchemaFile $ show $ displayDefault $
        procSchemaSource schemaIndexCurrent
      appendFile newSchemaFile
        [s|
          schema mergetest.1 {
            import glean.test.6
            # pick out the nat field from a glean.test.Predicate
            predicate JustNat : { predicate : glean.test.Predicate, nat : nat }
              {P,N} where P = glean.test.Predicate { nat = N }
          }
  
          schema all.99999: mergetest.1 {}
        |]
  
      -- query the existing DB using the extended schema
      withTestEnv [setRoot root, setSchemaPath newSchemaFile] $ \env -> do
        r <- try $ angleQuery env repo "mergetest.JustNat _"
        print (r :: Either BadQuery UserQueryResults)
        assertBool "merge" $ case r of
          Right UserQueryResults{..} -> length userQueryResults_facts == 4
          _ -> False
  
  
  -- This test is superseded by the tests in Schema/Multi.hs, we should retire
  -- it when support for use_schema_id = false is removed.
  schemaUnversioned :: Test
  schemaUnversioned = TestCase $ do
    let
      schema =
        [s|
            schema test.1 {
              predicate P : { a : nat }
            }
  
            schema test.2 {
              predicate P : { a : nat, b : nat }
            }
  
            schema all.1 : test.1 {}
            schema all.2 : test.2 {}
        |]
  
    let fill env repo =
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "test.P" 1)
                [ [s|{ "key" : { "a": 1 } }|] ]
            , mkBatch (PredicateRef "test.P" 2)
                [ [s|{ "key" : { "a": 1, "b": 1 } }|]
                , [s|{ "key" : { "a": 2, "b": 2 } }|]
                ]
            ]
            Nothing
  
    withSchemaFile latestAngleVersion schema $ \root file -> do
      let
        create repo propList =
          withTestEnv [setRoot root, setSchemaPath file] $ \env -> do
            kickOffTestDB env repo id
            let props = HashMap.fromList propList
            void $ updateProperties env repo props []
            fill env repo
            completeTestDB env repo
            return repo
  
      repo1 <- create (Thrift.Repo "schematest-repo" "1") []
  
      withTestEnv [setRoot root, setSchemaPath file] $ \env -> do
        -- Test that an unversioned query "test.P _" resolves to test.P.2,
        -- because the all.2 schema inherits from test.2 and we pick
        -- all.2 by default
        r <- try $ angleQuery env repo1 "test.P _"
        print (r :: Either BadQuery UserQueryResults)
        assertBool "unversioned 1" $ case r of
          Right UserQueryResults{..} -> length userQueryResults_facts == 2
          _ -> False
  
  
  schemaTypeError :: Test
  schemaTypeError = TestCase $ do
    let
      schema =
        [s|
          schema error.1 {
            predicate Test : { a : string, b : nat }
              {A,B} where {A,B} = {42, "xyz"}
          }
  
          schema all.1 : error.1 {}
        |]
  
    withSchema latestAngleVersion schema $ \r ->
      assertBool "schemaTypeError" $
        case r of
          Left e | Just (ErrorCall err) <- fromException e ->
            "type error" `isInfixOf` err
          _ -> False
  
  
  schemaStoredError :: Test
  schemaStoredError = TestCase $ do
    let
      schema =
        [s|
          schema error.1 {
            predicate P : { a : string, b : nat }
              {"xyz", 42}
  
            predicate Q : P # should be an error to refer to P here
              stored P _
          }
  
          schema all.1 : error.1 {}
        |]
  
    withSchema latestAngleVersion schema $ \r -> do
      print r
      assertBool "schemaStoredError" $
        case r of
          Left e | Just (ErrorCall err) <- fromException e ->
            "stored predicate" `isInfixOf` err
          _ -> False
  
  -- The validation run at gen-schema time.
  schemaGenValidation :: Test
  schemaGenValidation = TestList
    [ TestLabel "recursive derivation" $ TestCase $
        hasCycles
          [s|
            schema test.1 {
              predicate P : nat
                X where P X;
            }
  
            schema all.1 : test.1 {}
          |]
  
    , TestLabel "co-recursive derivation" $ TestCase $ do
        hasCycles
          [s|
            schema test.1 {
              predicate P : nat
                X where Q X;
  
              predicate Q : nat
                X where P X;
            }
  
            schema all.1 : test.1 {}
          |]
    ]
    where
      hasCycles schema = do
        r <- tryAll $ validate schema
        print r
        case r of
          Left err@SomeException{} ->
            assertBool "validation failure" $
            "found cycles in predicate derivations" `isInfixOf` show err
          _ -> assertFailure "did not fail validation"
  
      validate schema =
        withSystemTempDirectory "glean-dbtest" $ \root -> do
        let schemaPath = root </> "schema"
            indexPath = root </> "index"
            index = Internal.SchemaIndex curr older
              where
              older = []
              curr = Internal.SchemaInstance
                  { schemaInstance_versions = Map.fromList [ ("v1", 1) ]
                  , schemaInstance_file = pack schemaPath
                  }
        saveJSON indexPath index
        appendFile schemaPath schema
        schemaIndex <- parseSchemaIndex indexPath
        validateNewSchemaInstance schemaIndex
  
  schemaReservedWord :: Test
  schemaReservedWord = TestCase $ do
    let
      schema =
        [s|
          schema error.1 {
            type R = { class : string }
          }
  
          schema all.1 : error.1 {}
        |]
  
    withSchema latestAngleVersion schema $ \r ->
      assertBool "schemaReservedWord" $
        case r of
          Left e -> "class is a reserved word" `isInfixOf` show e
          _ -> False
  
  schemaUpperCaseField :: Test
  schemaUpperCaseField = TestCase $ do
    let
      schema =
        [s|
          schema error.1 {
            type T = { Field : nat }
          }
  
          schema all.1 : error.1 {}
        |]
  
    withSchema latestAngleVersion schema $ \r ->
      assertBool "schemaUpperCaseField" $
        case r of
          Left e -> "field names must begin with a lowercase" `isInfixOf` show e
          _ -> False
  
  schemaTypeShadowing :: Test
  schemaTypeShadowing = TestCase $ do
    withSchemaAndFacts []
      [s|
        schema x.1 {
          type Q = string
          predicate P : Q
        }
        schema x.2 {
          type Q = nat
          predicate P: Q
        }
        schema all.1 : x.1, x.2 {}
      |]
      [ mkBatch (PredicateRef "x.P" 2)
          [ [s|{ "key": 1 }|]
          , [s|{ "key": 2 }|]
          ]
      ]
      $ \env repo _ -> do
        let
          runQuery env repo q = userQuery env repo $ def
            { userQuery_query = q
            , userQuery_options = Just def
              { userQueryOptions_syntax = QuerySyntax_ANGLE }
            }
  
        response <- try $ runQuery env repo [s| x.P (x.Q _) |]
        print (response :: Either BadQuery UserQueryResults)
        -- This used to silently default to the latest version, but now
        -- we give an ambiguity error.  It's your responsibility to make
        -- sure there are no overlapping names exposed by the "all"
        -- schema.
        case response of
          Left err | "ambiguous" `isInfixOf` show err ->
            assertBool "ambiguous identifier" True
          _ -> assertFailure (show response)
  
  fakeSchemaKey :: Text
  fakeSchemaKey = "glean/schema"
  
  changeSchemaTest :: Test
  changeSchemaTest = TestCase $ do
      let
        schema_v0 =
          [s|
            schema test.1 {
              predicate P : { a : string, b : nat }
              predicate Q : { p : P }
            }
            schema all.1 : test.1 {}
          |]
  
        schema_v1 =
          [s|
            schema test.1 {
              predicate P : { a : string, b : nat }
              predicate Q : { p : P }
            }
            schema test.2 : test.1 {
              predicate P : { a : string, b : nat, c : {} }
            }
            schema all.1 : test.1, test.2 {}
          |]
  
      let repo = Thrift.Repo "schematest" "123"
  
      withEventBaseDataplane $ \evb -> do
        withConfigProvider defaultConfigOptions $ \confApi -> do
          setTestConfig confApi fakeSchemaKey schema_v0
  
          let
            dbConfig = def
              { cfgDataStore = tmpDataStore
              , cfgSchemaLocation = Just (SchemaLocation_config fakeSchemaKey)
              , cfgServerConfig = ThriftSource.value def
                  { ServerConfig.config_db_rocksdb_cache_mb = 0 }
              }
  
          withDatabases evb dbConfig (realConfigAPI confApi) $ \env -> do
            kickOffTestDB env repo id
            completeTestDB env repo
  
            info <- getSchemaInfo env (Just repo)
              def { getSchemaInfo_omit_source = True }
            assertBool "changeSchemaTest 1" $
              PredicateRef "test.P" 1 `elem`
                Map.elems (schemaInfo_predicateIds info)
            assertBool "changeSchemaTest 1" $
              PredicateRef "test.P" 2 `notElem`
                Map.elems (schemaInfo_predicateIds info)
  
            -- Now update the schema
            setTestConfig confApi fakeSchemaKey schema_v1
            -- wait for the schema to be updated for our repo
            let
              loop = do
                info <- getSchemaInfo env (Just repo)
                  def { getSchemaInfo_omit_source = True }
                when (PredicateRef "test.P" 2 `notElem`
                    Map.elems (schemaInfo_predicateIds info)) $
                  do putStrLn "waiting..."; threadDelay 1000000; loop
            r <- timeout 20000000 loop
            assertBool "changeSchemaTest 2" $ isJust r
  
  
  -- | Trying to write to a predicate that was not in the schema when
  -- the DB was created should fail.
  writeEphemeralPredicate :: Test
  writeEphemeralPredicate = TestCase $
    withSystemTempDirectory "glean-dbtest" $ \root -> do
      let
        schema_v0_file = root </> "schema0"
        schema_v0 =
          [s|
            schema test.1 {
              predicate P : { a : string, b : nat }
              predicate Q : { p : P }
            }
            schema all.1 : test.1 {}
          |]
  
        schema_v1_file = root </> "schema1"
        schema_v1 =
          [s|
            schema test.1 {
              predicate P : { a : string, b : nat }
              predicate Q : { p : P }
            }
            schema test.2 : test.1 {
              predicate P : { a : string, b : nat, c : {} }
            }
  
            schema all.1 : test.1, test.2 {}
          |]
  
      writeFile schema_v0_file schema_v0
      writeFile schema_v1_file schema_v1
  
      -- create the DB with the default schema
      repo <- withEmptyTestDB [setRoot root, setSchemaPath schema_v0_file] $
        \_env repo -> return repo
  
      -- try to write a fact from the new schema
      withTestEnv [setRoot root, setSchemaPath schema_v1_file] $ \env -> do
        -- this should work
        void $ syncWriteJsonBatch env repo
          [ mkBatch (PredicateRef "test.P" 1)
              [ "{ \"key\" : {} }" ]
          ]
          Nothing
  
        -- this should fail
        r <- try $ syncWriteJsonBatch env repo
          [ mkBatch (PredicateRef "test.P" 2)
              [ "{ \"key\" : {} }" ]
          ]
          Nothing
        print r
        assertBool "writeEphemeralPredicate" $ case r of
          Left e@Exception{} -> "not in scope" `isInfixOf` show e
          _ -> False
  
  
  backwardCompatDeriving :: Test
  backwardCompatDeriving = TestCase $
    withSystemTempDirectory "glean-dbtest" $ \root -> do
      let
        schema_v0_file = root </> "schema0"
        schema_v0 =
          [s|
            schema test.1 {
              predicate P : { a : string, b : nat }
              predicate Q : { p : P }
            }
            schema all.1 : test.1 {}
          |]
  
        schema_v1_file = root </> "schema1"
        schema_v1 =
          [s|
            version: 11
            schema test.1 {
              predicate P : { a : string, b : nat }
              predicate Q : { p : P }
            }
            schema test.2 : test.1 {
              predicate P : { a : string, b : nat, c : {} }
  
              derive test.P.1 default
                { A, B } where P.2 { A, B, _ }
            }
            schema all.1 : test.1 , test.2 {}
          |]
  
      writeFile schema_v0_file schema_v0
      writeFile schema_v1_file schema_v1
  
      -- create a DB with schema v0, create a fact of P.1
      repo0 <- withEmptyTestDB [setRoot root, setSchemaPath schema_v0_file] $
        \env repo -> do
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "test.P" 1)
                [ "{ \"key\" : {} }" ]
            ]
            Nothing
          completeTestDB env repo
          return repo
  
      -- open the DB with schema_v1, we should still be able to query
      -- for P.1 and get one fact
      withTestEnv [setRoot root, setSchemaPath schema_v1_file] $ \env -> do
         r <- try $ angleQuery env repo0 "test.P.1 _"
         print (r :: Either BadQuery UserQueryResults)
         assertBool "backcompat 1" $ case r of
           Right UserQueryResults{..} -> length userQueryResults_facts == 1
           _ -> False
  
         void $ deleteDatabase env repo0
  
      -- create a new DB with schema_v1, create a fact of P.2
      repo1 <- withEmptyTestDB [setRoot root, setSchemaPath schema_v1_file] $
        \env repo -> do
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "test.P" 2)
                [ "{ \"key\" : {} }" ]
            ]
            Nothing
          completeTestDB env repo
          return repo
  
      -- open the DB with schema_v1, we should be able to query for P.1 and P.2
      withTestEnv [setRoot root, setSchemaPath schema_v1_file] $ \env -> do
         r <- try $ angleQuery env repo1 "test.P.1 _"
         print (r :: Either BadQuery UserQueryResults)
         assertBool "backcompat 2" $ case r of
           Right UserQueryResults{..} -> length userQueryResults_facts == 1
           _ -> False
  
         r <- try $ angleQuery env repo1 "test.P.2 _"
         print (r :: Either BadQuery UserQueryResults)
         assertBool "backcompat 3" $ case r of
           Right UserQueryResults{..} -> length userQueryResults_facts == 1
           _ -> False
  
  deriveDefault :: Test
  deriveDefault = TestCase $
    withSystemTempDirectory "glean-dbtest" $ \root -> do
      let
        schema_v0_file = root </> "schema0"
        schema_v0 =
          [s|
            version: 11
            schema test.1 {
              predicate P : { a : string, b : nat }
              predicate Q : { p : P }
            }
            schema test.2 : test.1 {
              predicate P : { a : string, b : nat, c : {} }
  
              derive test.P.1 default
                { A, B } where P.2 { A, B, _ }
  
              derive test.P.2 default
                { A, B, {} } where test.P.1 { A, B }
            }
  
            schema all.1 : test.1, test.2 {}
          |]
  
      writeFile schema_v0_file schema_v0
  
      let
        -- we should be able to query for both P.1 and P.2
        checkQuery repo ss = do
          let settings = setRoot root : setSchemaPath schema_v0_file : ss
          withTestEnv settings $ \env -> do
             r <- try $ angleQuery env repo "test.P.1 _"
             print (r :: Either BadQuery UserQueryResults)
             assertBool "backcompat 1" $ case r of
               Right UserQueryResults{..} -> length userQueryResults_facts == 1
               _ -> False
  
             r <- try $ angleQuery env repo "test.P.2 _"
             print (r :: Either BadQuery UserQueryResults)
             assertBool "backcompat 2" $ case r of
               Right UserQueryResults{..} -> length userQueryResults_facts == 1
               _ -> False
      let
        mkP version env repo =
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "test.P" version)
                [ "{ \"key\" : {} }" ]
            ]
            Nothing
  
        mkRepo hash facts =
          withTestEnv [setRoot root, setSchemaPath schema_v0_file] $ \env -> do
            let repo = Repo "test" hash
            kickOffTestDB env repo id
            facts env repo
            completeTestDB env repo
            return repo
  
      -- create a DB with a fact of P.1
      repo0 <- mkRepo "1" (mkP 1)
      checkQuery repo0 []
  
      -- create a DB with a fact of P.2
      repo1 <- mkRepo "2" (mkP 2)
      checkQuery repo1 []
  
  schemaNegation :: [Test]
  schemaNegation =
    [ TestLabel "negation - derived" $ TestCase $ do
      -- a derived predicate can use negation
      withSchema latestAngleVersion
        [s|
          schema test.1 {
            predicate Base : string
            predicate Derived : string
              A where Base A; !(A = "x"..);
          }
          schema all.1 : test.1 {}
        |]
        $ \r ->
        assertBool "schemaNegation - derived" $
          case r of
            Left _ -> False
            Right _ -> True
  
    , TestLabel "negation - stored" $ TestCase $ do
      -- a stored predicate cannot use negation
      withSchema latestAngleVersion
        [s|
          schema test.1 {
            predicate Base : string
            predicate Stored : string
              stored A where Base A; !(A = "x"..);
          }
          schema all.1 : test.1 {}
        |]
        $ \r ->
        assertBool "schemaNegation - stored" $
          case r of
            Left e -> "use of negation is not allowed in a stored predicate"
              `isInfixOf` show e
            _ -> False
  
    , TestLabel "negation - stored if statements" $ TestCase $ do
      -- a stored predicate cannot use if statements
      withSchema latestAngleVersion
        [s|
          schema test.1 {
            predicate Base : string
            predicate Stored : string
              stored A where A = if (Base B) then B else "x"
          }
          schema all.1 : test.1 {}
        |]
        $ \r ->
        assertBool "schemaNegation - stored" $
          case r of
            Left e -> "use of if-statements is not allowed in a stored predicate"
              `isInfixOf` show e
            _ -> False
  
    , TestLabel "negation - stored dependency" $ TestCase $ do
      -- a stored predicate cannot depend on a derived
      -- predicate that uses negation
      withSchema latestAngleVersion
        [s|
          schema test.1 {
            predicate Base : string
            predicate Derived : string
              A where Base A; !(A = "x"..);
            predicate Stored : string
              stored A where Derived A
          }
          schema all.1 : test.1 {}
        |]
        $ \r ->
        assertBool "schemaNegation - stored dependency" $
          case r of
            Left e -> "negation is not allowed in a stored predicate"
              `isInfixOf` show e
            _ -> False
  
    , TestLabel "negation - stored dependency cross-schema" $ TestCase $ do
      -- use of negation is detected across schemas
      withSchema latestAngleVersion
        [s|
          schema test.1 {
            predicate Base : string
            predicate Derived : string
              A where Base A; !(A = "x"..);
          }
          schema test.2 : test.1 {
            predicate Stored : string
              stored A where Derived A
          }
          schema all.1 : test.1, test.2 {}
        |]
        $ \r ->
        assertBool "schemaNegation - stored dependency cross-schema" $
          case r of
            Left e -> "negation is not allowed in a stored predicate"
              `isInfixOf` show e
            _ -> False
    ]
  
  thinSchemaTest :: Test
  thinSchemaTest = TestCase $
    withSystemTempDirectory "glean-dbtest" $ \root -> do
      let
        schema_v0_file = root </> "schema0"
        schema_v0 =
          [s|
            schema test.1 {
              predicate P : { a : string, b : nat }
  
              # tickle a bug in which we used the wrong type environment
              # when checking predicates in the stored schema
              type T = string
              predicate Q : T stored "abc"
            }
  
            schema x.1 {
              predicate P : nat
            }
  
            schema all.1 : test.1, x.1 {}
          |]
  
        schema_v1_file = root </> "schema1"
        schema_v1 =
          [s|
            # delete schema test.1
            # to test that it is still stored in the DB
  
            schema x.1 {
              predicate P : string  # changed from nat to string
            }
  
            # This will be a type error if the old x.1 is still present
            schema x.2 : x.1 {
              predicate Q : string
                S where P S
            }
  
            schema all.1 : x.1, x.2 {}
          |]
  
      writeFile schema_v0_file schema_v0
      writeFile schema_v1_file schema_v1
  
      -- create a DB with schema v0, create a fact of test.P.1
      repo0 <- withEmptyTestDB [setRoot root, setSchemaPath schema_v0_file]
        $ \env repo -> do
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "test.P" 1)
                [ "{ \"key\" : {} }" ]
            ]
            Nothing
          completeTestDB env repo
          return repo
  
      -- open the DB with schema_v1, we should not be able to see
      -- test.P.1 any more when we query using the default schema
      -- version.
      withTestEnv [setRoot root, setSchemaPath schema_v1_file] $ \env -> do
         r <- try $ angleQuery env repo0 "test.P.1 _"
         print (r :: Either BadQuery UserQueryResults)
         assertBool "thin 1" $ case r of
           Left BadQuery{} -> True
           _ -> False
  
  stackedSchemaTest :: Test
  stackedSchemaTest = TestCase $
    withSystemTempDirectory "glean-dbtest" $ \root -> do
      let
        schema_v0_file = root </> "schema0"
        schema_v0 =
          [s|
            schema x.1 {
              predicate P : string
            }
  
            schema y.1 {
              predicate Q : string
            }
  
            schema all.1 : x.1, y.1 {}
          |]
      writeFile schema_v0_file schema_v0
  
      -- Test a stacked DB:
      --    base: 1 fact of x.P
      --    stacked: 1 fact of y.Q
      -- make sure that we can query x.P on the stacked DB.
      --
      -- This tickled a bug in the schema handling at one point, where
      -- we were over-eagerly removing schemas from the base DB and then
      -- assigning the wrong Pid to the predicates in the stacked DB.
  
      withEmptyTestDB [setRoot root, setSchemaPath schema_v0_file]
        $ \env repo -> do
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "x.P" 1)
                [ "{ \"key\" : \"a\" }" ]
            ]
            Nothing
          completeTestDB env repo
  
          let stacked = Repo "stacked" "0"
          kickOffTestDB env stacked $ \x -> x
            { Thrift.kickOff_dependencies =
               Just $ stackedDeps repo }
          void $ syncWriteJsonBatch env stacked
            [ mkBatch (PredicateRef "y.Q" 1)
                [ "{ \"key\" : \"b\" }" ]
            ]
            Nothing
          completeTestDB env stacked
  
          r <- try $ angleQuery env stacked "x.P _"
          print (r :: Either BadQuery UserQueryResults)
          assertEqual "stacked 1" 1 $ case r of
            Right UserQueryResults{..} -> length userQueryResults_facts
            _ -> error "bad query"
  
          r <- try $ angleQuery env stacked "y.Q _"
          print (r :: Either BadQuery UserQueryResults)
          assertEqual "stacked 2" 1 $ case r of
            Right UserQueryResults{..} -> length userQueryResults_facts
            _ -> error "bad query"
  
  
  -- | Test that we can extend the schema when creating a stacked DB
  stackedSchemaUpdateTest :: Test
  stackedSchemaUpdateTest = TestCase $
    withSystemTempDirectory "glean-dbtest" $ \root -> do
      let
        schema_v0_file = root </> "schema0"
        schema_v0 =
          [s|
            schema x.1 {
              predicate P : { a : string }
            }
  
            schema y.1 {
              predicate Q : string
            }
  
            schema all.1 : x.1, y.1 {}
          |]
      writeFile schema_v0_file schema_v0
  
      -- v1 changes y.Q in an incompatible way, and adds y.R
      let
        schema_v1_file = root </> "schema1"
        schema_v1 =
          [s|
            schema x.1 {
              predicate P : { a : string }
            }
  
            schema y.1 {
              predicate Q : { a : string }
  
              predicate R : string
            }
  
            schema all.1 : x.1, y.1 {}
          |]
      writeFile schema_v1_file schema_v1
  
      let
        schema_index_file_1 = root </> "schema_index_1"
        schema_index_1 = Internal.SchemaIndex
          { schemaIndex_current = Internal.SchemaInstance
            { schemaInstance_versions = Map.fromList [ ("v1", 1) ]
            , schemaInstance_file = "schema1"
            }
          , schemaIndex_older = []
          }
      saveJSON schema_index_file_1 schema_index_1
  
      -- v2 modifies x.P in a backwards compatible way, and removes y.R
      let
        schema_v2_file = root </> "schema2"
        schema_v2 =
          [s|
            schema x.1 {
              predicate P : { a : string, b : nat }
            }
  
            schema y.1 {
              predicate Q : { a : string }
            }
  
            schema all.1 : x.1, y.1 {}
          |]
      writeFile schema_v2_file schema_v2
  
      -- v3 modifies x.P and y.Q
      let
        schema_v3_file = root </> "schema3"
        schema_v3 =
          [s|
            schema x.1 {
              predicate P : { a : string }
            }
  
            schema y.1 {
              predicate Q : { a : string, b : nat }
  
              predicate D : string
                stored S where Q { a = S }
            }
  
            schema all.1 : x.1, y.1 {}
          |]
      writeFile schema_v3_file schema_v3
  
      let dbRoot = root </> "db"
      createDirectory dbRoot
  
      let
        mkRepo schema hash upd facts =
          withTestEnv [
              setRoot dbRoot,
              setSchemaPath schema ] $ \env -> do
            let repo = Repo "test" hash
            kickOffTestDB env repo upd
            facts env repo
            completeTestDB env repo
            return repo
  
        mkRepoIndex schema hash upd facts =
          withTestEnv [
              setRoot dbRoot,
              setSchemaIndex schema ] $ \env -> do
            let repo = Repo "test" hash
            kickOffTestDB env repo upd
            facts env repo
            completeTestDB env repo
            return repo
  
        testQuery name repo schema query result =
          withTestEnv [
              setRoot dbRoot,
              setSchemaPath schema ] $ \env -> do
            r <- try $ angleQuery env repo query
            case result of
              Just n -> case r :: Either BadQuery UserQueryResults of
                Right UserQueryResults{..} ->
                  assertEqual name n (length userQueryResults_facts)
                _ -> assertFailure (name <> ": " <> show r)
              Nothing -> assertBool name $ case r of
                Left{} -> True
                _ -> False
  
      repo0 <- mkRepo schema_v0_file "0" id $ \env repo ->
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "x.P" 1)
                [ [s| { "key" : { "a" : "x" } } |] ]
            ] Nothing
  
      -- switch to schema v1, make a stacked DB, we shouldn't be able to
      -- make a y.R fact
      let set x = x { Thrift.kickOff_dependencies =
             Just $ stackedDeps repo0 }
      r <- try $ mkRepo schema_v1_file "1" set $ \env repo ->
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "y.R" 1)
                [ [s| { "key" : { "a" : "x" } } |] ]
            ] Nothing
      print r
      assertBool "stacked schema 0" $
        case r of
          Left (e :: Thrift.Exception) -> "not in scope: y.R" `isInfixOf` show e
          _ -> False
  
      let set x = x {
             Thrift.kickOff_dependencies = Just $ stackedDeps repo0,
             Thrift.kickOff_properties = HashMap.insert "glean.schema_id" "v1"
               (kickOff_properties x) }
      r <- try $ mkRepoIndex schema_index_file_1 "1a" set $ \env repo ->
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "y.R" 1)
                [ [s| { "key" : "x" } |] ]
            ] Nothing
      print (r :: Either Thrift.Exception Repo)
      -- This should be allowed; the new schema is compatible with the
      -- base DB schema for the populated predicates. We don't have to
      -- use --update-schema-for-stacked because we explicitly requested
      -- the schema with glean.schema_id.
      assertBool "stacked schema 0a" $ isRight r
  
      -- switch to schema v1, make a stacked DB with update_schema_for_stacked
      -- works even though y.Q changed, because there are no facts of y.Q
      let set x = x {
            Thrift.kickOff_dependencies =
              Just $ stackedDeps repo0,
            Thrift.kickOff_update_schema_for_stacked = True }
      repo1 <- mkRepo schema_v1_file "2" set $ \env repo ->
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "y.R" 1)
                [ [s| { "key" : "abc" } |] ]
            ] Nothing
  
      testQuery "stacked schema 1" repo1 schema_v1_file "x.P _" (Just 1)
      testQuery "stacked schema 2" repo1 schema_v1_file "y.Q _" (Just 0)
      testQuery "stacked schema 3" repo1 schema_v1_file "y.R _" (Just 1)
  
      -- when the current schema is incompatible with the schema in the
      -- base DB, creating the stacked DB with update_schema_for_stacked
      -- should fail.
      let set x = x {
            Thrift.kickOff_dependencies =
              Just $ stackedDeps repo0,
            Thrift.kickOff_update_schema_for_stacked = True }
      r <- try $ mkRepo schema_v2_file "3" set $ \env repo ->
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "y.R" 1)
                [ [s| { "key" : "abc" } |] ]
            ] Nothing
      assertBool "stacked schema 4" $
        case r of
          Left (e :: Thrift.Exception) -> "incompatible" `isInfixOf` show e
          _ -> False
  
      -- switch to schema v3, make a stacked DB with update_schema_for_stacked
      let set x = x {
            Thrift.kickOff_dependencies =
              Just $ stackedDeps repo0,
            Thrift.kickOff_update_schema_for_stacked = True }
      repo4 <- mkRepo schema_v3_file "4" set $ \env repo -> do
          void $ syncWriteJsonBatch env repo
            [ mkBatch (PredicateRef "y.Q" 1)
                [ [s| { "key" : {} } |] ]
            ] Nothing
          derivePredicate env repo Nothing Nothing (parseRef "y.D") Nothing
  
      testQuery "stacked schema 5" repo4 schema_v3_file "x.P _" (Just 1)
      testQuery "stacked schema 6" repo4 schema_v3_file "y.Q _" (Just 1)
      testQuery "stacked schema 7" repo4 schema_v3_file "y.D _" (Just 1)
  
  stackedDeps :: Thrift.Repo -> Thrift.Dependencies
  stackedDeps (Thrift.Repo name hash) =
    Thrift.Dependencies_stacked $ Thrift.Stacked name hash Nothing
  
  schemaUnversionedImports :: Test
  schemaUnversionedImports = TestCase $ do
    let
      schema =
        [s|
          schema a.1 {}
          schema b.1 {}
          schema c.1 {}
          schema d.1 : a { import b }
          schema d evolves c
  
          schema all.1 : a, b, c, d {}
        |]
  
    withSchema latestAngleVersion schema $ \r ->
      assertBool "schemaUnversionedImports 1" $
        case r of
          Right{} -> True
          _ -> False
  
    let
      schema =
        [s|
          schema a.1 {}
          schema a.2 {}
          schema b.1 : a {}
  
          schema all.1 : a.1, a.2, b.1 {}
        |]
  
    let expectAmbiguous r =
          case r of
            Left e | Just (ThriftSource.ThriftSourceException err)
                <- fromException e ->
              "ambiguous schema" `Text.isInfixOf` err
            _ -> False
  
    withSchema latestAngleVersion schema $
      assertBool "schemaUnversionedImports 2" . expectAmbiguous
  
    let
      schema =
        [s|
          schema a.1 {}
          schema a.2 {}
          schema b.1 { import a }
  
          schema all.1 : a.1, a.2, b.1 {}
        |]
  
    withSchema latestAngleVersion schema $
      assertBool "schemaUnversionedImports 3" . expectAmbiguous
  
    let
      schema =
        [s|
          schema a.1 {}
          schema a.2 {}
          schema b.1 {}
          schema b evolves a
  
          schema all.1 : a.1, a.2, b {}
        |]
  
    withSchema latestAngleVersion schema $
      assertBool "schemaUnversionedImports 4" . expectAmbiguous
  
  
  main :: IO ()
  main = withUnitTest $ testRunner $ TestList $
    [ TestLabel "mergeSchemaTest" mergeSchemaTest
    , TestLabel "schemaTypeError" schemaTypeError
    , TestLabel "schemaStoredError" schemaStoredError
    , TestLabel "schemaGenValidation" schemaGenValidation
    , TestLabel "schemaReservedWord" schemaReservedWord
    , TestLabel "schemaUpperCaseField" schemaUpperCaseField
    , TestLabel "schemaTypeShadowing" schemaTypeShadowing
    , TestLabel "changeSchema" changeSchemaTest
    , TestLabel "writeEphemeralPredicate" writeEphemeralPredicate
    , TestLabel "backwardCompatDeriving" backwardCompatDeriving
    , TestLabel "deriveDefault" deriveDefault
    , TestLabel "thinSchema" thinSchemaTest
    , TestLabel "schemaUnversioned" schemaUnversioned
    , TestLabel "stackedSchemaTest" stackedSchemaTest
    , TestLabel "stackedSchemaUpdateTest" stackedSchemaUpdateTest
    , TestLabel "schemaUnversionedImports" schemaUnversionedImports
    ] ++ schemaNegation
  