{-# 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

{-
- The keys in the map must be sorted as follows:
   -  If two keys have different lengths, the shorter one sorts earlier.
   -  If two keys have the same length, the one with the lower value
      in (byte-wise) lexical order sorts earlier.
-}
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))