KeyRevealing.hs

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

module Test.KeyRevealing
  ( test_keyRevealing
  ) where

import Test.HUnit (Assertion, assertFailure)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Lorentz qualified as L
import Morley.Client
import Morley.Michelson.Runtime.GState (genesisAddress1)
import Morley.Michelson.Typed
import Morley.Tezos.Address.Alias (AddressOrAlias(..))
import Morley.Tezos.Core (tz)
import Test.Util
import TestM

fakeState :: FakeState
fakeState = defaultFakeState
  { fsImplicits = one ( genesisAddress1
                      , dumbImplicitState
                          { asAccountData = ImplicitData $ Just dumbManagerKey }
                      )
  }

test_keyRevealing :: TestTree
test_keyRevealing = testGroup "Fake test key revealing"
  [ testCase "Manager key for new address is revealed only once for transfer" $ handleSuccess $
    runFakeTest chainOperationHandlers fakeState $ do
      senderAddress <- genKey "sender"
      dummyTransfer genesisAddress1 senderAddress
      mbManagerKey <- getManagerKey senderAddress

      when (isJust mbManagerKey) $
        fail "Manager key was expected not to be revealed, but it's revealed."

      dummyTransfer senderAddress genesisAddress1
      mbManagerKey' <- getManagerKey senderAddress

      when (isNothing mbManagerKey') $
        fail "Manager key was expected to be revealed, but it's not revealed."

      local
        (const noRevealHandlers)
        (dummyTransfer senderAddress genesisAddress1)

  , testCase "Manager key for new address is revealed only once for origination" $ handleSuccess $
    runFakeTest chainOperationHandlers fakeState $ do
      originatorAddress <- genKey "originator"
      dummyTransfer genesisAddress1 originatorAddress

      mbManagerKey <- getManagerKey originatorAddress

      when (isJust mbManagerKey) $
        fail "Manager key was expected not to be revealed, but it's revealed."

      originateDummy originatorAddress

      mbManagerKey' <- getManagerKey originatorAddress
      when (isNothing mbManagerKey') $
        fail "Manager key was expected to be revealed, but it's not revealed."

      local
        (const noRevealHandlers)
        (originateDummy originatorAddress)
  ]
  where
    dummyTransfer from to =
      void $ transfer from to [tz|10u|] DefEpName (toVal ()) Nothing

    originateDummy addr =
      lOriginateContract OverwriteDuplicateAlias "dummy" (AddressResolved addr) [tz|10u|]
      dumbLorentzContract () Nothing Nothing

-- | Handlers which don't allow to reveal key.
noRevealHandlers :: (Monad m) => TestHandlers m
noRevealHandlers = TestHandlers $ chainOperationHandlers
  { hRevealKey = \_ _ -> throwM $ UnexpectedClientCall "revealKey" }

dumbLorentzContract :: L.Contract Integer () ()
dumbLorentzContract = L.defaultContract $
  L.drop L.# L.unit L.# L.nil L.# L.pair

handleSuccess :: Either SomeException a -> Assertion
handleSuccess (Left err) = assertFailure $ displayException err
handleSuccess (Right _)  = pass