diff --git a/cardano-ledger/src/Cardano/Chain/Common/Lovelace.hs b/cardano-ledger/src/Cardano/Chain/Common/Lovelace.hs index c159bac91db..e442fbd98c7 100644 --- a/cardano-ledger/src/Cardano/Chain/Common/Lovelace.hs +++ b/cardano-ledger/src/Cardano/Chain/Common/Lovelace.hs @@ -58,7 +58,15 @@ import GHC.TypeLits (type (<=)) import qualified Text.JSON.Canonical as Canonical (FromJSON(..), ReportSchemaErrors, ToJSON(..)) -import Cardano.Binary (DecoderError(..), FromCBOR(..), ToCBOR(..)) +import Cardano.Binary + ( DecoderError(..) + , FromCBOR(..) + , ToCBOR(..) + , decodeListLen + , decodeWord8 + , encodeListLen + , matchSize + ) -- | Lovelace is the least possible unit of currency @@ -123,6 +131,29 @@ instance B.Buildable LovelaceError where c' c +instance ToCBOR LovelaceError where + toCBOR = \case + LovelaceOverflow c -> + encodeListLen 2 <> toCBOR @Word8 0 <> toCBOR c + LovelaceTooLarge c -> + encodeListLen 2 <> toCBOR @Word8 1 <> toCBOR c + LovelaceTooSmall c -> + encodeListLen 2 <> toCBOR @Word8 2 <> toCBOR c + LovelaceUnderflow c c' -> + encodeListLen 3 <> toCBOR @Word8 3 <> toCBOR c <> toCBOR c' + +instance FromCBOR LovelaceError where + fromCBOR = do + len <- decodeListLen + let checkSize size = matchSize "LovelaceError" size len + tag <- decodeWord8 + case tag of + 0 -> checkSize 2 >> LovelaceOverflow <$> fromCBOR + 1 -> checkSize 2 >> LovelaceTooLarge <$> fromCBOR + 2 -> checkSize 2 >> LovelaceTooSmall <$> fromCBOR + 3 -> checkSize 3 >> LovelaceUnderflow <$> fromCBOR <*> fromCBOR + _ -> cborError $ DecoderErrorUnknownTag "TxValidationError" tag + -- | Maximal possible value of 'Lovelace' maxLovelaceVal :: Word64 maxLovelaceVal = 45e15 diff --git a/cardano-ledger/src/Cardano/Chain/Common/NetworkMagic.hs b/cardano-ledger/src/Cardano/Chain/Common/NetworkMagic.hs index 7eb9204ebb1..26320e206a5 100644 --- a/cardano-ledger/src/Cardano/Chain/Common/NetworkMagic.hs +++ b/cardano-ledger/src/Cardano/Chain/Common/NetworkMagic.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Chain.Common.NetworkMagic ( NetworkMagic (..) @@ -12,6 +14,8 @@ import Cardano.Prelude hiding ((%)) import Formatting (bprint, build, (%)) import qualified Formatting.Buildable as B +import Cardano.Binary (DecoderError(..), FromCBOR(..), ToCBOR(..), + decodeListLen, decodeWord8, encodeListLen , matchSize) import Cardano.Crypto.ProtocolMagic (AProtocolMagic (..), RequiresNetworkMagic (..), getProtocolMagic) @@ -33,6 +37,22 @@ instance HeapWords NetworkMagic where heapWords NetworkMainOrStage = 0 heapWords (NetworkTestnet _) = 2 +instance ToCBOR NetworkMagic where + toCBOR = \case + NetworkMainOrStage -> + encodeListLen 1 <> toCBOR @Word8 0 + NetworkTestnet n -> + encodeListLen 2 <> toCBOR @Word8 1 <> toCBOR n + +instance FromCBOR NetworkMagic where + fromCBOR = do + len <- decodeListLen + tag <- decodeWord8 + case tag of + 0 -> matchSize "NetworkMagic" 1 len $> NetworkMainOrStage + 1 -> matchSize "NetworkMagic" 2 len >> NetworkTestnet <$> fromCBOR + _ -> cborError $ DecoderErrorUnknownTag "NetworkMagic" tag + makeNetworkMagic :: AProtocolMagic a -> NetworkMagic makeNetworkMagic pm = case getRequiresNetworkMagic pm of RequiresNoMagic -> NetworkMainOrStage diff --git a/cardano-ledger/src/Cardano/Chain/UTxO/UTxO.hs b/cardano-ledger/src/Cardano/Chain/UTxO/UTxO.hs index 086123d0c11..18821cafe4a 100644 --- a/cardano-ledger/src/Cardano/Chain/UTxO/UTxO.hs +++ b/cardano-ledger/src/Cardano/Chain/UTxO/UTxO.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Chain.UTxO.UTxO ( UTxO(..) @@ -33,7 +35,15 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import qualified Data.Set as S -import Cardano.Binary (FromCBOR, ToCBOR) +import Cardano.Binary + ( DecoderError(..) + , FromCBOR(..) + , ToCBOR(..) + , decodeListLen + , decodeWord8 + , encodeListLen + , matchSize + ) import Cardano.Chain.Common (Address, Lovelace, LovelaceError, isRedeemAddress, sumLovelace) import Cardano.Chain.UTxO.Tx (Tx(..), TxId, TxIn(..), TxOut(..)) @@ -59,6 +69,22 @@ data UTxOError | UTxOOverlappingUnion deriving (Eq, Show) +instance ToCBOR UTxOError where + toCBOR = \case + UTxOMissingInput txIn -> + encodeListLen 2 <> toCBOR @Word8 0 <> toCBOR txIn + UTxOOverlappingUnion -> + encodeListLen 1 <> toCBOR @Word8 1 + +instance FromCBOR UTxOError where + fromCBOR = do + len <- decodeListLen + tag <- decodeWord8 + case tag of + 0 -> matchSize "UTxOError" 2 len >> UTxOMissingInput <$> fromCBOR + 1 -> matchSize "UTxOError" 1 len $> UTxOOverlappingUnion + _ -> cborError $ DecoderErrorUnknownTag "UTxOError" tag + empty :: UTxO empty = UTxO mempty diff --git a/cardano-ledger/src/Cardano/Chain/UTxO/Validation.hs b/cardano-ledger/src/Cardano/Chain/UTxO/Validation.hs index 4446bbce0b1..a5b1c282a6b 100644 --- a/cardano-ledger/src/Cardano/Chain/UTxO/Validation.hs +++ b/cardano-ledger/src/Cardano/Chain/UTxO/Validation.hs @@ -25,7 +25,18 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Set as S import qualified Data.Vector as V -import Cardano.Binary (Annotated(..)) +import Cardano.Binary + ( Annotated(..) + , Decoder + , DecoderError(DecoderErrorUnknownTag) + , FromCBOR(..) + , ToCBOR(..) + , decodeListLen + , decodeWord8 + , encodeListLen + , enforceSize + , matchSize + ) import Cardano.Chain.Common ( Address(..) , Lovelace @@ -77,6 +88,60 @@ data TxValidationError | TxValidationUnknownAttributes deriving (Eq, Show) +instance ToCBOR TxValidationError where + toCBOR = \case + TxValidationLovelaceError text loveLaceError -> + encodeListLen 3 + <> toCBOR @Word8 0 + <> toCBOR text + <> toCBOR loveLaceError + TxValidationFeeTooSmall tx lovelace1 lovelace2 -> + encodeListLen 4 + <> toCBOR @Word8 1 + <> toCBOR tx + <> toCBOR lovelace1 + <> toCBOR lovelace2 + TxValidationInvalidWitness txInWitness -> + encodeListLen 2 + <> toCBOR @Word8 2 + <> toCBOR txInWitness + TxValidationMissingInput txIn -> + encodeListLen 2 + <> toCBOR @Word8 3 + <> toCBOR txIn + TxValidationNetworkMagicMismatch networkMagic1 networkMagic2 -> + encodeListLen 3 + <> toCBOR @Word8 4 + <> toCBOR networkMagic1 + <> toCBOR networkMagic2 + TxValidationTxTooLarge nat1 nat2 -> + encodeListLen 3 + <> toCBOR @Word8 5 + <> toCBOR nat1 + <> toCBOR nat2 + TxValidationUnknownAddressAttributes -> + encodeListLen 1 + <> toCBOR @Word8 6 + TxValidationUnknownAttributes -> + encodeListLen 1 + <> toCBOR @Word8 7 + +instance FromCBOR TxValidationError where + fromCBOR = do + len <- decodeListLen + let checkSize :: forall s. Int -> Decoder s () + checkSize size = matchSize "TxValidationError" size len + tag <- decodeWord8 + case tag of + 0 -> checkSize 3 >> TxValidationLovelaceError <$> fromCBOR <*> fromCBOR + 1 -> checkSize 4 >> TxValidationFeeTooSmall <$> fromCBOR <*> fromCBOR <*> fromCBOR + 2 -> checkSize 2 >> TxValidationInvalidWitness <$> fromCBOR + 3 -> checkSize 2 >> TxValidationMissingInput <$> fromCBOR + 4 -> checkSize 3 >> TxValidationNetworkMagicMismatch <$> fromCBOR <*> fromCBOR + 5 -> checkSize 3 >> TxValidationTxTooLarge <$> fromCBOR <*> fromCBOR + 6 -> checkSize 1 $> TxValidationUnknownAddressAttributes + 7 -> checkSize 1 $> TxValidationUnknownAttributes + _ -> cborError $ DecoderErrorUnknownTag "TxValidationError" tag -- | Validate that: -- @@ -207,6 +272,20 @@ data UTxOValidationError | UTxOValidationUTxOError UTxOError deriving (Eq, Show) +instance ToCBOR UTxOValidationError where + toCBOR = \case + UTxOValidationTxValidationError txValidationError -> + encodeListLen 2 <> toCBOR @Word8 0 <> toCBOR txValidationError + UTxOValidationUTxOError uTxOError -> + encodeListLen 2 <> toCBOR @Word8 1 <> toCBOR uTxOError + +instance FromCBOR UTxOValidationError where + fromCBOR = do + enforceSize "UTxOValidationError" 2 + decodeWord8 >>= \case + 0 -> UTxOValidationTxValidationError <$> fromCBOR + 1 -> UTxOValidationUTxOError <$> fromCBOR + tag -> cborError $ DecoderErrorUnknownTag "UTxOValidationError" tag -- | Validate a transaction and use it to update the 'UTxO' updateUTxOTx