Entrypoints.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'.
module Test.Entrypoints
  ( test_default_EpName
  , test_EpAddress
  , test_ParseEpAddressRaw
  , test_ParamNotes
  , test_ParamEpError
  , test_contractHasEntrypoints
  ) where

import Prelude hiding (or)

import Data.Default (def)
import qualified Data.Map as Map
import Fmt (pretty)
import Test.HUnit (assertBool, (@?=))
import Test.Hspec (shouldSatisfy)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Hedgehog.Gen.Michelson.Typed (genEpAddress)
import Hedgehog.Gen.Tezos.Address (genAddress)
import Morley.Michelson.Parser (uparamTypeQ, utypeQ)
import Morley.Michelson.TypeCheck (HST(..))
import qualified Morley.Michelson.TypeCheck as TC
import Morley.Michelson.Typed
import Morley.Michelson.Untyped (noAnn, unsafeBuildEpName)
import qualified Morley.Michelson.Untyped as U
import Morley.Tezos.Address
import Test.Cleveland.Instances ()
import Test.Cleveland.Util (fromHex, runGen, unsafeFromHex)

import Test.Util.Hedgehog

test_default_EpName :: [TestTree]
test_default_EpName =
  [ testCase "`CONTRACT %default` is invalid" $
    flip shouldSatisfy isInvalidEpName $
    TC.typeCheckingWith def $
    TC.runTypeCheck TC.TypeCheckTest $
    TC.typeCheckList [U.PrimEx $ U.CONTRACT noAnn ("default" :: U.FieldAnn) U.tyunit]
      ((starNotes @'TAddress, Dict, noAnn) ::& SNil)
  , testCase "`SELF %default` is valid" $
    flip shouldSatisfy isRight $
    TC.typeCheckingWith def $
    TC.runTypeCheck (TC.TypeCheckContract unitParamType) $
    TC.typeCheckList [U.PrimEx $ U.SELF noAnn ("default" :: U.FieldAnn)] SNil
  ]
  where
    isInvalidEpName :: Either TC.TCError a -> Bool
    isInvalidEpName = \case
      Left (TC.TCFailedOnInstr _ _ _ _ (Just (TC.IllegalEntrypoint {}))) -> True
      _ -> False

    unitParamType :: TC.SomeParamType
    unitParamType =
      either (error . pretty) id $
      TC.mkSomeParamType (U.ParameterType U.tyunit noAnn)

test_EpAddress :: [TestTree]
test_EpAddress =
  [ testGroup "Parsing" $
    [ testCase "Simple entrypoint" $
        parseEpAddress (formatAddress addr <> "%ab")
          @?= Right (EpAddress addr (unsafeBuildEpName "ab"))

    , testCase "No entrypoint" $
        parseEpAddress (formatAddress addr)
          @?= Right (EpAddress addr DefEpName)

    , testCase "Weird entrypoint" $
        parseEpAddress (formatAddress addr <> "%a%b")
          @?= Right (EpAddress addr (unsafeBuildEpName "a%b"))
    ]

  , testGroup "parse . format = pure"
    [ roundtripTreeSTB genEpAddress formatEpAddress parseEpAddress ]
  ]
  where
    addr = runGen 20 123 genAddress

test_ParseEpAddressRaw :: [TestTree]
test_ParseEpAddressRaw = mconcat
  [ [ testCase ("Successfully encodes " <> toString b)
      (formatEpAddress (unsafeParseEpAddressRaw (unsafeFromHex b)) @?= a)
    | (a, b) <- sampleEpAddresses
    ]
  , [ testCase ("Fails to parse invalid address " <> toString a)
      ((fromHex a >>= rightToMaybe . parseEpAddressRaw) `shouldSatisfy` isNothing)
    | a <- invalidRawEpAddresses
    ]
  ]

test_ParamNotes :: [TestTree]
test_ParamNotes =
  [ testGroup "Duplications are handled" $
    [ testCase "One duplicated entrypoint" $
        mkParamNotes (or "a" "a" prim prim) noAnn
          @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| []))
    , testCase "Several duplicated entrypoint" $
        mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn
          @?= Left (ParamEpDuplicatedNames (unsafeBuildEpName "a" :| [unsafeBuildEpName "b"]))
    , testCase "Duplicated default entrypoint" $
        mkParamNotes (or "default" "default" prim prim) noAnn
          @?= Left (ParamEpDuplicatedNames (DefEpName :| []))
    ]

  , testGroup "All entrypoints callable check" $
    [ testCase "Non-callable entrypoint is detected in simple case" $
        mkParamNotes (or "default" "" prim (or "" "q" prim prim)) noAnn
          @?= Left (ParamEpUncallableArm [AcRight, AcLeft])
    , testCase "Non-callable entrypoint is detected in complex case" $
        mkParamNotes (or "a" "" prim (or "" "default" (or "b" "" prim prim) prim)) noAnn
          @?= Left (ParamEpUncallableArm [AcRight, AcLeft, AcRight])

    , testCase "Having all leaves named is enough for callability" $
        mkParamNotes (or "default" "" prim (or "q" "" prim (or "a" "b" prim prim))) noAnn
          & assertBool "All arms should've considered callable" . isRight
    , testCase "Having all leaves named is enough for callability" $
        mkParamNotes (or "default" "a" prim (or "" "" prim (or "" "" prim prim))) noAnn
          & assertBool "All arms should've considered callable" . isRight
    ]
  ]
  where
    or a1 a2 = NTOr noAnn a1 a2
    prim = NTKey noAnn

test_ParamEpError :: [TestTree]
test_ParamEpError =
  [ testGroup "Buildable instance"
    [ testCase "Duplicated entrypoints error" $
        pretty @_ @Text (ParamEpDuplicatedNames $ unsafeBuildEpName "a" :| [DefEpName])
        @?= "Duplicated entrypoint names: 'a', '<default>'"
    , testCase "Uncallable arms error" $
        pretty @_ @Text (ParamEpUncallableArm [AcLeft, AcRight])
        @?= "Due to presence of 'default' entrypoint, one of contract \"arms\" \
            \cannot be called: \"left - right\" (in top-to-bottom order)"
    ]
  ]

test_contractHasEntrypoints :: [TestTree]
test_contractHasEntrypoints =
  [ testCase "Simple parameter" $
      U.mkEntrypointsMap [uparamTypeQ| (int %a | nat %b) |]
        @?= Map.fromList
        [ (UnsafeEpName "a", [utypeQ| int |])
        , (UnsafeEpName "b", [utypeQ| nat |])
        ]

  , testCase "Root entrypoint is considered" $
      U.mkEntrypointsMap [uparamTypeQ| (int %a | nat %b) %root |]
        @?= Map.fromList
        [ (UnsafeEpName "root", [utypeQ| (int %a | nat %b) |])
        , (UnsafeEpName "a", [utypeQ| int |])
        , (UnsafeEpName "b", [utypeQ| nat |])
        ]
  ]

sampleEpAddresses :: [(Text, Text)]
sampleEpAddresses =
  [ ( "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo"     , "01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f"         )
  , ( "KT1QbdJ7M7uAQZwLpvzerUyk7LYkJWDL7eDh%foo%bar" , "01afab866e7f1e74f9bba388d66b246276ce50bf4700666f6f25626172" )
  , ( "KT1VY2LXzHN5DJ5QWNhQykmFt26dhmsbyFwq"         , "01e5d5b97aa45ee3df7218aebc5bac27b166db46a200"               )
  -- TODO [https://gitlab.com/tezos/tezos/-/issues/851] and [https://gitlab.com/morley-framework/morley/-/issues/275]:
  -- in Tezos almost every string is allowed to be present after '%' in address (including special
  -- chars such as '{', '$', etc.) , but actual validation happens from entrypoint call, so we need
  -- to investigate on it.
  --  , ( "KT1VY2LXzHN5DJ5QWNhQykmFt26dhmsbyFwq%%%%"     , "01e5d5b97aa45ee3df7218aebc5bac27b166db46a200252525"         )
  , ( "KT1Nd2WPFZqPhzzrGJiS3e21jKjmdXxWQunk"         , "0199ff10cb8e04fda6b4b79e7e3eaf6980f4298d9000"               )
  , ( "KT1Nd2WPFZqPhzzrGJiS3e21jKjmdXxWQunk%9%%"     , "0199ff10cb8e04fda6b4b79e7e3eaf6980f4298d9000392525"         )
  ]

invalidRawEpAddresses :: [Text]
invalidRawEpAddresses =
  [ ""
  , "qehrwu"
  , "050a0000001"
  , "0199ff10cb8e04fda6b4b79e7e3eaf6980f4298d9000sd"
  ]