Merge #598

598: Add ToCBOR and FromCBOR instances for UTxOValidationError r=mrBliss a=mrBliss These will be used by ouroboros-network to transmit validation errors over the local TxSubmission protocol. Co-authored-by: Thomas Winant <thomas@well-typed.com>
IntersectMBO · Aug 2, 2019 · ecbd65e · ecbd65e
2 parents a8bbbee + e68b38c
commit ecbd65e
Show file tree

Hide file tree

Showing 4 changed files with 161 additions and 5 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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