{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Cardano.Ledger.Alonzo.Binary.CanonicalSpec (spec) where
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.PParams
import Cardano.Ledger.Binary (
Annotator (..),
Decoder,
TokenType (..),
decodeBool,
decodeBytesCanonical,
decodeDoubleCanonical,
decodeFullAnnotator,
decodeIntegerCanonical,
decodeListLenCanonical,
decodeMapLenCanonical,
decodeNull,
decodeSimpleCanonical,
decodeStringCanonical,
peekTokenType,
serialize,
withSlice,
)
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus.Language (Language)
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.Common
import qualified Test.QuickCheck.Property as QCP
spec :: Spec
spec :: Spec
spec = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"LangDepView encoding" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> (PParams AlonzoEra -> Set Language -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"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 :: String
base16String = ByteString -> String
forall a. Show a => a -> String
show (ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
encodedViews)
in String -> Result -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
base16String (Result -> Property) -> Result -> Property
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either String ()
isCanonical ByteString
encodedViews of
Right () -> Result
QCP.succeeded
Left String
message -> Result
QCP.failed {QCP.reason = message}
isCanonical :: LBS.ByteString -> Either String ()
isCanonical :: ByteString -> Either String ()
isCanonical ByteString
bytes =
case Version
-> Text
-> (forall s. Decoder s (Annotator (Either String ())))
-> ByteString
-> Either DecoderError (Either String ())
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 String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalTerm ByteString
bytes of
Left DecoderError
err -> String -> Either String ()
forall a b. a -> Either a b
Left (DecoderError -> String
forall a. Show a => a -> String
show DecoderError
err)
Right Either String ()
x -> Either String ()
x
checkCanonicalTerm :: Decoder s (Annotator (Either String ()))
checkCanonicalTerm :: forall s. Decoder s (Annotator (Either String ()))
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 =
String -> Decoder s a
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s a) -> String -> Decoder s a
forall a b. (a -> b) -> a -> b
$ String
"canonicity check for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TokenType -> String
forall a. Show a => a -> String
show TokenType
tt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not implemented"
case TokenType
tt of
TokenType
TypeUInt -> Integer -> Annotator (Either String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either String ()))
-> Decoder s Integer -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either String ()))
-> Decoder s Integer -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either String ()))
-> Decoder s Integer -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either String ()))
-> Decoder s Integer -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Integer -> Annotator (Either String ()))
-> Decoder s Integer -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Double -> Annotator (Either String ()))
-> Decoder s Double -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Double -> Annotator (Either String ()))
-> Decoder s Double -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Double -> Annotator (Either String ()))
-> Decoder s Double -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (ByteString -> Annotator (Either String ()))
-> Decoder s ByteString -> Decoder s (Annotator (Either String ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
decodeBytesCanonical
TokenType
TypeBytesIndef -> String -> Decoder s (Annotator (Either String ()))
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"indefinite bytes encoding"
TokenType
TypeString -> Text -> Annotator (Either String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Text -> Annotator (Either String ()))
-> Decoder s Text -> Decoder s (Annotator (Either String ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Text
forall s. Decoder s Text
decodeStringCanonical
TokenType
TypeStringIndef -> String -> Decoder s (Annotator (Either String ()))
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"indefinite string encoding"
TokenType
TypeListLen -> Annotator (Either String ()) -> Annotator (Either String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Annotator (Either String ()) -> Annotator (Either String ()))
-> Decoder s (Annotator (Either String ()))
-> Decoder s (Annotator (Either String ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (Either String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalList
TokenType
TypeListLen64 -> Annotator (Either String ()) -> Annotator (Either String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Annotator (Either String ()) -> Annotator (Either String ()))
-> Decoder s (Annotator (Either String ()))
-> Decoder s (Annotator (Either String ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (Either String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalList
TokenType
TypeListLenIndef -> String -> Decoder s (Annotator (Either String ()))
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"indefinite list encoding"
TokenType
TypeMapLen -> Decoder s (Annotator (Either String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalMap
TokenType
TypeMapLen64 -> Decoder s (Annotator (Either String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalMap
TokenType
TypeMapLenIndef -> String -> Decoder s (Annotator (Either String ()))
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"indefinite map encoding"
TokenType
TypeTag -> Decoder s (Annotator (Either String ()))
forall {a}. Decoder s a
failNotImplemented
TokenType
TypeTag64 -> Decoder s (Annotator (Either String ()))
forall {a}. Decoder s a
failNotImplemented
TokenType
TypeBool -> Bool -> Annotator (Either String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Bool -> Annotator (Either String ()))
-> Decoder s Bool -> Decoder s (Annotator (Either String ()))
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 String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (() -> Annotator (Either String ()))
-> Decoder s () -> Decoder s (Annotator (Either String ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ()
forall s. Decoder s ()
decodeNull
TokenType
TypeSimple -> Word8 -> Annotator (Either String ())
forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t (Word8 -> Annotator (Either String ()))
-> Decoder s Word8 -> Decoder s (Annotator (Either String ()))
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 String ()))
forall {a}. Decoder s a
failNotImplemented
TokenType
TypeInvalid -> Decoder s (Annotator (Either String ()))
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 String ()))
checkCanonicalMap = do
Int
n <- Decoder s Int
forall s. Decoder s Int
decodeMapLenCanonical
[Annotator (Either String ByteString)]
keys <- Int
-> Decoder s (Annotator (Either String ByteString))
-> Decoder s [Annotator (Either String ByteString)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Decoder s (Annotator (Either String ByteString))
forall s. Decoder s (Annotator (Either String ByteString))
checkCanonicalKVPair
let keys' :: Annotator (Either String [ByteString])
keys' :: Annotator (Either String [ByteString])
keys' = Compose Annotator (Either String) [ByteString]
-> Annotator (Either String [ByteString])
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose ((Annotator (Either String ByteString)
-> Compose Annotator (Either String) ByteString)
-> [Annotator (Either String ByteString)]
-> Compose Annotator (Either String) [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 String ByteString)
-> Compose Annotator (Either String) ByteString
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose [Annotator (Either String ByteString)]
keys)
Annotator (Either String ())
-> Decoder s (Annotator (Either String ()))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (Either String ())
-> Decoder s (Annotator (Either String ())))
-> Annotator (Either String ())
-> Decoder s (Annotator (Either String ()))
forall a b. (a -> b) -> a -> b
$
(FullByteString -> Either String ())
-> Annotator (Either String ())
forall a. (FullByteString -> a) -> Annotator a
Annotator ((FullByteString -> Either String ())
-> Annotator (Either String ()))
-> (FullByteString -> Either String ())
-> Annotator (Either String ())
forall a b. (a -> b) -> a -> b
$ \FullByteString
fullBytes -> do
[ByteString]
ks <- Annotator (Either String [ByteString])
-> FullByteString -> Either String [ByteString]
forall a. Annotator a -> FullByteString -> a
runAnnotator Annotator (Either String [ByteString])
keys' FullByteString
fullBytes
Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
isSorted [ByteString]
ks) (String -> Either String ()
forall a b. a -> Either a b
Left String
"map keys out of order")
checkCanonicalList :: Decoder s (Annotator (Either String ()))
checkCanonicalList :: forall s. Decoder s (Annotator (Either String ()))
checkCanonicalList = do
Int
len <- Decoder s Int
forall s. Decoder s Int
decodeListLenCanonical
[Annotator (Either String ())]
checkedTerms <- Int
-> Decoder s (Annotator (Either String ()))
-> Decoder s [Annotator (Either String ())]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len Decoder s (Annotator (Either String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalTerm
Annotator (Either String ())
-> Decoder s (Annotator (Either String ()))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (Either String ())
-> Decoder s (Annotator (Either String ())))
-> Annotator (Either String ())
-> Decoder s (Annotator (Either String ()))
forall a b. (a -> b) -> a -> b
$ Either String [()] -> Either String ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either String [()] -> Either String ())
-> Annotator (Either String [()]) -> Annotator (Either String ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compose Annotator (Either String) [()]
-> Annotator (Either String [()])
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose ((Annotator (Either String ())
-> Compose Annotator (Either String) ())
-> [Annotator (Either String ())]
-> Compose Annotator (Either String) [()]
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 String ())
-> Compose Annotator (Either String) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose [Annotator (Either String ())]
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 String ByteString))
checkCanonicalKVPair = do
(Annotator (Either String ())
key, Annotator ByteString
keyBytes) <- Decoder s (Annotator (Either String ()))
-> Decoder s (Annotator (Either String ()), Annotator ByteString)
forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice Decoder s (Annotator (Either String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalTerm
Annotator (Either String ())
value <- Decoder s (Annotator (Either String ()))
forall s. Decoder s (Annotator (Either String ()))
checkCanonicalTerm
Annotator (Either String ByteString)
-> Decoder s (Annotator (Either String ByteString))
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (Either String ByteString)
-> Decoder s (Annotator (Either String ByteString)))
-> Annotator (Either String ByteString)
-> Decoder s (Annotator (Either String ByteString))
forall a b. (a -> b) -> a -> b
$ Compose Annotator (Either String) ByteString
-> Annotator (Either String ByteString)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Annotator (Either String ())
-> Compose Annotator (Either String) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Annotator (Either String ())
key Compose Annotator (Either String) ()
-> Compose Annotator (Either String) ()
-> Compose Annotator (Either String) ()
forall a b.
Compose Annotator (Either String) a
-> Compose Annotator (Either String) b
-> Compose Annotator (Either String) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Annotator (Either String ())
-> Compose Annotator (Either String) ()
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Annotator (Either String ())
value Compose Annotator (Either String) ()
-> Compose Annotator (Either String) ByteString
-> Compose Annotator (Either String) ByteString
forall a b.
Compose Annotator (Either String) a
-> Compose Annotator (Either String) b
-> Compose Annotator (Either String) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Annotator (Either String ByteString)
-> Compose Annotator (Either String) ByteString
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> Annotator ByteString -> Annotator (Either String ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator ByteString
keyBytes))