Timelock.hs

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

-- | Tests on basic timelock puzzle, i.e. 'openChest' functionality
module Test.Lorentz.Timelock
  ( test_Interpreter
  ) where

import Lorentz
import Prelude (Num, fst, id, snd, (/=), (<$>))

import Hedgehog (forAll, property, withTests, (===))
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)

import Hedgehog.Gen.Tezos.Crypto.Timelock
import Morley.Tezos.Crypto.Timelock hiding (openChest)

natTime :: Num a => a
natTime = 1000

time :: TLTime
time = UnsafeTLTime natTime

bogusOpening, bogusCipher :: ByteString
bogusOpening = "\1BogusOpening"
bogusCipher = "\0BogusCipher"

-- | This is a Lorentz equivalent of @open_chest.tz@
openChestTLambda :: Lambda (ChestKey, ChestT ByteString) ByteString
openChestTLambda =
    unpair
  # dipN @2 (push @Natural natTime)
  # openChestT
  # caseT
    ( #cChestContentT /-> nop
    , #cChestOpenFailedT /-> if_ (push bogusOpening) (push bogusCipher)
    )

-- | This is a Lorentz equivalent of @open_chest.tz@
openChestLambda :: Lambda (ChestKey, Chest) ByteString
openChestLambda =
    unpair
  # dipN @2 (push @Natural natTime)
  # openChest
  # caseT
    ( #cChestContent /-> nop
    , #cChestOpenFailed /-> if_ (push bogusOpening) (push bogusCipher)
    )

test_Interpreter :: [TestTree]
test_Interpreter =
  [ treeImpl "Chest" openChestLambda id
  , treeImpl "ChestT" openChestTLambda ChestT
  ]

treeImpl :: IsoValue a => TestName -> (Lambda (ChestKey, a) ByteString) -> (Chest -> a) -> TestTree
treeImpl nm tstf conv = testGroup nm
  [ testProperty "Chest value decodes" $ property do
      ((chest, key), (payload, _)) <- forAll $ genChestAndKeyWithParams (Just time)
      (tstf -$ (key, conv chest)) === payload
  , testProperty "Chest value doesn't decode with a wrong key" $ withTests 50 $ property do
      (chest, key) <- fst <$> forAll (Gen.small $ genChestAndKeyWithParams (Just time))
      (chest', key') <- fst <$>
        forAll (Gen.filter ((/= key) . snd . fst) $ Gen.small $ genChestAndKeyWithParams (Just time))
      (tstf -$ (key', conv chest)) === bogusOpening
      (tstf -$ (key, conv chest')) === bogusOpening
  , testProperty "Chest value doesn't decode with a bogus ciphertext" $ property do
      (Chest{..}, key) <- fst <$> forAll (genChestAndKeyWithParams (Just time))
      let Ciphertext{..} = chestCiphertext
      payload' <- forAll . Gen.filter (/= ctPayload) $ Gen.bytes (Range.constant 100 500)
      (tstf -$ (key, conv Chest{chestCiphertext=Ciphertext{ctPayload = payload', ..}, ..}))
        === bogusCipher
  , testProperty "Chest value doesn't decode with a wrong time" $ property do
      (chest, key) <- fst <$>
        forAll (Gen.filter ((/= time) . snd . snd) $ genChestAndKeyWithParams Nothing)
      (tstf -$ (key, conv chest)) === bogusOpening
  ]