{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.CanonicalState.BasicTypes (
  OnChain (..),
  DecodeOnChain (..),
  CanonicalCoin (..),
) where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.BaseTypes (Anchor (..), SlotNo (..), StrictMaybe (..))
import Cardano.Ledger.CanonicalState.LedgerCBOR
import Cardano.Ledger.CanonicalState.Namespace (Era, NamespaceEra)
import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Hashes (KeyHash (..), ScriptHash (..))
import qualified Cardano.Ledger.Hashes as H
import Cardano.SCLS.CBOR.Canonical (CanonicalDecoder)
import Cardano.SCLS.CBOR.Canonical.Decoder (
  FromCanonicalCBOR (..),
  decodeListLenCanonicalOf,
  peekTokenType,
 )
import Cardano.SCLS.CBOR.Canonical.Encoder (ToCanonicalCBOR (..))
import Cardano.SCLS.Versioned
import qualified Codec.CBOR.Decoding as D
import qualified Data.ByteString as BS (ByteString)
import qualified Data.ByteString.Base16 as Base16
import Data.Kind (Type)
import Data.Typeable (Typeable)
import Data.Word
import GHC.Generics (Generic)
import GHC.TypeLits

-- | Wrapper type that tells that the type is the type that is kept on-chain
-- for such types we want to keep exactly the same encoding as on the wire.
--
-- We still tag the type with an original one to be able to distinguish between
-- them.
data OnChain (a :: Type) = OnChain {forall a. OnChain a -> a
getValue :: !a, forall a. OnChain a -> ByteString
getWireEncoding :: !BS.ByteString}
  deriving stock ((forall x. OnChain a -> Rep (OnChain a) x)
-> (forall x. Rep (OnChain a) x -> OnChain a)
-> Generic (OnChain a)
forall x. Rep (OnChain a) x -> OnChain a
forall x. OnChain a -> Rep (OnChain a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (OnChain a) x -> OnChain a
forall a x. OnChain a -> Rep (OnChain a) x
$cfrom :: forall a x. OnChain a -> Rep (OnChain a) x
from :: forall x. OnChain a -> Rep (OnChain a) x
$cto :: forall a x. Rep (OnChain a) x -> OnChain a
to :: forall x. Rep (OnChain a) x -> OnChain a
Generic)

instance Eq a => Eq (OnChain a) where
  (OnChain a
_ ByteString
bs1) == :: OnChain a -> OnChain a -> Bool
== (OnChain a
_ ByteString
bs2) = ByteString
bs1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
bs2

instance Ord a => Ord (OnChain a) where
  compare :: OnChain a -> OnChain a -> Ordering
compare (OnChain a
_ ByteString
bs1) (OnChain a
_ ByteString
bs2) = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
bs1 ByteString
bs2

instance Show a => Show (OnChain a) where
  show :: OnChain a -> String
show (OnChain a
a ByteString
b) = ByteString -> String
forall a. Show a => a -> String
show (ByteString -> ByteString
Base16.encode ByteString
b) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a

instance ToCanonicalCBOR v (OnChain a) where
  toCanonicalCBOR :: forall (proxy :: Symbol -> *).
proxy v -> OnChain a -> CanonicalEncoding
toCanonicalCBOR proxy v
v (OnChain a
_ ByteString
bs) = proxy v -> ByteString -> CanonicalEncoding
forall (v :: Symbol) a (proxy :: Symbol -> *).
ToCanonicalCBOR v a =>
proxy v -> a -> CanonicalEncoding
forall (proxy :: Symbol -> *).
proxy v -> ByteString -> CanonicalEncoding
toCanonicalCBOR proxy v
v ByteString
bs

instance DecodeOnChain v a => FromCanonicalCBOR v (OnChain a) where
  fromCanonicalCBOR :: forall s. CanonicalDecoder s (Versioned v (OnChain a))
fromCanonicalCBOR = do
    Versioned bs <- CanonicalDecoder s (Versioned (ZonkAny 0) ByteString)
forall s. CanonicalDecoder s (Versioned (ZonkAny 0) ByteString)
forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR
    a <- decodeOnChain @v bs
    return $ Versioned (OnChain a bs)

-- | Helper types to encode on-chain types, it's used so
-- it would be possible to pass input bytestring to
-- `toPlainDecoder`.
class DecodeOnChain (v :: Symbol) (a :: Type) where
  decodeOnChain :: BS.ByteString -> CanonicalDecoder s a

-- | Wrapper for the coin type.
--
-- Despite the fact that Coin is on-chain type, we do not want to use
-- 'OnChain' wrapper for it. Because it's expected that if we keep chain
-- structure like transaction in canonical state, then we should keep entire
-- structure there and keep that as a whole, like 'UTxOut'.
newtype CanonicalCoin = CanonicalCoin {CanonicalCoin -> CompactForm Coin
unCoin :: CompactForm Coin}
  deriving (CanonicalCoin -> CanonicalCoin -> Bool
(CanonicalCoin -> CanonicalCoin -> Bool)
-> (CanonicalCoin -> CanonicalCoin -> Bool) -> Eq CanonicalCoin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CanonicalCoin -> CanonicalCoin -> Bool
== :: CanonicalCoin -> CanonicalCoin -> Bool
$c/= :: CanonicalCoin -> CanonicalCoin -> Bool
/= :: CanonicalCoin -> CanonicalCoin -> Bool
Eq, Eq CanonicalCoin
Eq CanonicalCoin =>
(CanonicalCoin -> CanonicalCoin -> Ordering)
-> (CanonicalCoin -> CanonicalCoin -> Bool)
-> (CanonicalCoin -> CanonicalCoin -> Bool)
-> (CanonicalCoin -> CanonicalCoin -> Bool)
-> (CanonicalCoin -> CanonicalCoin -> Bool)
-> (CanonicalCoin -> CanonicalCoin -> CanonicalCoin)
-> (CanonicalCoin -> CanonicalCoin -> CanonicalCoin)
-> Ord CanonicalCoin
CanonicalCoin -> CanonicalCoin -> Bool
CanonicalCoin -> CanonicalCoin -> Ordering
CanonicalCoin -> CanonicalCoin -> CanonicalCoin
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CanonicalCoin -> CanonicalCoin -> Ordering
compare :: CanonicalCoin -> CanonicalCoin -> Ordering
$c< :: CanonicalCoin -> CanonicalCoin -> Bool
< :: CanonicalCoin -> CanonicalCoin -> Bool
$c<= :: CanonicalCoin -> CanonicalCoin -> Bool
<= :: CanonicalCoin -> CanonicalCoin -> Bool
$c> :: CanonicalCoin -> CanonicalCoin -> Bool
> :: CanonicalCoin -> CanonicalCoin -> Bool
$c>= :: CanonicalCoin -> CanonicalCoin -> Bool
>= :: CanonicalCoin -> CanonicalCoin -> Bool
$cmax :: CanonicalCoin -> CanonicalCoin -> CanonicalCoin
max :: CanonicalCoin -> CanonicalCoin -> CanonicalCoin
$cmin :: CanonicalCoin -> CanonicalCoin -> CanonicalCoin
min :: CanonicalCoin -> CanonicalCoin -> CanonicalCoin
Ord, Int -> CanonicalCoin -> ShowS
[CanonicalCoin] -> ShowS
CanonicalCoin -> String
(Int -> CanonicalCoin -> ShowS)
-> (CanonicalCoin -> String)
-> ([CanonicalCoin] -> ShowS)
-> Show CanonicalCoin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CanonicalCoin -> ShowS
showsPrec :: Int -> CanonicalCoin -> ShowS
$cshow :: CanonicalCoin -> String
show :: CanonicalCoin -> String
$cshowList :: [CanonicalCoin] -> ShowS
showList :: [CanonicalCoin] -> ShowS
Show, (forall x. CanonicalCoin -> Rep CanonicalCoin x)
-> (forall x. Rep CanonicalCoin x -> CanonicalCoin)
-> Generic CanonicalCoin
forall x. Rep CanonicalCoin x -> CanonicalCoin
forall x. CanonicalCoin -> Rep CanonicalCoin x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CanonicalCoin -> Rep CanonicalCoin x
from :: forall x. CanonicalCoin -> Rep CanonicalCoin x
$cto :: forall x. Rep CanonicalCoin x -> CanonicalCoin
to :: forall x. Rep CanonicalCoin x -> CanonicalCoin
Generic)

instance FromCanonicalCBOR v CanonicalCoin where
  fromCanonicalCBOR :: forall s. CanonicalDecoder s (Versioned v CanonicalCoin)
fromCanonicalCBOR = (Word64 -> CanonicalCoin)
-> Versioned v Word64 -> Versioned v CanonicalCoin
forall a b. (a -> b) -> Versioned v a -> Versioned v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CompactForm Coin -> CanonicalCoin
CanonicalCoin (CompactForm Coin -> CanonicalCoin)
-> (Word64 -> CompactForm Coin) -> Word64 -> CanonicalCoin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> CompactForm Coin
CompactCoin) (Versioned v Word64 -> Versioned v CanonicalCoin)
-> CanonicalDecoder s (Versioned v Word64)
-> CanonicalDecoder s (Versioned v CanonicalCoin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CanonicalDecoder s (Versioned v Word64)
forall s. CanonicalDecoder s (Versioned v Word64)
forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR

instance ToCanonicalCBOR v CanonicalCoin where
  toCanonicalCBOR :: forall (proxy :: Symbol -> *).
proxy v -> CanonicalCoin -> CanonicalEncoding
toCanonicalCBOR proxy v
v (CanonicalCoin (CompactCoin Word64
c)) = proxy v -> Word64 -> CanonicalEncoding
forall (v :: Symbol) a (proxy :: Symbol -> *).
ToCanonicalCBOR v a =>
proxy v -> a -> CanonicalEncoding
forall (proxy :: Symbol -> *).
proxy v -> Word64 -> CanonicalEncoding
toCanonicalCBOR proxy v
v Word64
c

instance ToCanonicalCBOR v a => ToCanonicalCBOR v (StrictMaybe a) where
  toCanonicalCBOR :: forall (proxy :: Symbol -> *).
proxy v -> StrictMaybe a -> CanonicalEncoding
toCanonicalCBOR proxy v
v StrictMaybe a
SNothing = proxy v -> () -> CanonicalEncoding
forall (v :: Symbol) a (proxy :: Symbol -> *).
ToCanonicalCBOR v a =>
proxy v -> a -> CanonicalEncoding
forall (proxy :: Symbol -> *). proxy v -> () -> CanonicalEncoding
toCanonicalCBOR proxy v
v ()
  toCanonicalCBOR proxy v
v (SJust a
x) = proxy v -> a -> CanonicalEncoding
forall (v :: Symbol) a (proxy :: Symbol -> *).
ToCanonicalCBOR v a =>
proxy v -> a -> CanonicalEncoding
forall (proxy :: Symbol -> *). proxy v -> a -> CanonicalEncoding
toCanonicalCBOR proxy v
v a
x

instance FromCanonicalCBOR v a => FromCanonicalCBOR v (StrictMaybe a) where
  fromCanonicalCBOR :: forall s. CanonicalDecoder s (Versioned v (StrictMaybe a))
fromCanonicalCBOR = do
    mt <- CanonicalDecoder s TokenType
forall s. CanonicalDecoder s TokenType
peekTokenType
    case mt of
      TokenType
D.TypeNull -> do
        Versioned () <- CanonicalDecoder s (Versioned (ZonkAny 3) ())
forall s. CanonicalDecoder s (Versioned (ZonkAny 3) ())
forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR
        pure (Versioned SNothing)
      TokenType
_ -> (a -> StrictMaybe a)
-> Versioned v a -> Versioned v (StrictMaybe a)
forall a b. (a -> b) -> Versioned v a -> Versioned v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> StrictMaybe a
forall a. a -> StrictMaybe a
SJust (Versioned v a -> Versioned v (StrictMaybe a))
-> CanonicalDecoder s (Versioned v a)
-> CanonicalDecoder s (Versioned v (StrictMaybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CanonicalDecoder s (Versioned v a)
forall s. CanonicalDecoder s (Versioned v a)
forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR

deriving via
  LedgerCBOR v Anchor
  instance
    (Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v Anchor

deriving via
  LedgerCBOR v Anchor
  instance
    (Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v Anchor

deriving via
  LedgerCBOR v ScriptHash
  instance
    (Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v ScriptHash

deriving via
  LedgerCBOR v ScriptHash
  instance
    (Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v ScriptHash

instance ToCanonicalCBOR v (H.Hash a b) where
  toCanonicalCBOR :: forall (proxy :: Symbol -> *).
proxy v -> Hash a b -> CanonicalEncoding
toCanonicalCBOR proxy v
v Hash a b
h = proxy v -> ByteString -> CanonicalEncoding
forall (v :: Symbol) a (proxy :: Symbol -> *).
ToCanonicalCBOR v a =>
proxy v -> a -> CanonicalEncoding
forall (proxy :: Symbol -> *).
proxy v -> ByteString -> CanonicalEncoding
toCanonicalCBOR proxy v
v (Hash a b -> ByteString
forall h a. Hash h a -> ByteString
Hash.hashToBytes Hash a b
h)

instance H.HashAlgorithm a => FromCanonicalCBOR v (H.Hash a b) where
  fromCanonicalCBOR :: forall s. CanonicalDecoder s (Versioned v (Hash a b))
fromCanonicalCBOR = do
    Versioned bytes <- CanonicalDecoder s (Versioned (ZonkAny 2) ShortByteString)
forall s.
CanonicalDecoder s (Versioned (ZonkAny 2) ShortByteString)
forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR
    case Hash.hashFromBytesShort bytes of
      Just Hash a b
h -> Versioned v (Hash a b)
-> CanonicalDecoder s (Versioned v (Hash a b))
forall a. a -> CanonicalDecoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Hash a b -> Versioned v (Hash a b)
forall (ns :: Symbol) a. a -> Versioned ns a
Versioned Hash a b
h)
      Maybe (Hash a b)
Nothing -> String -> CanonicalDecoder s (Versioned v (Hash a b))
forall a. String -> CanonicalDecoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid hash bytes"

deriving newtype instance ToCanonicalCBOR v SlotNo

deriving newtype instance FromCanonicalCBOR v SlotNo

deriving via
  LedgerCBOR v (H.KeyHash kr)
  instance
    (Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v (H.KeyHash kr)

deriving via
  LedgerCBOR v (H.KeyHash kr)
  instance
    (Era era, NamespaceEra v ~ era, Typeable kr) => FromCanonicalCBOR v (H.KeyHash kr)

instance (Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v (Credential kr) where
  toCanonicalCBOR :: forall (proxy :: Symbol -> *).
proxy v -> Credential kr -> CanonicalEncoding
toCanonicalCBOR proxy v
v (ScriptHashObj ScriptHash
sh) = proxy v -> (Word8, ScriptHash) -> CanonicalEncoding
forall (v :: Symbol) a (proxy :: Symbol -> *).
ToCanonicalCBOR v a =>
proxy v -> a -> CanonicalEncoding
forall (proxy :: Symbol -> *).
proxy v -> (Word8, ScriptHash) -> CanonicalEncoding
toCanonicalCBOR proxy v
v (Word8
0 :: Word8, ScriptHash
sh)
  toCanonicalCBOR proxy v
v (KeyHashObj KeyHash kr
kh) = proxy v -> (Word8, KeyHash kr) -> CanonicalEncoding
forall (v :: Symbol) a (proxy :: Symbol -> *).
ToCanonicalCBOR v a =>
proxy v -> a -> CanonicalEncoding
forall (proxy :: Symbol -> *).
proxy v -> (Word8, KeyHash kr) -> CanonicalEncoding
toCanonicalCBOR proxy v
v (Word8
1 :: Word8, KeyHash kr
kh)

instance (Era era, NamespaceEra v ~ era, Typeable kr) => FromCanonicalCBOR v (Credential kr) where
  fromCanonicalCBOR :: forall s. CanonicalDecoder s (Versioned v (Credential kr))
fromCanonicalCBOR = do
    Int -> CanonicalDecoder s ()
forall s. Int -> CanonicalDecoder s ()
decodeListLenCanonicalOf Int
2
    Versioned (tag :: Word8) <- CanonicalDecoder s (Versioned (ZonkAny 1) Word8)
forall s. CanonicalDecoder s (Versioned (ZonkAny 1) Word8)
forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR
    case tag of
      Word8
0 -> (ScriptHash -> Credential kr)
-> Versioned v ScriptHash -> Versioned v (Credential kr)
forall a b. (a -> b) -> Versioned v a -> Versioned v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptHash -> Credential kr
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (Versioned v ScriptHash -> Versioned v (Credential kr))
-> CanonicalDecoder s (Versioned v ScriptHash)
-> CanonicalDecoder s (Versioned v (Credential kr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR @v
      Word8
1 -> (KeyHash kr -> Credential kr)
-> Versioned v (KeyHash kr) -> Versioned v (Credential kr)
forall a b. (a -> b) -> Versioned v a -> Versioned v b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KeyHash kr -> Credential kr
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (Versioned v (KeyHash kr) -> Versioned v (Credential kr))
-> CanonicalDecoder s (Versioned v (KeyHash kr))
-> CanonicalDecoder s (Versioned v (Credential kr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (v :: Symbol) a s.
FromCanonicalCBOR v a =>
CanonicalDecoder s (Versioned v a)
fromCanonicalCBOR @v
      Word8
_ -> String -> CanonicalDecoder s (Versioned v (Credential kr))
forall a. String -> CanonicalDecoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Credential tag"