[wip] Take into account value for computing TxOut hash

This commit only tries to serialise Ada values on-chain. It also
"vendorises" the CBOR encoder from @KtorZ stolen from #154

hydra-node/src/Hydra/Ledger/Cardano.hs

@@ -709,11 +709,11 @@ genValue = txOutValue <$> (genKeyPair >>= (genOutput . fst))
 genAdaOnlyUtxo :: Gen Utxo
 genAdaOnlyUtxo = do
   fmap adaOnly <$> arbitrary
- where
-  adaOnly :: TxOut CtxUTxO AlonzoEra -> TxOut CtxUTxO AlonzoEra
-  adaOnly = \case
-    TxOut addr value datum ->
-      TxOut addr (lovelaceToTxOutValue $ txOutValueToLovelace value) datum
+
+adaOnly :: TxOut CtxUTxO AlonzoEra -> TxOut CtxUTxO AlonzoEra
+adaOnly = \case
+  TxOut addr value datum ->
+    TxOut addr (lovelaceToTxOutValue $ txOutValueToLovelace value) datum
 
 -- | Generate UTXO with only 'TxOut' which are addressed to non-bootstrap
 -- (byron) addresses.

hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs

@@ -9,6 +9,7 @@ import Test.Hydra.Prelude
 
 import Cardano.Binary (serialize')
 import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN)
+import Cardano.Crypto.Hash (hashToBytes)
 import Cardano.Crypto.Util (SignableRepresentation (getSignableRepresentation))
 import qualified Cardano.Ledger.Alonzo.Data as Ledger
 import Cardano.Ledger.Alonzo.Scripts (ExUnits)
@@ -46,14 +47,17 @@ import Hydra.Ledger.Cardano (
   ExecutionUnits (ExecutionUnits),
   LedgerCrypto,
   LedgerEra,
+  NetworkId (Mainnet),
   PlutusScriptV1,
   Tx (ShelleyTx, Tx),
   TxBody (ShelleyTxBody, TxBody),
   TxBodyContent (..),
   TxBodyScriptData (TxBodyNoScriptData, TxBodyScriptData),
   TxOut (..),
+  TxOutDatum (TxOutDatumNone),
   Utxo,
   Utxo' (Utxo),
+  adaOnly,
   addInputs,
   describeCardanoTx,
   emptyTxBody,
@@ -74,15 +78,19 @@ import Hydra.Ledger.Cardano (
   mkScriptWitness,
   mkTxOutDatum,
   mkTxOutDatumHash,
+  mkVkAddress,
   modifyTxOutValue,
+  shrinkUtxo,
   toCtxUTxOTxOut,
   toLedgerTx,
   toLedgerTxOut,
   toLedgerUtxo,
   txOutValue,
   unsafeBuildTransaction,
+  verificationKeyHash,
  )
 import qualified Hydra.Ledger.Cardano as Api
+import qualified Hydra.Ledger.Cardano as Cardano
 import Hydra.Ledger.Simple (SimpleTx)
 import Hydra.Party (
   MultiSigned (MultiSigned),
@@ -97,8 +105,9 @@ import Hydra.Party (
  )
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
 import Plutus.Orphans ()
-import Plutus.V1.Ledger.Api (fromBuiltin, fromData, toBuiltin, toData)
+import Plutus.V1.Ledger.Api (Address (Address), Credential (PubKeyCredential), PubKeyHash (PubKeyHash), fromBuiltin, fromData, toBuiltin, toData)
 import Plutus.V1.Ledger.Crypto (Signature (Signature))
+import qualified Plutus.V1.Ledger.Tx as Plutus
 import Test.QuickCheck (
   Positive (Positive),
   Property,
@@ -109,6 +118,8 @@ import Test.QuickCheck (
   elements,
   forAll,
   forAllShow,
+  forAllShrink,
+  generate,
   oneof,
   property,
   suchThat,
@@ -131,7 +142,7 @@ spec = do
       "verifies snapshot multi-signature for list of parties and signatures"
       prop_verifySnapshotSignatures
   describe "TxOut hashing" $ do
-    prop "hashUtxo == hashTxOuts" prop_hashUtxo
+    prop "hashUtxo == hashTxOuts" prop_hashUtxoWithAdaOnly
   describe "Close" $ do
     prop "is healthy" $
       propTransactionValidates healthyCloseTx
@@ -195,11 +206,12 @@ calculateHashExUnits n algorithm =
 -- Properties
 --
 
-prop_hashUtxo :: Property
-prop_hashUtxo =
+prop_hashUtxoWithAdaOnly :: Property
+prop_hashUtxoWithAdaOnly =
   -- NOTE: We only generate shelley addressed txouts because they are left out
   -- of the plutus script context in 'txInfoOut'.
-  forAllShow genUtxoWithoutByronAddresses (decodeUtf8 . encodePretty) $ \(utxo :: Utxo) ->
+  -- NOTE: we only generate Ada only UTXO as a baby step
+  forAllShrink (fmap adaOnly <$> genUtxoWithoutByronAddresses) shrinkUtxo $ \(utxo :: Utxo) ->
     let plutusTxOuts = mapMaybe txInfoOut ledgerTxOuts
         ledgerTxOuts = Map.elems . Ledger.unUTxO $ toLedgerUtxo utxo
      in (hashUtxo utxo === fromBuiltin (hashTxOuts plutusTxOuts))

hydra-plutus/src/Hydra/Contract/MockHead.hs

@@ -5,6 +5,7 @@
 
 module Hydra.Contract.MockHead where
 
+import qualified Hydra.Prelude as Prelude
 import Ledger hiding (validatorHash)
 import PlutusTx.Prelude
 
@@ -18,9 +19,11 @@ import Ledger.Constraints (TxConstraints)
 import qualified Ledger.Typed.Scripts as Scripts
 import Plutus.Contract.StateMachine.OnChain (StateMachine)
 import qualified Plutus.Contract.StateMachine.OnChain as SM
+import Plutus.V1.Ledger.Ada (fromValue, getLovelace)
 import Plutus.V1.Ledger.Api (Credential (PubKeyCredential, ScriptCredential), getValue, unCurrencySymbol, unTokenName)
 import qualified PlutusTx
 import qualified PlutusTx.AssocMap as AssocMap
+import PlutusTx.Builtins (subtractInteger)
 import Text.Show (Show)
 
 type SnapshotNumber = Integer
@@ -110,9 +113,7 @@ serialiseTxOut TxOut{txOutAddress, txOutValue} =
          in case addressCredential of
               PubKeyCredential (PubKeyHash bs) -> bs
               ScriptCredential (ValidatorHash bs) -> bs
-      valueBytes = foldr currencyBytes mempty $ AssocMap.toList (getValue txOutValue)
-      currencyBytes (cur, tokList) bs = unCurrencySymbol cur <> foldr tokenBytes mempty (AssocMap.toList tokList) <> bs
-      tokenBytes (tok, val) bs = unTokenName tok <> naturalToCBOR val <> bs
+      valueBytes = naturalToCBOR . getLovelace . fromValue $ txOutValue
    in addrBytes <> valueBytes
 {-# INLINEABLE serialiseTxOut #-}
 
@@ -151,18 +152,55 @@ mockSign vkey msg = appendByteString (sliceByteString 0 8 hashedMsg) (naturalToC
 naturalToCBOR :: Integer -> BuiltinByteString
 naturalToCBOR n
   | n < 0 =
-    traceError "naturalToCBOR: n < 0"
+    encodeUnsigned 1 (subtractInteger 0 n - 1)
+  | otherwise =
+    encodeUnsigned 0 n
+{-# INLINEABLE naturalToCBOR #-}
+
+withMajorType :: Integer -> Integer -> BuiltinByteString -> BuiltinByteString
+withMajorType major n =
+  consByteString (32 * major + n)
+{-# INLINEABLE withMajorType #-}
+
+encodeUnsigned :: Integer -> Integer -> BuiltinByteString
+encodeUnsigned major n
   | n < 24 =
-    consByteString n emptyByteString
+    withMajorType major n emptyByteString
   | n < 256 =
-    consByteString 24 $ consByteString n emptyByteString
+    withMajorType major 24 (encodeUnsigned8 n)
   | n < 65536 =
-    consByteString 25 $
-      consByteString (quotient n 256) $
-        consByteString (remainder n 256) emptyByteString
+    withMajorType major 25 (encodeUnsigned16 n)
+  | n < 4294967296 =
+    withMajorType major 26 (encodeUnsigned32 n)
   | otherwise =
-    traceError "naturalToCBOR: n >= 65536"
-{-# INLINEABLE naturalToCBOR #-}
+    withMajorType major 27 (encodeUnsigned64 n)
+{-# INLINEABLE encodeUnsigned #-}
+
+encodeUnsigned8 :: Integer -> BuiltinByteString
+encodeUnsigned8 n =
+  consByteString n emptyByteString
+{-# INLINEABLE encodeUnsigned8 #-}
+
+encodeUnsigned16 :: Integer -> BuiltinByteString
+encodeUnsigned16 n =
+  appendByteString
+    (encodeUnsigned8 (quotient n 256))
+    (encodeUnsigned8 (remainder n 256))
+{-# INLINEABLE encodeUnsigned16 #-}
+
+encodeUnsigned32 :: Integer -> BuiltinByteString
+encodeUnsigned32 n =
+  appendByteString
+    (encodeUnsigned16 (quotient n 65536))
+    (encodeUnsigned16 (remainder n 65536))
+{-# INLINEABLE encodeUnsigned32 #-}
+
+encodeUnsigned64 :: Integer -> BuiltinByteString
+encodeUnsigned64 n =
+  appendByteString
+    (encodeUnsigned32 (quotient n 4294967296))
+    (encodeUnsigned32 (remainder n 4294967296))
+{-# INLINEABLE encodeUnsigned64 #-}
 
 -- | The script instance of the auction state machine. It contains the state
 -- machine compiled to a Plutus core validator script. The 'MintingPolicyHash' serves