StorageCheck.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# LANGUAGE OverloadedLists #-}

module TestSuite.Cleveland.StorageCheck
  ( test_GetStorage
  , test_GetFullStorage
  , test_GetFullStorageConditional
  , test_GetSomeStorage
  , test_AnnotationsArePreserved
  ) where

import Control.Lens (from, (^?!))
import Fmt (Buildable(..), GenericBuildable(..))
import System.FilePath ((</>))
import Test.Tasty (TestTree)

import Lorentz hiding (comment, contract)
import Morley.Michelson.Typed (isoValue)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.AnnotatedValue

import Test.Cleveland
import Test.Cleveland.Lorentz (ToContractAddress, embedContract)
import TestSuite.Util (BigMapInStorage(..), idContract, saveInStorageContract)
import TestSuite.Util.Contracts (contractsDir)

data Storage = Storage
  { _stField1 :: Natural
  , _stField2 :: BigMap Natural MText
  }
  deriving stock (Generic, Show, Eq)
  deriving anyclass (IsoValue, HasAnnotation)
  deriving Buildable via GenericBuildable Storage

deriveRPC "Storage"

test_GetStorage :: TestTree
test_GetStorage =
  testScenario "getStorage returns the contract's storage" $ scenario do
    addr <- originate
      "save parameter in storage"
      (1 :: Natural)
      saveInStorageContract

    comment "checking initial storage"
    getStorage addr @@== 1

    transfer addr [tz|100u|] $ calling def 2

    comment "storage is updated after transfer"
    getStorage addr @@== 2

test_GetFullStorage :: TestTree
test_GetFullStorage =
  testScenarioOnEmulator "getFullStorage returns storage with big_map's contents" $ scenarioEmulated do
    let initialStorage =
          Storage
            { _stField1 = 23
            , _stField2 =
                [ (1, "a")
                , (2, "b")
                ]
            }
    addr <- originate "test" initialStorage $ idContract @() @Storage
    getFullStorage addr @@== initialStorage

test_GetFullStorageConditional :: TestTree
test_GetFullStorageConditional =
  testScenario "getStorage/getFullStorage can work conditionally" $ scenario do
    let initialStorage =
          Storage
            { _stField1 = 23
            , _stField2 =
                [ (1, "a")
                , (2, "b")
                ]
            }
    addr <- originate "test" initialStorage $ idContract @() @Storage
    ifEmulation
      (getFullStorage addr @@== initialStorage)
      (_stField1RPC <$> getStorage addr @@== 23)

test_GetSomeStorage :: TestTree
test_GetSomeStorage = testScenario "getSomeStorage is consistent with getStorage" $ scenario do
  addr <- originate "test" (Storage 1 [(2, "a")]) $ idContract @() @Storage
  storage <- getStorage addr
  someStorage <- getSomeStorage addr

  someStorage ^? castTo @StorageRPC . value . from isoValue @== Just (toVal storage)

test_AnnotationsArePreserved :: [TestTree]
test_AnnotationsArePreserved =
  [ testScenario "importUntypedContract" $ scenario do
      contract <- importUntypedContract $ contractsDir </> "big_map_in_storage.tz"
      let initialStorage = (one (101, 102), 103) :: (BigMap Integer Integer, Natural)
      addr <- originate "contract" (T.untypeValue $ T.toVal initialStorage) contract
      checkAnnotationsArePreserved addr
  , testScenario "importContract" $ scenario do
      contract <- importContract @Integer @(BigMap Integer Integer, Natural) @() $ contractsDir </> "big_map_in_storage.tz"
      let initialStorage = (one (101, 102), 103)
      originate "contract" initialStorage contract >>= checkAnnotationsArePreserved
  , testScenario "importContract with a user-defined storage" $ scenario do
      contract <- importContract @Integer @BigMapInStorage @() $ contractsDir </> "big_map_in_storage.tz"
      let initialStorage = BigMapInStorage (one (101, 102)) 103
      addr <- originate "contract" initialStorage contract
      checkAnnotationsArePreserved addr
  , testScenario "embedContract" $ scenario do
      let contract = $$(embedContract @Integer @BigMapInStorage @() $ contractsDir </> "big_map_in_storage.tz")
      let initialStorage = BigMapInStorage (one (101, 102)) 103
      addr <- originate "contract" initialStorage contract
      checkAnnotationsArePreserved addr
  ]
  where
    checkAnnotationsArePreserved
      :: (HasCallStack, MonadCleveland caps m, ToContractAddress addr)
      => addr -> m ()
    checkAnnotationsArePreserved addr = do
      storage <- getSomeStorage addr
      storage ^? field "field2" . castTo @Natural . value @== Just 103
      let bigMapId = storage ^?! field "field1" . castTo @(BigMapId Integer Integer) . value
      getBigMapValue bigMapId 101 @@== 102