Helpers.hs

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

-- | Tests on tickets helpers from "Lorentz.Tickets" module.
module Test.Lorentz.Tickets.Helpers
  ( test_ActionAuth
  , test_TokenAllowance
  ) where

import Test.Tasty (TestTree, testGroup)

import Lorentz qualified as L
import Lorentz.Value
import Morley.Util.Named
import Test.Cleveland
import Test.Cleveland.Lorentz.Ticketer

import Test.Lorentz.Tickets.Contracts

test_ActionAuth :: [TestTree]
test_ActionAuth =
  let prepare
        :: MonadCleveland caps m
        => m ( ContractHandle (Ticket Integer) Bool ()
             , ContractHandle (L.View_ ((), (Natural, Integer)) (Ticket Integer)) () ()
             )
      prepare = do
        ticketer <- originateSimple "ticketer" () (ticketerContract' L.drop)
        launcher <- originateSimple "launcher" False (atomicMissileLaunchContract $ toTAddress ticketer)
        return (launcher, ticketer)
  in
  [ testScenario "Normal scenario works" $ scenario do
      (launcher, ticketer) <- prepare

      callViaTicketer ticketer 1 12345 launcher ()

  , testScenario "Bad ticket data causes failure" $ scenario do
      (launcher, ticketer) <- prepare

      callViaTicketer ticketer 1 123 launcher ()
        & expectFailedWith [mt|Bad code|]

  , testScenario "Bad tokens number causes failure" $ scenario do
      (launcher, ticketer) <- prepare

      callViaTicketer ticketer 0 12345 launcher ()
        & expectCustomErrorNoArg #nOT_SINGLE_TICKET_TOKEN

      callViaTicketer ticketer 3 12345 launcher ()
        & expectCustomErrorNoArg #nOT_SINGLE_TICKET_TOKEN

  , testScenario "Wrong ticketer causes failure" $ scenario do
      (launcher, _ticketer) <- prepare
      fakeTicketer <- originateSimple "fake-ticketer" () (ticketerContract' L.drop)

      callViaTicketer fakeTicketer 3 12345 launcher ()
        & expectCustomErrorNoArg #wRONG_TICKETER

  ]

test_TokenAllowance :: [TestTree]
test_TokenAllowance =
  let prepare
        :: MonadCleveland caps m
        => m ( ContractHandle PermitTokensParameter PermitTokensStorage ()
             , ContractHandle (L.View_ ((), (Natural, ())) (Ticket ())) () ()
             )
      prepare = do
        ticketer <- originateSimple "ticketer" () (ticketerContract' L.drop)
        let initStorage = PermitTokensStorage Nothing (toAddress ticketer)
        token <- originateSimple "token" initStorage permitTokensContract
        return (token, ticketer)
  in
  [ testGroup "Allowances"

    [ testScenario "Permitting tokens works" $ scenario do
        -- TODO: Would be actually nice to try hedgehog here once it is available for cleveland

        (token, ticketer) <- prepare

        callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) ()
        callViaTicketer ticketer 3 () (callingAddress token (Call @"PermitAllow")) ()

        call token (Call @"PermitGet") (L.mkVoid ())
          & expectError (L.VoidResult @Natural 8)

    , testScenario "Permitting 0 tokens works" $ scenario do
        (token, ticketer) <- prepare

        callViaTicketer ticketer 0 () (callingAddress token (Call @"PermitAllow")) ()

        call token (Call @"PermitGet") (L.mkVoid ())
          & expectError (L.VoidResult @Natural 0)

    , testScenario "Permitting tokens from wrong ticketer fails" $ scenario do
        (token, _ticketer) <- prepare
        fakeTicketer <- originateSimple "fake-ticketer" () (ticketerContract' L.drop)

        callViaTicketer fakeTicketer 1 () (callingAddress token (Call @"PermitAllow")) ()
          & expectCustomErrorNoArg #wRONG_TICKETER

    ]

  , testGroup "Spendings"

    [ testScenario "Spending tokens works" $ scenario do
        (token, ticketer) <- prepare

        callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) ()
        call token (Call @"PermitSpend") 3

        call token (Call @"PermitGet") (L.mkVoid ())
          & expectError (L.VoidResult @Natural 2)

    , testScenario "Spending too many tokens fails" $ scenario do
        (token, ticketer) <- prepare

        callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) ()
        call token (Call @"PermitSpend") 8
          & expectCustomError #insufficient_tokens_permitted_by_ticket
              (#permitted :! 5, #spent :! 8)

    , testScenario "Can repeatedly exhaust all allowances" $ scenario do
        (token, ticketer) <- prepare

        callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) ()
        call token (Call @"PermitSpend") 3
        call token (Call @"PermitSpend") 2
        callViaTicketer ticketer 0 () (callingAddress token (Call @"PermitAllow")) ()
        call token (Call @"PermitSpend") 0
        callViaTicketer ticketer 1 () (callingAddress token (Call @"PermitAllow")) ()
        call token (Call @"PermitSpend") 1
        callViaTicketer ticketer 3 () (callingAddress token (Call @"PermitAllow")) ()

        call token (Call @"PermitGet") (L.mkVoid ())
          & expectError (L.VoidResult @Natural 3)

    ]

    , testGroup "Admin change"

    [ testScenario "Admin change takes effect" $ scenario do
        (token, ticketer) <- prepare
        ticketer2 <- originateSimple "ticketer2" () (ticketerContract' L.drop)

        callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) ()
        call token (Call @"PermitSetAdmin") (toAddress ticketer2)

        call token (Call @"PermitGet") (L.mkVoid ())
          & expectError (L.VoidResult @Natural 0)

        callViaTicketer ticketer 5 () (callingAddress token (Call @"PermitAllow")) ()
          & expectCustomErrorNoArg #wRONG_TICKETER

        callViaTicketer ticketer2 5 () (callingAddress token (Call @"PermitAllow")) ()
        call token (Call @"PermitGet") (L.mkVoid ())
          & expectError (L.VoidResult @Natural 5)

    ]
  ]

{- We do not cover 'allowancesContract' with tests since there is nothing
special there comparing to 'permitTokensContract', the contract exists only to
demonstrate implementation for a contract that stores an entire map of tickets.
-}
_untestedContract1 :: [TestTree]
_untestedContract1 = const [] allowancesContract

{-# ANN _untestedContract1 ("HLint: ignore Evaluate" :: Text) #-}