{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.Serialisation.Canonical (tests) where

import Cardano.Ledger.Alonzo (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.Crypto
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.Serialisation.Generators ()
import qualified Test.QuickCheck.Property as QCP
import Test.Tasty
import Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests = forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"LangDepView encoding is canonical" (forall c.
Crypto c =>
PParams (AlonzoEra c) -> Set Language -> Property
canonicalLangDepView @StandardCrypto)

canonicalLangDepView :: forall c. Crypto c => PParams (AlonzoEra c) -> Set Language -> Property
canonicalLangDepView :: forall c.
Crypto c =>
PParams (AlonzoEra c) -> Set Language -> Property
canonicalLangDepView PParams (AlonzoEra c)
pparams Set Language
langs =
  let langViews :: Set LangDepView
langViews = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams (AlonzoEra c)
pparams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set Language
langs
      encodedViews :: ByteString
encodedViews = forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerHigh @(AlonzoEra c)) forall a b. (a -> b) -> a -> b
$ Set LangDepView -> Encoding
encodeLangViews Set LangDepView
langViews
      base16String :: TestName
base16String = forall a. Show a => a -> TestName
show (ByteString -> ByteString
B16.encode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
encodedViews)
   in forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
base16String 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 {reason :: TestName
QCP.reason = TestName
message}

isCanonical :: LBS.ByteString -> Either String ()
isCanonical :: ByteString -> Either TestName ()
isCanonical ByteString
bytes =
  case forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator (forall era. Era era => Version
eraProtVerHigh @Alonzo) Text
"Canonicity check" forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm ByteString
bytes of
    Left DecoderError
err -> forall a b. a -> Either a b
Left (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 <- forall s. Decoder s TokenType
peekTokenType
  let t :: p -> f (Either a ())
t p
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
      failNotImplemented :: Decoder s a
failNotImplemented =
        forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail forall a b. (a -> b) -> a -> b
$ TestName
"canonicity check for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> TestName
show TokenType
tt forall a. Semigroup a => a -> a -> a
<> TestName
" not implemented"
  case TokenType
tt of
    TokenType
TypeUInt -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeIntegerCanonical
    TokenType
TypeUInt64 -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeIntegerCanonical
    TokenType
TypeNInt -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeIntegerCanonical
    TokenType
TypeNInt64 -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeIntegerCanonical
    TokenType
TypeInteger -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeIntegerCanonical
    TokenType
TypeFloat16 -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Double
decodeDoubleCanonical
    TokenType
TypeFloat32 -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Double
decodeDoubleCanonical
    TokenType
TypeFloat64 -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Double
decodeDoubleCanonical
    TokenType
TypeBytes -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s ByteString
decodeBytesCanonical
    TokenType
TypeBytesIndef -> forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite bytes encoding"
    TokenType
TypeString -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Text
decodeStringCanonical
    TokenType
TypeStringIndef -> forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite string encoding"
    TokenType
TypeListLen -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalList
    TokenType
TypeListLen64 -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalList
    TokenType
TypeListLenIndef -> forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite list encoding"
    TokenType
TypeMapLen -> forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalMap
    TokenType
TypeMapLen64 -> forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalMap
    TokenType
TypeMapLenIndef -> forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"indefinite map encoding"
    TokenType
TypeTag -> forall {a}. Decoder s a
failNotImplemented
    TokenType
TypeTag64 -> forall {a}. Decoder s a
failNotImplemented
    TokenType
TypeBool -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Bool
decodeBool
    TokenType
TypeNull -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s ()
decodeNull
    TokenType
TypeSimple -> forall {f :: * -> *} {p} {a}. Applicative f => p -> f (Either a ())
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Word8
decodeSimpleCanonical
    TokenType
TypeBreak -> forall {a}. Decoder s a
failNotImplemented
    TokenType
TypeInvalid -> 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 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 -> 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 <- forall s. Decoder s Int
decodeMapLenCanonical
  [Annotator (Either TestName ByteString)]
keys <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n forall s. Decoder s (Annotator (Either TestName ByteString))
checkCanonicalKVPair
  let keys' :: Annotator (Either String [ByteString])
      keys' :: Annotator (Either TestName [ByteString])
keys' = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose [Annotator (Either TestName ByteString)]
keys)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a. (FullByteString -> a) -> Annotator a
Annotator forall a b. (a -> b) -> a -> b
$ \FullByteString
fullBytes -> do
      [ByteString]
ks <- forall a. Annotator a -> FullByteString -> a
runAnnotator Annotator (Either TestName [ByteString])
keys' FullByteString
fullBytes
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
isSorted [ByteString]
ks) (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 <- forall s. Decoder s Int
decodeListLenCanonical
  [Annotator (Either TestName ())]
checkedTerms <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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) <- forall s a. Decoder s a -> Decoder s (a, Annotator ByteString)
withSlice forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm
  Annotator (Either TestName ())
value <- forall s. Decoder s (Annotator (Either TestName ()))
checkCanonicalTerm
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Annotator (Either TestName ())
key forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Annotator (Either TestName ())
value forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator ByteString
keyBytes))