content: -- Copyright (c) 2025 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
  -- SPDX-License-Identifier: Apache-2.0
  
  {-# LANGUAGE DuplicateRecordFields #-}
  
  module DA.Ledger.Tests (main) where
  
  {- HLINT ignore "locateRunfiles/package_app" -}
  
  import Control.Monad
  import Control.Monad.IO.Class(liftIO)
  import DA.Bazel.Runfiles
  import DA.Daml.LF.Proto3.Archive (decodeArchivePackageId)
  import DA.Daml.LF.Reader(DalfManifest(..), Dalfs(..), readDalfs, readDalfManifest)
  import DA.Ledger as Ledger
  import DA.Test.Sandbox
  import Data.List (isInfixOf,(\\))
  import Data.IORef
  import Prelude hiding(Enum)
  import System.Environment.Blank (setEnv)
  import System.FilePath
  import Test.Tasty as Tasty (TestName,TestTree,testGroup,withResource,defaultMain)
  import Test.Tasty.HUnit as Tasty(assertFailure,assertBool,assertEqual,testCase)
  import qualified "zip-archive" Codec.Archive.Zip as Zip
  import qualified DA.Daml.LF.Ast as LF
  import qualified Data.ByteString as BS (readFile)
  import qualified Data.ByteString.Lazy as BSL (readFile,toStrict)
  import qualified Data.ByteString.UTF8 as BS (ByteString,fromString)
  import qualified Data.Set as Set
  import qualified Data.Text.Lazy as TL(Text,pack,fromStrict,splitOn)
  
  main :: IO ()
  main = do
      setEnv "TASTY_NUM_THREADS" "1" True
      testDar <- locateRunfiles darPath
      Tasty.defaultMain $ testGroup "Ledger bindings"
          [ sharedSandboxTests testDar
          , authenticatingSandboxTests testDar
          ]
  
  type SandboxTest = WithSandbox -> TestTree
  
  -- (RH) flakyTests are those tests that relie on DA.Ledger.Stream, nonFlakyTests do not
  nonFlakyTests :: [WithSandbox -> TestTree]
  flakyTests :: [WithSandbox -> TestTree]
  nonFlakyTests =
      [ tListPackages
      , tGetPackage
      , tGetPackageBad
      , tGetPackageStatusRegistered
      , tGetPackageStatusUnspecify
      , tGetParticipantId
      , tUploadDarFileBad
      , tAllocateParty
      ]
  flakyTests =
      [ tUploadDarFileGood
      ]
  
  -- (RH) We disable all test that rely on stream to reduce flakyness
  testFlaky :: Bool
  testFlaky = False
  
  sharedSandboxTests :: FilePath -> TestTree
  sharedSandboxTests testDar = testGroupWithSandbox testDar Nothing "shared sandbox"
    ( nonFlakyTests ++ if testFlaky then flakyTests else [] )
  
  authenticatingSandboxTests :: FilePath -> TestTree
  authenticatingSandboxTests testDar =
    testGroupWithSandbox testDar mbSecret "shared authenticating sandbox"
    [ tListPackages
    , tAllocateParty
    , tUploadDarFileGood
    ]
    where mbSecret = Just (Secret "Brexit-is-a-very-silly-idea")
  
  -- | Drops the `::[0-9a-f]+` after a party name, so we can determinstically compare
  dropPartyDetailHash :: PartyDetails -> PartyDetails
  dropPartyDetailHash p = p {party = Party $ dropHashSuffix $ unParty $ party p}
  
  -- | Drops the `::[0-9a-f]+` suffix from a given string
  dropHashSuffix :: TL.Text -> TL.Text
  dropHashSuffix = head . TL.splitOn "::"
  
  run :: WithSandbox -> (DarMetadata -> TestId -> LedgerService ()) -> IO ()
  run withSandbox f =
    withSandbox $ \sandbox maybeAuth darMetadata testId -> runWithSandbox sandbox maybeAuth (f darMetadata testId)
  
  tListPackages :: SandboxTest
  tListPackages withSandbox = testCase "listPackages" $ run withSandbox $ \DarMetadata{mainPackageId,manifest} _testId -> do
      pids <- listPackages
      liftIO $ do
          putStrLn ("PIDS" <> show pids)
          putStrLn ("dalfPaths manifest" <> show (dalfPaths manifest))
          -- Canton loads the `AdminWorkflows` package at boot, hence the + 1.
          -- The `AdminWorkflows` package transitively pulls the 2.1 prim and
          -- stdlib packages, while our test dar pulls the 2.dev ones, hence the 
          -- temporary + 2.
          -- TODO(https://github.com/digital-asset/daml/issues/18457): revert to
          --  just +1 once the test dar targets 2.1 again.
          assertEqual "#packages" (length (dalfPaths manifest) + 1 + 2) (length pids)
          assertBool "The pid is listed" (mainPackageId `elem` pids)
  
  tGetPackage :: SandboxTest
  tGetPackage withSandbox = testCase "getPackage" $ run withSandbox $ \DarMetadata{mainPackageId} _testId -> do
      Just (Package bs) <- getPackage mainPackageId
      liftIO $ assertBool "contents" ("currency" `isInfixOf` show bs)
  
  tGetPackageBad :: SandboxTest
  tGetPackageBad withSandbox = testCase "getPackage/bad" $ run withSandbox $ \_darMetadata _testId -> do
      let pid = PackageId "xxxxxxxxxxxxxxxxxxxxxx"
      Nothing <- getPackage pid
      return ()
  
  tGetPackageStatusRegistered :: SandboxTest
  tGetPackageStatusRegistered withSandbox = testCase "getPackageStatus/Registered" $ run withSandbox $ \DarMetadata{mainPackageId} _testId -> do
      status <- getPackageStatus mainPackageId
      liftIO $ assertBool "status" (status == PackageStatusPACKAGE_STATUS_REGISTERED)
  
  tGetPackageStatusUnspecify :: SandboxTest
  tGetPackageStatusUnspecify withSandbox = testCase "getPackageStatus/Unspecify" $ run withSandbox $ \_darMetadata _testId -> do
      let pid = PackageId "xxxxxxxxxxxxxxxxxxxxxx"
      status <- getPackageStatus pid
      liftIO $ assertBool "status" (status == PackageStatusPACKAGE_STATUS_UNSPECIFIED)
  
  tUploadDarFileBad :: SandboxTest
  tUploadDarFileBad withSandbox = testCase "tUploadDarFileBad" $ run withSandbox $ \_darMetadata _testId -> do
      Right _ <- uploadDummy -- force uploading the stdlib
      let bytes = BS.fromString "not-the-bytes-for-a-darfile"
      Left err <- uploadDarFileGetPid bytes
      liftIO $ assertTextContains err "Dar file is corrupt"
  
  -- This test flakes with a `NO_SYNCHRONIZER_FOR_SUBMISSION`
  -- The error class in scala includes a reasons for each domain, but that isn't forwarded here, and is difficult to obtain
  -- I'd assume the domain is somehow still busy from the upload in some way?
  tUploadDarFileGood :: SandboxTest
  tUploadDarFileGood withSandbox = testCase "tUploadDarFileGood" $ run withSandbox $ \_darMetadata _testId -> do
      Right _ <- uploadDummy -- force uploading the stdlib
      bytes <- liftIO getBytesForUpload
      before <- listKnownPackages
      pid <- uploadDarFileGetPid bytes >>= either (liftIO . assertFailure) return
      after <- listKnownPackages
      let getPid PackageDetails{pid} = pid
      liftIO $ assertEqual "new pids"
          (Set.fromList (map getPid after) Set.\\ Set.fromList (map getPid before))
          (Set.singleton pid)
  
  getBytesDummy :: IO BS.ByteString
  getBytesDummy = do
          let extraDarFilename = "language-support/hs/bindings/dummy.dar"
          file <- locateRunfiles (mainWorkspace </> extraDarFilename)
          BS.readFile file
  
  uploadDummy :: LedgerService (Either String ())
  uploadDummy = do
      bytes <- liftIO getBytesDummy
      uploadDarFile bytes
  
  getBytesForUpload :: IO BS.ByteString
  getBytesForUpload = do
          let extraDarFilename = "language-support/hs/bindings/for-upload.dar"
          file <- locateRunfiles (mainWorkspace </> extraDarFilename)
          BS.readFile file
  
  -- Would be nice if the underlying service returned the pid on successful upload.
  uploadDarFileGetPid :: BS.ByteString -> LedgerService (Either String PackageId)
  uploadDarFileGetPid bytes = do
      before <- listPackages
      uploadDarFile bytes >>= \case -- call the actual service
          Left m -> return $ Left m
          Right () -> do
              after <- listPackages
              [newPid] <- return (after \\ before) -- see what new pid appears
              return $ Right newPid
  
  tGetParticipantId :: SandboxTest
  tGetParticipantId withSandbox = testCase "tGetParticipantId" $ run withSandbox $ \_darMetadata _testId -> do
      id <- getParticipantId
      liftIO $ assertEqual "participant" "my-ledger-id" $ dropHashSuffix $ unParticipantId id
  
  tAllocateParty :: SandboxTest
  tAllocateParty withSandbox = testCase "tAllocateParty" $ run withSandbox $ \_darMetadata (TestId testId) -> do
      let party = Party (TL.pack $ "me" <> show testId)
      before <- map dropPartyDetailHash <$> listKnownParties
      let request = AllocatePartyRequest { partyIdHint = unParty party }
      deats <- dropPartyDetailHash <$> allocateParty request
      let expected = PartyDetails { party, isLocal = True }
      liftIO $ assertEqual "deats" expected deats
      after <- map dropPartyDetailHash <$> listKnownParties
      liftIO $ assertEqual "new parties"
          (Set.fromList after Set.\\ Set.fromList before)
          (Set.singleton expected)
  
  ----------------------------------------------------------------------
  -- misc ledger ops/commands
  
  newtype TestId = TestId Int
    deriving Show
  
  newtype Secret = Secret { getSecret :: String }
  
  nextTestId :: TestId -> TestId
  nextTestId (TestId i) = TestId (i + 1)
  
  ----------------------------------------------------------------------
  -- runWithSandbox
  
  runWithSandbox :: forall a. Port -> Maybe Secret -> LedgerService a -> IO a
  runWithSandbox port mbSecret ls = runLedgerService ls' timeout (configOfPort port)
      where timeout = 60 :: TimeoutSeconds
            ls' :: LedgerService a
            ls' = case mbSecret of
              Nothing -> ls
              Just secret -> do
                let tok = Ledger.Token ("Bearer " <> makeSignedJwt' secret)
                setToken tok ls
  
  makeSignedJwt' :: Secret -> String
  makeSignedJwt' secret =
      makeSignedAdminJwt (getSecret secret)
  
  ----------------------------------------------------------------------
  -- misc expectation combinators
  
  assertTextContains :: String -> String -> IO ()
  assertTextContains text frag =
      unless (frag `isInfixOf` text) (assertFailure msg)
      where msg = "expected frag: " ++ frag ++ "\n contained in: " ++ text
  
  darPath :: FilePath
  darPath = mainWorkspace </> "language-support/hs/bindings/for-tests.dar"
  
  testGroupWithSandbox :: FilePath -> Maybe Secret -> TestName -> [WithSandbox -> TestTree] -> TestTree
  testGroupWithSandbox testDar mbSecret name tests =
      withCantonSandbox defaultSandboxConf 
          { dars = [ testDar ]
          , timeMode = Static
          , mbLedgerId = Just "my-ledger-id" 
          -- TODO(https://github.com/digital-asset/daml/issues/18457): split the
          -- tests into two sets: those that use contract keys and those that 
          -- don't. Revert to to non-dev for those that don't.
          , devVersionSupport = True
          } $ \getSandboxPort ->
      withResource (readDarMetadata testDar) (const $ pure ()) $ \getDarMetadata ->
      withResource (newIORef $ TestId 0) (const $ pure ()) $ \getTestCounter ->
      let run :: WithSandbox
          run f = do
              port <- getSandboxPort
              darMetadata <- getDarMetadata
              testCounter <- getTestCounter
              testId <- atomicModifyIORef testCounter (\x -> (nextTestId x, x))
              f (Port port) mbSecret darMetadata testId
      in testGroup name $ map (\f -> f run) tests
  
  readDarMetadata :: FilePath -> IO DarMetadata
  readDarMetadata dar = do
      archive <- Zip.toArchive <$> BSL.readFile dar
      Dalfs { mainDalf } <- either fail pure $ readDalfs archive
      manifest <- either fail pure $ readDalfManifest archive
      LF.PackageId pId <- either (fail . show) pure $ decodeArchivePackageId (BSL.toStrict mainDalf)
      pure $ DarMetadata (PackageId $ TL.fromStrict pId) manifest
  
  data DarMetadata = DarMetadata
    { mainPackageId :: PackageId
    , manifest :: DalfManifest
    }
  
  type WithSandbox = (Port -> Maybe Secret -> DarMetadata -> TestId -> IO ()) -> IO ()
  