{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Test.Cardano.Ledger.Shelley.Generator.ScriptClass (
  ScriptClass (..),
  Quantifier (..),
  exponential,
  anyOf,
  allOf,
  mOf,
  keyPairs,
  mkPayScriptHashMap,
  mkStakeScriptHashMap,
  mkScriptsFromKeyPair,
  mkKeyPairs,
  mkScripts,
  mkScriptCombinations,
  combinedScripts,
  baseScripts,
  scriptKeyCombinations,
  scriptKeyCombination,
)
where

import Cardano.Ledger.Core
import Cardano.Ledger.Keys (asWitness)
import Data.List (permutations)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Proxy
import Data.Tuple (swap)
import Data.Word (Word64)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), KeyPairs, vKey)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Utils (RawSeed (..), mkKeyPair)
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck as QC

{------------------------------------------------------------------------------
  ScriptClass defines the operations that enable an Era's scripts to
  be adapated to property tests. This is a key component of the EraGen class.
------------------------------------------------------------------------------}

class EraScript era => ScriptClass era where
  basescript :: Proxy era -> KeyHash 'Witness -> Script era
  isKey :: Proxy era -> Script era -> Maybe (KeyHash 'Witness)
  isOnePhase :: Proxy era -> Script era -> Bool
  isOnePhase Proxy era
_proxy Script era
_ = Bool
True -- Many Eras have only OnePhase Scripts.
  quantify :: Proxy era -> Script era -> Quantifier (Script era)
  unQuantify :: Proxy era -> Quantifier (Script era) -> Script era

{------------------------------------------------------------------------------
  Abstracts the quantifier structure of (Script era)
  used in the 'quantify' and 'unQuantify' methods of ScriptClass.
 -----------------------------------------------------------------------------}

data Quantifier t = AllOf [t] | AnyOf [t] | MOf Int [t] | Leaf t
  deriving (forall a b. a -> Quantifier b -> Quantifier a
forall a b. (a -> b) -> Quantifier a -> Quantifier b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Quantifier b -> Quantifier a
$c<$ :: forall a b. a -> Quantifier b -> Quantifier a
fmap :: forall a b. (a -> b) -> Quantifier a -> Quantifier b
$cfmap :: forall a b. (a -> b) -> Quantifier a -> Quantifier b
Functor)

anyOf :: forall era. ScriptClass era => Proxy era -> [Script era] -> Script era
anyOf :: forall era.
ScriptClass era =>
Proxy era -> [Script era] -> Script era
anyOf Proxy era
prox [Script era]
xs = forall era.
ScriptClass era =>
Proxy era -> Quantifier (Script era) -> Script era
unQuantify Proxy era
prox forall a b. (a -> b) -> a -> b
$ forall t. [t] -> Quantifier t
AnyOf [Script era]
xs

allOf :: forall era. ScriptClass era => Proxy era -> [Script era] -> Script era
allOf :: forall era.
ScriptClass era =>
Proxy era -> [Script era] -> Script era
allOf Proxy era
prox [Script era]
xs = forall era.
ScriptClass era =>
Proxy era -> Quantifier (Script era) -> Script era
unQuantify Proxy era
prox forall a b. (a -> b) -> a -> b
$ forall t. [t] -> Quantifier t
AllOf [Script era]
xs

mOf :: forall era. ScriptClass era => Proxy era -> Int -> [Script era] -> Script era
mOf :: forall era.
ScriptClass era =>
Proxy era -> Int -> [Script era] -> Script era
mOf Proxy era
prox Int
m [Script era]
xs = forall era.
ScriptClass era =>
Proxy era -> Quantifier (Script era) -> Script era
unQuantify Proxy era
prox forall a b. (a -> b) -> a -> b
$ forall t. Int -> [t] -> Quantifier t
MOf Int
m [Script era]
xs

{------------------------------------------------------------------------------
  Compute lists of keyHashes
------------------------------------------------------------------------------}

-- | return the first sublist that meets the predicate p.
getFirst :: ([a] -> Bool) -> [[a]] -> [a]
getFirst :: forall a. ([a] -> Bool) -> [[a]] -> [a]
getFirst [a] -> Bool
_p [] = []
getFirst [a] -> Bool
p ([a]
xs : [[a]]
xss) = if [a] -> Bool
p [a]
xs then [a]
xs else forall a. ([a] -> Bool) -> [[a]] -> [a]
getFirst [a] -> Bool
p [[a]]
xss

-- | Produce a valid list of key hashes that appear in a Script.
-- Note: in the case of AnyOf, we just take the first script in the expression.
-- This only works if we generate AnyOf scripts such that all script options
-- are valid scripts (that is, valid in the context of a transaction, at generation time
-- and execution/spend time).
scriptKeyCombination ::
  forall era.
  ScriptClass era =>
  Proxy era ->
  Script era ->
  [KeyHash 'Witness]
scriptKeyCombination :: forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness]
scriptKeyCombination Proxy era
prox Script era
script = case forall era.
ScriptClass era =>
Proxy era -> Script era -> Quantifier (Script era)
quantify Proxy era
prox Script era
script of
  AllOf [Script era]
xs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness]
scriptKeyCombination Proxy era
prox) [Script era]
xs
  AnyOf [Script era]
xs -> forall a. ([a] -> Bool) -> [[a]] -> [a]
getFirst (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (forall a b. (a -> b) -> [a] -> [b]
map (forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness]
scriptKeyCombination Proxy era
prox) [Script era]
xs)
  MOf Int
m [Script era]
xs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness]
scriptKeyCombination Proxy era
prox) (forall a. Int -> [a] -> [a]
take Int
m [Script era]
xs)
  Leaf Script era
t -> case forall era.
ScriptClass era =>
Proxy era -> Script era -> Maybe (KeyHash 'Witness)
isKey Proxy era
prox Script era
t of
    Just KeyHash 'Witness
hk -> [KeyHash 'Witness
hk]
    Maybe (KeyHash 'Witness)
Nothing -> []

-- | Return all valid lists of KeyHashes that appear in a Script
--   used in testing.
scriptKeyCombinations ::
  forall era.
  ScriptClass era =>
  Proxy era ->
  Script era ->
  [[KeyHash 'Witness]]
scriptKeyCombinations :: forall era.
ScriptClass era =>
Proxy era -> Script era -> [[KeyHash 'Witness]]
scriptKeyCombinations Proxy era
prox Script era
script = case forall era.
ScriptClass era =>
Proxy era -> Script era -> Quantifier (Script era)
quantify Proxy era
prox Script era
script of
  AllOf [Script era]
xs -> [forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall era.
ScriptClass era =>
Proxy era -> Script era -> [[KeyHash 'Witness]]
scriptKeyCombinations Proxy era
prox) [Script era]
xs]
  AnyOf [Script era]
xs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall era.
ScriptClass era =>
Proxy era -> Script era -> [[KeyHash 'Witness]]
scriptKeyCombinations Proxy era
prox) [Script era]
xs
  MOf Int
m [Script era]
xs ->
    let perms :: [[Script era]]
perms = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
take Int
m) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
permutations [Script era]
xs
     in forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall era.
ScriptClass era =>
Proxy era -> Script era -> [[KeyHash 'Witness]]
scriptKeyCombinations Proxy era
prox)) [[Script era]]
perms
  Leaf Script era
t -> case forall era.
ScriptClass era =>
Proxy era -> Script era -> Maybe (KeyHash 'Witness)
isKey Proxy era
prox Script era
t of
    Just KeyHash 'Witness
hk -> [[KeyHash 'Witness
hk]]
    Maybe (KeyHash 'Witness)
Nothing -> [[]]

-- | Make a simple (non-combined, ie NO quantifer like All, Any, MofN, etc.) script.
--   'basescript' is a method of ScriptClass, and is different for every Era.
mkScriptFromKey :: forall era. ScriptClass era => KeyPair 'Witness -> Script era
mkScriptFromKey :: forall era. ScriptClass era => KeyPair 'Witness -> Script era
mkScriptFromKey = forall era.
ScriptClass era =>
Proxy era -> KeyHash 'Witness -> Script era
basescript (forall {k} (t :: k). Proxy t
Proxy :: Proxy era) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey

mkScriptsFromKeyPair ::
  forall era.
  ScriptClass era =>
  (KeyPair 'Payment, KeyPair 'Staking) ->
  (Script era, Script era)
mkScriptsFromKeyPair :: forall era.
ScriptClass era =>
(KeyPair 'Payment, KeyPair 'Staking) -> (Script era, Script era)
mkScriptsFromKeyPair (KeyPair 'Payment
k0, KeyPair 'Staking
k1) =
  (forall era. ScriptClass era => KeyPair 'Witness -> Script era
mkScriptFromKey @era forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
k0, forall era. ScriptClass era => KeyPair 'Witness -> Script era
mkScriptFromKey @era forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Staking
k1)

-- | make Scripts based on the given key pairs
mkScripts ::
  forall era.
  ScriptClass era =>
  KeyPairs ->
  [(Script era, Script era)]
mkScripts :: forall era.
ScriptClass era =>
KeyPairs -> [(Script era, Script era)]
mkScripts = forall a b. (a -> b) -> [a] -> [b]
map (forall era.
ScriptClass era =>
(KeyPair 'Payment, KeyPair 'Staking) -> (Script era, Script era)
mkScriptsFromKeyPair @era)

mkPayScriptHashMap ::
  forall era.
  ScriptClass era =>
  [(Script era, Script era)] ->
  Map.Map ScriptHash (Script era, Script era)
mkPayScriptHashMap :: forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map ScriptHash (Script era, Script era)
mkPayScriptHashMap [(Script era, Script era)]
scripts =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((Script era, Script era) -> (ScriptHash, (Script era, Script era))
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
scripts)
  where
    f :: (Script era, Script era) -> (ScriptHash, (Script era, Script era))
f script :: (Script era, Script era)
script@(Script era
pay, Script era
_ssStake) = (forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
pay, (Script era, Script era)
script)

-- | Generate a mapping from stake script hash to script pair.
mkStakeScriptHashMap ::
  forall era.
  ScriptClass era =>
  [(Script era, Script era)] ->
  Map.Map ScriptHash (Script era, Script era)
mkStakeScriptHashMap :: forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map ScriptHash (Script era, Script era)
mkStakeScriptHashMap [(Script era, Script era)]
scripts =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((Script era, Script era) -> (ScriptHash, (Script era, Script era))
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
scripts)
  where
    f :: (Script era, Script era) -> (ScriptHash, (Script era, Script era))
f script :: (Script era, Script era)
script@(Script era
_pay, Script era
stake) = (forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
stake, (Script era, Script era)
script)

-- | Combine a list of script pairs into hierarchically structured multi-sig
-- scripts, list must have at least length 3. Be careful not to call with too
-- many pairs in order not to create too many of the possible combinations.
mkScriptCombinations ::
  forall era.
  ScriptClass era =>
  [(Script era, Script era)] ->
  [(Script era, Script era)]
mkScriptCombinations :: forall era.
ScriptClass era =>
[(Script era, Script era)] -> [(Script era, Script era)]
mkScriptCombinations [(Script era, Script era)]
msigs =
  if forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Script era, Script era)]
msigs forall a. Ord a => a -> a -> Bool
< Int
3
    then forall a. HasCallStack => [Char] -> a
error [Char]
"length of input msigs must be at least 3"
    else
      ( forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall a. [a] -> [a] -> [a]
(++) [] forall a b. (a -> b) -> a -> b
$
          do
            (Script era
k1, Script era
k2) <- [(Script era, Script era)]
msigs
            (Script era
k3, Script era
k4) <- [(Script era, Script era)]
msigs forall a. Eq a => [a] -> [a] -> [a]
List.\\ [(Script era
k1, Script era
k2)]
            (Script era
k5, Script era
k6) <- [(Script era, Script era)]
msigs forall a. Eq a => [a] -> [a] -> [a]
List.\\ [(Script era
k1, Script era
k2), (Script era
k3, Script era
k4)]

            forall (f :: * -> *) a. Applicative f => a -> f a
pure
              [ (Script era
pay, Script era
stake)
              | Script era
pay <-
                  [ forall era.
ScriptClass era =>
Proxy era -> [Script era] -> Script era
anyOf (forall {k} (t :: k). Proxy t
Proxy @era) [Script era
k1, Script era
k3, Script era
k5]
                  , forall era.
ScriptClass era =>
Proxy era -> [Script era] -> Script era
allOf (forall {k} (t :: k). Proxy t
Proxy @era) [Script era
k1, Script era
k3, Script era
k5]
                  , forall era.
ScriptClass era =>
Proxy era -> Int -> [Script era] -> Script era
mOf (forall {k} (t :: k). Proxy t
Proxy @era) Int
1 [Script era
k1, Script era
k3, Script era
k5]
                  , forall era.
ScriptClass era =>
Proxy era -> Int -> [Script era] -> Script era
mOf (forall {k} (t :: k). Proxy t
Proxy @era) Int
2 [Script era
k1, Script era
k3, Script era
k5]
                  , forall era.
ScriptClass era =>
Proxy era -> Int -> [Script era] -> Script era
mOf (forall {k} (t :: k). Proxy t
Proxy @era) Int
3 [Script era
k1, Script era
k3, Script era
k5]
                  ]
              , Script era
stake <-
                  [ forall era.
ScriptClass era =>
Proxy era -> [Script era] -> Script era
anyOf (forall {k} (t :: k). Proxy t
Proxy @era) [Script era
k2, Script era
k4, Script era
k6]
                  , forall era.
ScriptClass era =>
Proxy era -> [Script era] -> Script era
allOf (forall {k} (t :: k). Proxy t
Proxy @era) [Script era
k2, Script era
k4, Script era
k6]
                  , forall era.
ScriptClass era =>
Proxy era -> Int -> [Script era] -> Script era
mOf (forall {k} (t :: k). Proxy t
Proxy @era) Int
1 [Script era
k2, Script era
k4, Script era
k6]
                  , forall era.
ScriptClass era =>
Proxy era -> Int -> [Script era] -> Script era
mOf (forall {k} (t :: k). Proxy t
Proxy @era) Int
2 [Script era
k2, Script era
k4, Script era
k6]
                  , forall era.
ScriptClass era =>
Proxy era -> Int -> [Script era] -> Script era
mOf (forall {k} (t :: k). Proxy t
Proxy @era) Int
3 [Script era
k2, Script era
k4, Script era
k6]
                  ]
              ]
      ) ::
        [(Script era, Script era)]

-- | Make list of script pairs (payment,staking). These are non-combined scripts
--   Ie NO quantifer like All, Any, MofN, etc.) scripts.
--   In post Shelley Eras, either Keylock or Require Start-Finish scripts.
baseScripts ::
  forall era.
  ScriptClass era =>
  Constants ->
  [(Script era, Script era)]
baseScripts :: forall era.
ScriptClass era =>
Constants -> [(Script era, Script era)]
baseScripts Constants
c = forall era.
ScriptClass era =>
KeyPairs -> [(Script era, Script era)]
mkScripts @era (Constants -> KeyPairs
keyPairs Constants
c)

-- | Make a list of script pairs (payment,staking). Each of these are combined scripts.
--   I.e.  All, Any, MofN, etc. These come from combining the the first N (numBaseScripts) baseScripts
--   When N==3, we get about 150 combined scripts.
combinedScripts ::
  forall era.
  ScriptClass era =>
  Constants ->
  [(Script era, Script era)]
combinedScripts :: forall era.
ScriptClass era =>
Constants -> [(Script era, Script era)]
combinedScripts c :: Constants
c@(Constants {Int
numBaseScripts :: Constants -> Int
numBaseScripts :: Int
numBaseScripts}) =
  forall era.
ScriptClass era =>
[(Script era, Script era)] -> [(Script era, Script era)]
mkScriptCombinations @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
numBaseScripts forall a b. (a -> b) -> a -> b
$ forall era.
ScriptClass era =>
Constants -> [(Script era, Script era)]
baseScripts @era Constants
c

-- | Constant list of KeyPairs intended to be used in the generators.
keyPairs :: Constants -> KeyPairs
keyPairs :: Constants -> KeyPairs
keyPairs Constants {Word64
numKeyPairs :: Constants -> Word64
numKeyPairs :: Word64
numKeyPairs} = forall (kr :: KeyRole) (kr' :: KeyRole).
Word64 -> (KeyPair kr, KeyPair kr')
mkKeyPairs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64
1 .. Word64
numKeyPairs]

mkKeyPairs ::
  Word64 ->
  (KeyPair kr, KeyPair kr')
mkKeyPairs :: forall (kr :: KeyRole) (kr' :: KeyRole).
Word64 -> (KeyPair kr, KeyPair kr')
mkKeyPairs Word64
n =
  (forall {kd :: KeyRole}. Word64 -> KeyPair kd
mkKeyPair_ (Word64
2 forall a. Num a => a -> a -> a
* Word64
n), forall {kd :: KeyRole}. Word64 -> KeyPair kd
mkKeyPair_ (Word64
2 forall a. Num a => a -> a -> a
* Word64
n forall a. Num a => a -> a -> a
+ Word64
1))
  where
    mkKeyPair_ :: Word64 -> KeyPair kd
mkKeyPair_ Word64
n_ =
      (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> (b, a)
swap)
        (forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
n_ Word64
n_ Word64
n_ Word64
n_ Word64
n_))

{------------------------------------------------------------------------------
  How to be a Generic Value
------------------------------------------------------------------------------}

exponential :: Integer -> Integer -> Gen Integer
exponential :: Integer -> Integer -> Gen Integer
exponential Integer
minc Integer
maxc = forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency [(Int, Gen Integer)]
spread
  where
    width :: Integer
width = (Integer
maxc forall a. Num a => a -> a -> a
- Integer
minc) forall a. Integral a => a -> a -> a
`div` Integer
n
    deltas :: [Gen Integer]
deltas = [forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
minc forall a. Num a => a -> a -> a
+ (Integer
i forall a. Num a => a -> a -> a
- Integer
1) forall a. Num a => a -> a -> a
* Integer
width, Integer
minc forall a. Num a => a -> a -> a
+ Integer
i forall a. Num a => a -> a -> a
* Integer
width) | Integer
i <- [Integer
1 .. Integer
n]]
    scales :: [Int]
scales = [Int
1, Int
2, Int
4, Int
6, Int
4, Int
2, Int
1]
    n :: Integer
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
scales)
    spread :: [(Int, Gen Integer)]
spread = forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
scales [Gen Integer]
deltas