{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# 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.Crypto.DSIGN.Class (DSIGNAlgorithm (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto
import Cardano.Ledger.Keys (KeyHash, KeyRole (..), asWitness, hashKey)
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
class EraScript era => ScriptClass era where
basescript :: Proxy era -> KeyHash 'Witness (EraCrypto era) -> Script era
isKey :: Proxy era -> Script era -> Maybe (KeyHash 'Witness (EraCrypto era))
isOnePhase :: Proxy era -> Script era -> Bool
isOnePhase Proxy era
_proxy Script era
_ = Bool
True
quantify :: Proxy era -> Script era -> Quantifier (Script era)
unQuantify :: Proxy era -> Quantifier (Script era) -> Script era
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
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
scriptKeyCombination ::
forall era.
ScriptClass era =>
Proxy era ->
Script era ->
[KeyHash 'Witness (EraCrypto era)]
scriptKeyCombination :: forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness (EraCrypto era)]
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 (EraCrypto era)]
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 (EraCrypto era)]
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 (EraCrypto era)]
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 (EraCrypto era))
isKey Proxy era
prox Script era
t of
Just KeyHash 'Witness (EraCrypto era)
hk -> [KeyHash 'Witness (EraCrypto era)
hk]
Maybe (KeyHash 'Witness (EraCrypto era))
Nothing -> []
scriptKeyCombinations ::
forall era.
ScriptClass era =>
Proxy era ->
Script era ->
[[KeyHash 'Witness (EraCrypto era)]]
scriptKeyCombinations :: forall era.
ScriptClass era =>
Proxy era -> Script era -> [[KeyHash 'Witness (EraCrypto era)]]
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 (EraCrypto era)]]
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 (EraCrypto era)]]
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 (EraCrypto era)]]
scriptKeyCombinations Proxy era
prox)) [[Script era]]
perms
Leaf Script era
t -> case forall era.
ScriptClass era =>
Proxy era -> Script era -> Maybe (KeyHash 'Witness (EraCrypto era))
isKey Proxy era
prox Script era
t of
Just KeyHash 'Witness (EraCrypto era)
hk -> [[KeyHash 'Witness (EraCrypto era)
hk]]
Maybe (KeyHash 'Witness (EraCrypto era))
Nothing -> [[]]
mkScriptFromKey :: forall era. ScriptClass era => KeyPair 'Witness (EraCrypto era) -> Script era
mkScriptFromKey :: forall era.
ScriptClass era =>
KeyPair 'Witness (EraCrypto era) -> Script era
mkScriptFromKey = (forall era.
ScriptClass era =>
Proxy era -> KeyHash 'Witness (EraCrypto era) -> Script era
basescript (forall {k} (t :: k). Proxy t
Proxy :: Proxy era) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey)
mkScriptsFromKeyPair ::
forall era.
ScriptClass era =>
(KeyPair 'Payment (EraCrypto era), KeyPair 'Staking (EraCrypto era)) ->
(Script era, Script era)
mkScriptsFromKeyPair :: forall era.
ScriptClass era =>
(KeyPair 'Payment (EraCrypto era),
KeyPair 'Staking (EraCrypto era))
-> (Script era, Script era)
mkScriptsFromKeyPair (KeyPair 'Payment (EraCrypto era)
k0, KeyPair 'Staking (EraCrypto era)
k1) =
(forall era.
ScriptClass era =>
KeyPair 'Witness (EraCrypto era) -> Script era
mkScriptFromKey @era forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment (EraCrypto era)
k0, forall era.
ScriptClass era =>
KeyPair 'Witness (EraCrypto era) -> Script era
mkScriptFromKey @era forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Staking (EraCrypto era)
k1)
mkScripts ::
forall era.
ScriptClass era =>
KeyPairs (EraCrypto era) ->
[(Script era, Script era)]
mkScripts :: forall era.
ScriptClass era =>
KeyPairs (EraCrypto era) -> [(Script era, Script era)]
mkScripts = forall a b. (a -> b) -> [a] -> [b]
map (forall era.
ScriptClass era =>
(KeyPair 'Payment (EraCrypto era),
KeyPair 'Staking (EraCrypto era))
-> (Script era, Script era)
mkScriptsFromKeyPair @era)
mkPayScriptHashMap ::
forall era.
ScriptClass era =>
[(Script era, Script era)] ->
Map.Map (ScriptHash (EraCrypto era)) (Script era, Script era)
mkPayScriptHashMap :: forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era), (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 (EraCrypto era), (Script era, Script era))
f script :: (Script era, Script era)
script@(Script era
pay, Script era
_ssStake) = (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era Script era
pay, (Script era, Script era)
script)
mkStakeScriptHashMap ::
forall era.
ScriptClass era =>
[(Script era, Script era)] ->
Map.Map (ScriptHash (EraCrypto era)) (Script era, Script era)
mkStakeScriptHashMap :: forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era), (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 (EraCrypto era), (Script era, Script era))
f script :: (Script era, Script era)
script@(Script era
_pay, Script era
stake) = (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @era Script era
stake, (Script era, Script era)
script)
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)]
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 (EraCrypto era) -> [(Script era, Script era)]
mkScripts @era (forall c. Crypto c => Constants -> KeyPairs c
keyPairs Constants
c)
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
keyPairs :: Crypto c => Constants -> KeyPairs c
keyPairs :: forall c. Crypto c => Constants -> KeyPairs c
keyPairs Constants {Word64
numKeyPairs :: Constants -> Word64
numKeyPairs :: Word64
numKeyPairs} = forall c (kr :: KeyRole) (kr' :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
Word64 -> (KeyPair kr c, KeyPair kr' c)
mkKeyPairs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64
1 .. Word64
numKeyPairs]
mkKeyPairs ::
DSIGNAlgorithm (DSIGN c) =>
Word64 ->
(KeyPair kr c, KeyPair kr' c)
mkKeyPairs :: forall c (kr :: KeyRole) (kr' :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
Word64 -> (KeyPair kr c, KeyPair kr' c)
mkKeyPairs Word64
n =
(forall {c} {kd :: KeyRole}.
DSIGNAlgorithm (DSIGN c) =>
Word64 -> KeyPair kd c
mkKeyPair_ (Word64
2 forall a. Num a => a -> a -> a
* Word64
n), forall {c} {kd :: KeyRole}.
DSIGNAlgorithm (DSIGN c) =>
Word64 -> KeyPair kd c
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 c
mkKeyPair_ Word64
n_ =
(forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
KeyPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> (b, a)
swap)
(forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> (SignKeyDSIGN (DSIGN c), VKey kd c)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
n_ Word64
n_ Word64
n_ Word64
n_ Word64
n_))
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