{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Its a helper module, that is used to write canonical instances that
-- are lucky to match the current ledger implementation. There is no guarantee
-- that current ledger implementation will never diverge from the canonical
-- one. So it's important to run the scls conformance test for such instances.
--
-- If you use this method to derive canonical instances, make sure to add
-- a proper conformance test that covers the instance, and canonicity tests.
--
-- Example usage:
-- @
--
-- import Cardano.Ledger.Hashes ( ScriptHash )
--
-- deriving via LedgerCBOR v ScriptHash instance ToCanonicalCBOR v ScriptHash
--
-- deriving via LedgerCBOR v ScriptHash instance FromCanonicalCBOR v ScriptHash
--
-- tests = do
--    describe "GovConstitution ScriptHash canonical encoding" $ do
--      validateType @"gov/constitution/v0" @(ScriptHash) "script_hash"
-- --                  ^^^^^^^^^^^^^^^^^^                 ^^^^^^^^^^^^
-- --                   SCLS namespace                    CDDL rule name, to verify against
--      isCanonical @"common" @ScriptHash
-- --               ^^^^^^^
-- --               Namespace
-- @
module Cardano.Ledger.CanonicalState.LedgerCBOR (
  LedgerCBOR (..),
  LedgerSafeCBOR (..),
) where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
 )
import Cardano.Ledger.CanonicalState.Namespace
import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR)
import Cardano.SCLS.CBOR.Canonical (assumeCanonicalDecoder, assumeCanonicalEncoding)
import Cardano.SCLS.CBOR.Canonical.Decoder (FromCanonicalCBOR (..))
import Cardano.SCLS.CBOR.Canonical.Encoder (ToCanonicalCBOR (..), forceCanonical)
import Cardano.SCLS.Versioned
import GHC.TypeLits

-- | Helper that allows us to deriving instances via decodeTermToken CBOR representation.
--
-- Such newtype simply reuses existing EncCBOR and DecCBOR instances and does not guarantee
-- neither canonicity nor conformance with the specification, so it's important to add
-- conformance tests (@validateType@) and canonicity tests (@isCanonical@) for such instances.
--
-- Canonical ledger state uses so called deterministic cbor a canonical encoding with a few additional rules:
--  * sets (some tag) are sorted
--  * keys are sorted in lexicographical order of their byte encoding
--  * lists and byteareas use fixed length structures
--
-- It's needed for alignment of the binary encoding of the same data structure within
-- different scls implementations (different languages).
--
-- cborg library on it's own does use canonical encoding
-- (minimal size for integral values etc). If helpers from the scls-cbor library are used
-- then result encoding will satisfy all the properties, but sometimes you know that
-- existing cbor encoding already satisfies required properties, it happens when only
-- basic types and tuples are used, in this case it's possible to use 'assumeCanonicalEncoding'.
--
-- 'assumeCanonicalEncoding' means that we do not check or reencode cbor and
-- assume that whatever encoding was passed to that is canonical. But in this case
-- it would be nice to add a test that verifies that the encoding is actually canonical,
-- e.g.  'isCanonical @"gov/constitution/v0" @GovConstitution.V0.CanonicalConstitution'
-- is an example of such test.
newtype LedgerCBOR (v :: Symbol) a = LedgerCBOR {forall (v :: Symbol) a. LedgerCBOR v a -> a
unLedgerCBOR :: a}
  deriving (LedgerCBOR v a -> LedgerCBOR v a -> Bool
(LedgerCBOR v a -> LedgerCBOR v a -> Bool)
-> (LedgerCBOR v a -> LedgerCBOR v a -> Bool)
-> Eq (LedgerCBOR v a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: Symbol) a.
Eq a =>
LedgerCBOR v a -> LedgerCBOR v a -> Bool
$c== :: forall (v :: Symbol) a.
Eq a =>
LedgerCBOR v a -> LedgerCBOR v a -> Bool
== :: LedgerCBOR v a -> LedgerCBOR v a -> Bool
$c/= :: forall (v :: Symbol) a.
Eq a =>
LedgerCBOR v a -> LedgerCBOR v a -> Bool
/= :: LedgerCBOR v a -> LedgerCBOR v a -> Bool
Eq, Int -> LedgerCBOR v a -> ShowS
[LedgerCBOR v a] -> ShowS
LedgerCBOR v a -> String
(Int -> LedgerCBOR v a -> ShowS)
-> (LedgerCBOR v a -> String)
-> ([LedgerCBOR v a] -> ShowS)
-> Show (LedgerCBOR v a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Symbol) a. Show a => Int -> LedgerCBOR v a -> ShowS
forall (v :: Symbol) a. Show a => [LedgerCBOR v a] -> ShowS
forall (v :: Symbol) a. Show a => LedgerCBOR v a -> String
$cshowsPrec :: forall (v :: Symbol) a. Show a => Int -> LedgerCBOR v a -> ShowS
showsPrec :: Int -> LedgerCBOR v a -> ShowS
$cshow :: forall (v :: Symbol) a. Show a => LedgerCBOR v a -> String
show :: LedgerCBOR v a -> String
$cshowList :: forall (v :: Symbol) a. Show a => [LedgerCBOR v a] -> ShowS
showList :: [LedgerCBOR v a] -> ShowS
Show)

instance (EncCBOR a, Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v (LedgerCBOR v a) where
  toCanonicalCBOR :: forall (proxy :: Symbol -> *).
proxy v -> LedgerCBOR v a -> CanonicalEncoding
toCanonicalCBOR proxy v
_v (LedgerCBOR a
a) = Encoding -> CanonicalEncoding
assumeCanonicalEncoding (Encoding -> CanonicalEncoding) -> Encoding -> CanonicalEncoding
forall a b. (a -> b) -> a -> b
$ forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era a
a

instance (DecCBOR a, Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v (LedgerCBOR v a) where
  fromCanonicalCBOR :: forall s. CanonicalDecoder s (Versioned v (LedgerCBOR v a))
fromCanonicalCBOR =
    LedgerCBOR v a -> Versioned v (LedgerCBOR v a)
forall (ns :: Symbol) a. a -> Versioned ns a
Versioned (LedgerCBOR v a -> Versioned v (LedgerCBOR v a))
-> (a -> LedgerCBOR v a) -> a -> Versioned v (LedgerCBOR v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LedgerCBOR v a
forall (v :: Symbol) a. a -> LedgerCBOR v a
LedgerCBOR (a -> Versioned v (LedgerCBOR v a))
-> CanonicalDecoder s a
-> CanonicalDecoder s (Versioned v (LedgerCBOR v a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> CanonicalDecoder s a
forall s a. Decoder s a -> CanonicalDecoder s a
assumeCanonicalDecoder (forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era)

-- | Helper that allows us to deriving instances via decodeTermToken CBOR representation
newtype LedgerSafeCBOR (v :: Symbol) a = LedgerSafeCBOR {forall (v :: Symbol) a. LedgerSafeCBOR v a -> a
unLedgerSafeCBOR :: a}
  deriving (LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool
(LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool)
-> (LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool)
-> Eq (LedgerSafeCBOR v a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: Symbol) a.
Eq a =>
LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool
$c== :: forall (v :: Symbol) a.
Eq a =>
LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool
== :: LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool
$c/= :: forall (v :: Symbol) a.
Eq a =>
LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool
/= :: LedgerSafeCBOR v a -> LedgerSafeCBOR v a -> Bool
Eq, Int -> LedgerSafeCBOR v a -> ShowS
[LedgerSafeCBOR v a] -> ShowS
LedgerSafeCBOR v a -> String
(Int -> LedgerSafeCBOR v a -> ShowS)
-> (LedgerSafeCBOR v a -> String)
-> ([LedgerSafeCBOR v a] -> ShowS)
-> Show (LedgerSafeCBOR v a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Symbol) a.
Show a =>
Int -> LedgerSafeCBOR v a -> ShowS
forall (v :: Symbol) a. Show a => [LedgerSafeCBOR v a] -> ShowS
forall (v :: Symbol) a. Show a => LedgerSafeCBOR v a -> String
$cshowsPrec :: forall (v :: Symbol) a.
Show a =>
Int -> LedgerSafeCBOR v a -> ShowS
showsPrec :: Int -> LedgerSafeCBOR v a -> ShowS
$cshow :: forall (v :: Symbol) a. Show a => LedgerSafeCBOR v a -> String
show :: LedgerSafeCBOR v a -> String
$cshowList :: forall (v :: Symbol) a. Show a => [LedgerSafeCBOR v a] -> ShowS
showList :: [LedgerSafeCBOR v a] -> ShowS
Show)

-- | A safer version of 'LedgerCBOR' that forces canonical encoding by re-encoding the produced value,
-- this instance is slower but guarantees canonicity of the type.
--
-- This instance does not guarantee conformance with the specification, so it's important to add
-- conformance tests (@validateType@) for such instances as well.
instance
  (EncCBOR a, Era era, NamespaceEra v ~ era) =>
  ToCanonicalCBOR v (LedgerSafeCBOR v a)
  where
  toCanonicalCBOR :: forall (proxy :: Symbol -> *).
proxy v -> LedgerSafeCBOR v a -> CanonicalEncoding
toCanonicalCBOR proxy v
v (LedgerSafeCBOR a
a) = proxy v -> Encoding -> CanonicalEncoding
forall (proxy :: Symbol -> *) (v :: Symbol).
HasCallStack =>
proxy v -> Encoding -> CanonicalEncoding
forceCanonical proxy v
v (Encoding -> CanonicalEncoding) -> Encoding -> CanonicalEncoding
forall a b. (a -> b) -> a -> b
$ forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era a
a

instance
  (DecCBOR a, Era era, NamespaceEra v ~ era) =>
  FromCanonicalCBOR v (LedgerSafeCBOR v a)
  where
  fromCanonicalCBOR :: forall s. CanonicalDecoder s (Versioned v (LedgerSafeCBOR v a))
fromCanonicalCBOR =
    LedgerSafeCBOR v a -> Versioned v (LedgerSafeCBOR v a)
forall (ns :: Symbol) a. a -> Versioned ns a
Versioned (LedgerSafeCBOR v a -> Versioned v (LedgerSafeCBOR v a))
-> (a -> LedgerSafeCBOR v a)
-> a
-> Versioned v (LedgerSafeCBOR v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LedgerSafeCBOR v a
forall (v :: Symbol) a. a -> LedgerSafeCBOR v a
LedgerSafeCBOR (a -> Versioned v (LedgerSafeCBOR v a))
-> CanonicalDecoder s a
-> CanonicalDecoder s (Versioned v (LedgerSafeCBOR v a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> CanonicalDecoder s a
forall s a. Decoder s a -> CanonicalDecoder s a
assumeCanonicalDecoder (forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era)