{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Allegra.ImpTest (
  impAllegraSatisfyNativeScript,
  module Test.Cardano.Ledger.Shelley.ImpTest,
) where

import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN)
import Cardano.Crypto.Hash.Blake2b (Blake2b_224)
import Cardano.Crypto.Hash.Class (Hash)
import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Allegra.Core
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  evalTimelock,
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Crypto (Crypto (..))
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Control.Monad.State.Strict (get)
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Set as Set
import Lens.Micro ((^.))
import Test.Cardano.Ledger.Allegra.TreeDiff ()
import Test.Cardano.Ledger.Core.KeyPair (KeyPair)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
  ) =>
  ShelleyEraImp (AllegraEra c)
  where
  impSatisfyNativeScript :: Set (KeyHash 'Witness (EraCrypto (AllegraEra c)))
-> TxBody (AllegraEra c)
-> NativeScript (AllegraEra c)
-> ImpTestM
     (AllegraEra c)
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto (AllegraEra c)))
           (KeyPair 'Witness (EraCrypto (AllegraEra c)))))
impSatisfyNativeScript = forall era.
(AllegraEraScript era, AllegraEraTxBody era) =>
Set (KeyHash 'Witness (EraCrypto era))
-> TxBody era
-> NativeScript era
-> ImpTestM
     era
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto era))
           (KeyPair 'Witness (EraCrypto era))))
impAllegraSatisfyNativeScript

  fixupTx :: HasCallStack =>
Tx (AllegraEra c) -> ImpTestM (AllegraEra c) (Tx (AllegraEra c))
fixupTx = forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
shelleyFixupTx

impAllegraSatisfyNativeScript ::
  ( AllegraEraScript era
  , AllegraEraTxBody era
  ) =>
  Set.Set (KeyHash 'Witness (EraCrypto era)) ->
  TxBody era ->
  NativeScript era ->
  ImpTestM era (Maybe (Map.Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))
impAllegraSatisfyNativeScript :: forall era.
(AllegraEraScript era, AllegraEraTxBody era) =>
Set (KeyHash 'Witness (EraCrypto era))
-> TxBody era
-> NativeScript era
-> ImpTestM
     era
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto era))
           (KeyPair 'Witness (EraCrypto era))))
impAllegraSatisfyNativeScript Set (KeyHash 'Witness (EraCrypto era))
providedVKeyHashes TxBody era
txBody NativeScript era
script = do
  ImpTestState era
impState <- forall s (m :: * -> *). MonadState s m => m s
get
  let
    keyPairs :: Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
keyPairs = ImpTestState era
impState forall s a. s -> Getting a s a -> a
^. forall era.
SimpleGetter
  (ImpTestState era)
  (Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era)))
impKeyPairsG
    vi :: ValidityInterval
vi = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
vldtTxBodyL
    satisfyMOf :: Int
-> StrictSeq (NativeScript era)
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyMOf Int
m StrictSeq (NativeScript era)
Empty
      | Int
m forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
      | Bool
otherwise = forall a. Maybe a
Nothing
    satisfyMOf Int
m (NativeScript era
x :<| StrictSeq (NativeScript era)
xs) =
      case NativeScript era
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyScript NativeScript era
x of
        Maybe
  (Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era)))
Nothing -> Int
-> StrictSeq (NativeScript era)
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyMOf Int
m StrictSeq (NativeScript era)
xs
        Just Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
kps -> do
          Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
kps' <- Int
-> StrictSeq (NativeScript era)
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyMOf (Int
m forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript era)
xs
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
kps forall a. Semigroup a => a -> a -> a
<> Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
kps'
    satisfyScript :: NativeScript era
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyScript = \case
      RequireSignature KeyHash 'Witness (EraCrypto era)
keyHash
        | KeyHash 'Witness (EraCrypto era)
keyHash forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness (EraCrypto era))
providedVKeyHashes -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise -> do
            KeyPair 'Witness (EraCrypto era)
keyPair <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Witness (EraCrypto era)
keyHash Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
keyPairs
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton KeyHash 'Witness (EraCrypto era)
keyHash KeyPair 'Witness (EraCrypto era)
keyPair
      RequireAllOf StrictSeq (NativeScript era)
ss -> Int
-> StrictSeq (NativeScript era)
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyMOf (forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript era)
ss) StrictSeq (NativeScript era)
ss
      RequireAnyOf StrictSeq (NativeScript era)
ss -> Int
-> StrictSeq (NativeScript era)
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyMOf Int
1 StrictSeq (NativeScript era)
ss
      RequireMOf Int
m StrictSeq (NativeScript era)
ss -> Int
-> StrictSeq (NativeScript era)
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyMOf Int
m StrictSeq (NativeScript era)
ss
      lock :: NativeScript era
lock@(RequireTimeStart SlotNo
_)
        | forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness (EraCrypto era))
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise -> forall a. Maybe a
Nothing
      lock :: NativeScript era
lock@(RequireTimeExpire SlotNo
_)
        | forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness (EraCrypto era))
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock forall a. Monoid a => a
mempty ValidityInterval
vi NativeScript era
lock -> forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty
        | Bool
otherwise -> forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NativeScript era
-> Maybe
     (Map
        (KeyHash 'Witness (EraCrypto era))
        (KeyPair 'Witness (EraCrypto era)))
satisfyScript NativeScript era
script