{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Cardano.Ledger.Alonzo.Serialisation.Canonical (tests) where
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.PParams
import Cardano.Ledger.Binary (
Decoder,
TokenType (..),
decodeBool,
decodeBytesCanonical,
decodeDoubleCanonical,
decodeIntegerCanonical,
decodeListLenCanonical,
decodeMapLenCanonical,
decodeNull,
decodeSimpleCanonical,
decodeStringCanonical,
peekTokenType,
serialize,
)
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus.Language (Language)
import Control.Monad (replicateM, unless, void)
import qualified Data.ByteString.Base16 as B16
import Data.ByteString.Lazy as LBS
import Data.Functor.Compose (Compose (..))
import Data.Set (Set)
import qualified Data.Set as Set
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
import Test.Cardano.Ledger.Alonzo.Binary.Annotator
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import qualified Test.QuickCheck.Property as QCP
import Test.Tasty
import Test.Tasty.QuickCheck
tests :: TestTree
tests :: TestTree
tests = TestName
-> (PParams AlonzoEra -> Set Language -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"LangDepView encoding is canonical" PParams AlonzoEra -> Set Language -> Property
canonicalLangDepView
canonicalLangDepView :: PParams AlonzoEra -> Set Language -> Property
canonicalLangDepView :: PParams AlonzoEra -> Set Language -> Property
canonicalLangDepView PParams AlonzoEra
pparams Set Language
langs =
let langViews :: Set LangDepView
langViews = [LangDepView] -> Set LangDepView
forall a. Ord a => [a] -> Set a
Set.fromList ([LangDepView] -> Set LangDepView)
-> [LangDepView] -> Set LangDepView
forall a b. (a -> b) -> a -> b
$ PParams AlonzoEra -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams AlonzoEra
pparams (Language -> LangDepView) -> [Language] -> [LangDepView]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Language -> [Language]
forall a. Set a -> [a]
Set.toList Set Language
langs
encodedViews :: ByteString
encodedViews = Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerHigh @AlonzoEra) (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ Set LangDepView -> Encoding
encodeLangViews Set LangDepView
langViews
base16String :: TestName
base16String = ByteString -> TestName
forall a. Show a => a -> TestName
show (ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
encodedViews)
in TestName -> Result -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
base16String (Result -> Property) -> Result -> Property
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either TestName ()
isCanonical ByteString
encodedViews of
Right () -> Result
QCP.succeeded
Left TestName
message -> Result
QCP.failed {QCP.reason = message}
isCanonical :: LBS.ByteString -> Either String ()
isCanonical :: ByteString -> Either TestName ()
isCanonical ByteString
bytes =
case Version
-> Text
-> (forall s. Decoder s (Annotator (Either TestName ())))
-> ByteString
-> Either DecoderError (Either TestName ())
forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator (forall era. Era era => Version
eraProtVerHigh @AlonzoEra) Text
"Canonicity check" Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm ByteString
bytes of
Left DecoderError
err -> TestName -> Either TestName ()
forall a b. a -> Either a b
Left (DecoderError -> TestName
forall a. Show a => a -> TestName
show DecoderError
err)
Right Either TestName ()
x -> Either TestName ()
x
checkCanonicalTerm :: Decoder s (Annotator (Either String ()))
checkCanonicalTerm :: forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm = do
TokenType
tt <- Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType
let t :: p -> f (Either a ())
t p
_ = Either a () -> f (Either a ())
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either a ()
forall a b. b -> Either a b
Right ())
failNotImplemented :: Decoder s a
failNotImplemented =
TestName -> Decoder s a
forall a. TestName -> Decoder s a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail (TestName -> Decoder s a) -> TestName -> Decoder s a
forall a b. (a -> b) -> a -> b
$ TestName
"canonicity check for " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TokenType -> TestName
forall a. Show a => a -> TestName
show TokenType
tt TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
" not implemented"
case TokenType
tt of
TokenType
TypeUInt -> Integer -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either TestName ()))
-> Decoder s Integer -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeIntegerCanonical
TokenType
TypeUInt64 -> Integer -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either TestName ()))
-> Decoder s Integer -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeIntegerCanonical
TokenType
TypeNInt -> Integer -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either TestName ()))
-> Decoder s Integer -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeIntegerCanonical
TokenType
TypeNInt64 -> Integer -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either TestName ()))
-> Decoder s Integer -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeIntegerCanonical
TokenType
TypeInteger -> Integer -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either TestName ()))
-> Decoder s Integer -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeIntegerCanonical
TokenType
TypeFloat16 -> Double -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Double -> Annotator (Either TestName ()))
-> Decoder s Double -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Double
forall s. Decoder s Double
decodeDoubleCanonical
TokenType
TypeFloat32 -> Double -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Double -> Annotator (Either TestName ()))
-> Decoder s Double -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Double
forall s. Decoder s Double
decodeDoubleCanonical
TokenType
TypeFloat64 -> Double -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Double -> Annotator (Either TestName ()))
-> Decoder s Double -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Double
forall s. Decoder s Double
decodeDoubleCanonical
TokenType
TypeBytes -> ByteString -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (ByteString -> Annotator (Either TestName ()))
-> Decoder s ByteString
-> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
decodeBytesCanonical
TokenType
TypeBytesIndef -> TestName -> Decoder s (Annotator (Either TestName ()))
forall a. TestName -> Decoder s a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite bytes encoding"
TokenType
TypeString -> Text -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Text -> Annotator (Either TestName ()))
-> Decoder s Text -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Text
forall s. Decoder s Text
decodeStringCanonical
TokenType
TypeStringIndef -> TestName -> Decoder s (Annotator (Either TestName ()))
forall a. TestName -> Decoder s a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite string encoding"
TokenType
TypeListLen -> Annotator (Either TestName ()) -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Annotator (Either TestName ()) -> Annotator (Either TestName ()))
-> Decoder s (Annotator (Either TestName ()))
-> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalList
TokenType
TypeListLen64 -> Annotator (Either TestName ()) -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Annotator (Either TestName ()) -> Annotator (Either TestName ()))
-> Decoder s (Annotator (Either TestName ()))
-> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalList
TokenType
TypeListLenIndef -> TestName -> Decoder s (Annotator (Either TestName ()))
forall a. TestName -> Decoder s a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite list encoding"
TokenType
TypeMapLen -> Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalMap
TokenType
TypeMapLen64 -> Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalMap
TokenType
TypeMapLenIndef -> TestName -> Decoder s (Annotator (Either TestName ()))
forall a. TestName -> Decoder s a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite map encoding"
TokenType
TypeTag -> Decoder s (Annotator (Either TestName ()))
forall {a}. Decoder s a
failNotImplemented
TokenType
TypeTag64 -> Decoder s (Annotator (Either TestName ()))
forall {a}. Decoder s a
failNotImplemented
TokenType
TypeBool -> Bool -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Bool -> Annotator (Either TestName ()))
-> Decoder s Bool -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Bool
forall s. Decoder s Bool
decodeBool
TokenType
TypeNull -> () -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (() -> Annotator (Either TestName ()))
-> Decoder s () -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ()
forall s. Decoder s ()
decodeNull
TokenType
TypeSimple -> Word8 -> Annotator (Either TestName ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Word8 -> Annotator (Either TestName ()))
-> Decoder s Word8 -> Decoder s (Annotator (Either TestName ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word8
forall s. Decoder s Word8
decodeSimpleCanonical
TokenType
TypeBreak -> Decoder s (Annotator (Either TestName ()))
forall {a}. Decoder s a
failNotImplemented
TokenType
TypeInvalid -> Decoder s (Annotator (Either TestName ()))
forall {a}. Decoder s a
failNotImplemented
shortLex :: ByteString -> ByteString -> Ordering
shortLex :: ByteString -> ByteString -> Ordering
shortLex ByteString
x ByteString
y = case Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteString -> Int64
LBS.length ByteString
x) (ByteString -> Int64
LBS.length ByteString
y) of
Ordering
LT -> Ordering
LT
Ordering
GT -> Ordering
GT
Ordering
EQ -> [Word8] -> [Word8] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteString -> [Word8]
LBS.unpack ByteString
x) (ByteString -> [Word8]
LBS.unpack ByteString
y)
checkCanonicalMap :: Decoder s (Annotator (Either String ()))
checkCanonicalMap :: forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalMap = do
Int
n <- Decoder s Int
forall s. Decoder s Int
decodeMapLenCanonical
[Annotator (Either TestName ByteString)]
keys <- Int
-> Decoder s (Annotator (Either TestName ByteString))
-> Decoder s [Annotator (Either TestName ByteString)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Decoder s (Annotator (Either TestName ByteString))
forall s. Decoder s (Annotator (Either TestName ByteString))
checkCanonicalKVPair
let keys' :: Annotator (Either String [ByteString])
keys' :: Annotator (Either TestName [ByteString])
keys' = Compose Annotator (Either TestName) [ByteString]
-> Annotator (Either TestName [ByteString])
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose ((Annotator (Either TestName ByteString)
-> Compose Annotator (Either TestName) ByteString)
-> [Annotator (Either TestName ByteString)]
-> Compose Annotator (Either TestName) [ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Annotator (Either TestName ByteString)
-> Compose Annotator (Either TestName) ByteString
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose [Annotator (Either TestName ByteString)]
keys)
Annotator (Either TestName ())
-> Decoder s (Annotator (Either TestName ()))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (Either TestName ())
-> Decoder s (Annotator (Either TestName ())))
-> Annotator (Either TestName ())
-> Decoder s (Annotator (Either TestName ()))
forall a b. (a -> b) -> a -> b
$
(FullByteString -> Either TestName ())
-> Annotator (Either TestName ())
forall a. (FullByteString -> a) -> Annotator a
Annotator ((FullByteString -> Either TestName ())
-> Annotator (Either TestName ()))
-> (FullByteString -> Either TestName ())
-> Annotator (Either TestName ())
forall a b. (a -> b) -> a -> b
$ \FullByteString
fullBytes -> do
[ByteString]
ks <- Annotator (Either TestName [ByteString])
-> FullByteString -> Either TestName [ByteString]
forall a. Annotator a -> FullByteString -> a
runAnnotator Annotator (Either TestName [ByteString])
keys' FullByteString
fullBytes
Bool -> Either TestName () -> Either TestName ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
isSorted [ByteString]
ks) (TestName -> Either TestName ()
forall a b. a -> Either a b
Left TestName
"map keys out of order")
checkCanonicalList :: Decoder s (Annotator (Either String ()))
checkCanonicalList :: forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalList = do
Int
len <- Decoder s Int
forall s. Decoder s Int
decodeListLenCanonical
[Annotator (Either TestName ())]
checkedTerms <- Int
-> Decoder s (Annotator (Either TestName ()))
-> Decoder s [Annotator (Either TestName ())]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm
Annotator (Either TestName ())
-> Decoder s (Annotator (Either TestName ()))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (Either TestName ())
-> Decoder s (Annotator (Either TestName ())))
-> Annotator (Either TestName ())
-> Decoder s (Annotator (Either TestName ()))
forall a b. (a -> b) -> a -> b
$ Either TestName [()] -> Either TestName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either TestName [()] -> Either TestName ())
-> Annotator (Either TestName [()])
-> Annotator (Either TestName ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compose Annotator (Either TestName) [()]
-> Annotator (Either TestName [()])
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose ((Annotator (Either TestName ())
-> Compose Annotator (Either TestName) ())
-> [Annotator (Either TestName ())]
-> Compose Annotator (Either TestName) [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Annotator (Either TestName ())
-> Compose Annotator (Either TestName) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose [Annotator (Either TestName ())]
checkedTerms)
isSorted :: [ByteString] -> Bool
isSorted :: [ByteString] -> Bool
isSorted [] = Bool
True
isSorted [ByteString
_] = Bool
True
isSorted (ByteString
x : xs :: [ByteString]
xs@(ByteString
y : [ByteString]
_)) = case ByteString -> ByteString -> Ordering
shortLex ByteString
x ByteString
y of
Ordering
GT -> Bool
False
Ordering
_ -> [ByteString] -> Bool
isSorted [ByteString]
xs
checkCanonicalKVPair :: Decoder s (Annotator (Either String ByteString))
checkCanonicalKVPair :: forall s. Decoder s (Annotator (Either TestName ByteString))
checkCanonicalKVPair = do
(Annotator (Either TestName ())
key, Annotator ByteString
keyBytes) <- Decoder s (Annotator (Either TestName ()))
-> Decoder s (Annotator (Either TestName ()), Annotator ByteString)
forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm
Annotator (Either TestName ())
value <- Decoder s (Annotator (Either TestName ()))
forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm
Annotator (Either TestName ByteString)
-> Decoder s (Annotator (Either TestName ByteString))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (Either TestName ByteString)
-> Decoder s (Annotator (Either TestName ByteString)))
-> Annotator (Either TestName ByteString)
-> Decoder s (Annotator (Either TestName ByteString))
forall a b. (a -> b) -> a -> b
$ Compose Annotator (Either TestName) ByteString
-> Annotator (Either TestName ByteString)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Annotator (Either TestName ())
-> Compose Annotator (Either TestName) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Annotator (Either TestName ())
key Compose Annotator (Either TestName) ()
-> Compose Annotator (Either TestName) ()
-> Compose Annotator (Either TestName) ()
forall a b.
Compose Annotator (Either TestName) a
-> Compose Annotator (Either TestName) b
-> Compose Annotator (Either TestName) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Annotator (Either TestName ())
-> Compose Annotator (Either TestName) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Annotator (Either TestName ())
value Compose Annotator (Either TestName) ()
-> Compose Annotator (Either TestName) ByteString
-> Compose Annotator (Either TestName) ByteString
forall a b.
Compose Annotator (Either TestName) a
-> Compose Annotator (Either TestName) b
-> Compose Annotator (Either TestName) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Annotator (Either TestName ByteString)
-> Compose Annotator (Either TestName) ByteString
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ByteString -> Either TestName ByteString
forall a b. b -> Either a b
Right (ByteString -> Either TestName ByteString)
-> Annotator ByteString -> Annotator (Either TestName ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator ByteString
keyBytes))