Release/12.0.x+cbor datum

backfill-cbor-datums/Main.hs

@@ -0,0 +1,182 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans -Wno-missing-signatures #-}
+
+module Main where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.Text
+
+import qualified Cardano.Binary as CBOR
+import qualified Cardano.Api.Shelley as Api
+import qualified Plutus.V1.Ledger.Api as Plutus
+import           Codec.Serialise.Class (Serialise (..))
+import Cardano.Db
+
+import Database.Esqueleto.Experimental
+
+-- Due to pending api fix
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.List as List
+import qualified Data.Scientific as Scientific
+import qualified Data.Text.Encoding as Text
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Vector as Vector
+
+main :: IO ()
+main = do
+  putStrLn "Yolo"
+  todoLen <- runDbStdoutLogging $ do
+    maybe (0 :: Int) unValue . listToMaybe <$>
+      (select $ do
+        datum <- from (table @Datum)
+        where_ (isNothing (datum ^. DatumBytes))
+        pure countRows
+      )
+
+  liftIO
+    $ putStrLn
+    $ "Found " ++ show todoLen ++ " datums to backfill"
+
+  backfillAll 0 todoLen
+  putStrLn "All done"
+
+backfillAll :: Int -> Int -> IO ()
+backfillAll n total = do
+  backfillSome >>= \case
+    0 -> pure ()
+    x -> do
+      liftIO $ putStrLn $ "- " ++ show (n + x) ++ "/" ++ show total
+      liftIO $ threadDelay 1000000
+      backfillAll (n + x) total
+
+backfillSome :: IO Int
+backfillSome = do
+  --runDbStdoutLogging $ do
+  runDbNoLogging $ do
+    dats <- select $ do
+      datum <- from (table @Datum)
+      where_ (isNothing (datum ^. DatumBytes))
+      limit 10000
+      pure datum
+
+    forM_ dats $ \d -> do
+      case decodeData <$> datumValue (entityVal d) of
+        Just (Right dat) -> do
+          update $ \p -> do
+            let bytes = Api.serialiseToCBOR dat
+            set p [ DatumBytes =. just (val bytes)  ]
+            where_ $ (p ^. DatumId) ==. val (entityKey d)
+
+        Just (Left err) -> error
+          $ "Decoding failed " ++ show err ++ " input was " ++ show (datumValue (entityVal d))
+        Nothing -> error "absurd"
+
+    pure (length dats)
+
+
+-- check that previous datum CBOR bytes = new computed from JSON
+checkRoundtrip :: IO ()
+checkRoundtrip = do
+  runDbStdoutLogging $ do
+    dats <- select $ do
+      datum <- from (table @Datum)
+      where_ (not_ $ isNothing (datum ^. DatumBytes))
+      pure datum
+
+    forM_ dats $ \d -> do
+      let
+          Just olddat = datumBytes (entityVal d)
+
+      liftIO $ case decodeData <$> datumValue (entityVal d) of
+        Just (Right dat) -> do
+          unless (Api.serialiseToCBOR dat == olddat) $ do
+            error $ "No match" ++ show dat
+        Just (Left err) -> print ("Errord" :: String, err)
+        Nothing -> error "absurd"
+
+decodeData :: Text -> Either Api.ScriptDataJsonSchemaError Api.ScriptData
+decodeData x =
+      scriptDataFromJsonDetailedSchema
+    $ fromMaybe (error "absurd aeson decode")
+    $ Aeson.decode @Aeson.Value
+    $ LBS.fromStrict
+    $ BS.pack
+    $ Data.Text.unpack x
+
+encodeData dt = LBS.toStrict $ Aeson.encode $
+  Api.scriptDataToJson Api.ScriptDataJsonDetailedSchema $ Api.fromAlonzoData dt
+
+instance Api.SerialiseAsCBOR Api.ScriptData where
+  serialiseToCBOR = CBOR.serialize'
+
+instance CBOR.ToCBOR Api.ScriptData where
+  toCBOR = encode @Plutus.Data . Api.toPlutusData
+
+instance CBOR.FromCBOR Api.ScriptData where
+  fromCBOR = Api.fromPlutusData <$> decode @Plutus.Data
+
+-- ouch
+-- due to pending api fix
+scriptDataFromJsonDetailedSchema :: Aeson.Value
+                                 -> Either Api.ScriptDataJsonSchemaError
+                                           Api.ScriptData
+scriptDataFromJsonDetailedSchema = conv
+  where
+    conv :: Aeson.Value
+         -> Either Api.ScriptDataJsonSchemaError Api.ScriptData
+    conv (Aeson.Object m) =
+      case List.sort $ HashMap.toList m of
+        [("int", Aeson.Number d)] ->
+          case Scientific.floatingOrInteger d :: Either Double Integer of
+            Left  n -> Left (Api.ScriptDataJsonNumberNotInteger n)
+            Right n -> Right (Api.ScriptDataNumber n)
+
+        [("bytes", Aeson.String s)]
+          | Right bs <- Base16.decode (Text.encodeUtf8 s)
+          -> Right (Api.ScriptDataBytes bs)
+
+        [("list", Aeson.Array vs)] ->
+            fmap Api.ScriptDataList
+          . traverse conv
+          $ Vector.toList vs
+
+        [("map", Aeson.Array kvs)] ->
+            fmap Api.ScriptDataMap
+          . traverse convKeyValuePair
+          $ Vector.toList kvs
+
+        [("constructor", Aeson.Number d),
+         ("fields",      Aeson.Array vs)] ->
+          case Scientific.floatingOrInteger d :: Either Double Integer of
+            Left  n -> Left (Api.ScriptDataJsonNumberNotInteger n)
+            Right n -> fmap (Api.ScriptDataConstructor n)
+                     . traverse conv
+                     $ Vector.toList vs
+
+        (key, v):_ | key `elem` ["int", "bytes", "list", "map", "constructor"] ->
+            Left (Api.ScriptDataJsonTypeMismatch key v)
+
+        kvs -> Left (Api.ScriptDataJsonBadObject kvs)
+
+    conv v = Left (Api.ScriptDataJsonNotObject v)
+
+    convKeyValuePair :: Aeson.Value
+                     -> Either Api.ScriptDataJsonSchemaError
+                               (Api.ScriptData, Api.ScriptData)
+    convKeyValuePair (Aeson.Object m)
+      | HashMap.size m == 2
+      , Just k <- HashMap.lookup "k" m
+      , Just v <- HashMap.lookup "v" m
+      = (,) <$> conv k <*> conv v
+    convKeyValuePair _ = error "absurd convKeyValuePair"

backfill-cbor-datums/backfill-cbor-datums.cabal

@@ -0,0 +1,45 @@
+cabal-version:       2.2
+name:                backfill-cbor-datums
+version:             0.1.0.0
+license:             Apache-2.0
+author:              Richard Marko
+maintainer:          [email protected]
+copyright:           2022 Richard Marko
+build-type:          Simple
+
+executable backfill-cbor-datums
+  hs-source-dirs:      .
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , aeson
+                     , bytestring
+                     , cardano-binary
+                     , cardano-db
+                     , cardano-api
+                     , esqueleto
+                     , plutus-ledger-api
+                     , serialise
+                     , text
+                     , unordered-containers
+                     , vector
+                     , base16-bytestring
+                     , scientific
+  default-language:    Haskell2010
+
+
+-- test-suite backfill-cbor-datums-tests
+--   type:                exitcode-stdio-1.0
+--   hs-source-dirs:      test
+--   main-is:             Spec.hs
+--   other-modules:       --ParseSpec
+--                        SpecHelper
+--   build-depends:       base >= 4.7 && < 5
+--                      , backfill-cbor-datums
+--                      , hspec
+--                      , base16-bytestring
+--   default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/sorki/backfill-cbor-datums

cabal.project

@@ -8,6 +8,7 @@ packages:
   cardano-db-tool
   cardano-smash-server
   cardano-sync
+  backfill-cbor-datums
 
 constraints:
     libsystemd-journal >= 1.4.4

cardano-db-sync/cardano-db-sync.cabal

@@ -122,6 +122,8 @@ library
                       , persistent
                       , persistent-postgresql
                       , prometheus
+                      , plutus-ledger-api
+                      , serialise
                       , random-shuffle
                       , small-steps
                       , split

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs

@@ -7,6 +7,8 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Cardano.DbSync.Era.Shelley.Generic.Tx
   ( Tx (..)
   , TxCertificate (..)
@@ -76,6 +78,9 @@ import           Ouroboros.Consensus.Cardano.Block (StandardAllegra, StandardAlo
                    StandardMary, StandardShelley)
 import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBasedEra)
 
+import qualified Cardano.Binary as CBOR
+import qualified Plutus.V1.Ledger.Api as Plutus
+import           Codec.Serialise.Class (Serialise (..))
 
 data Tx = Tx
   { txHash :: !ByteString
@@ -150,8 +155,18 @@ data TxScript = TxScript
 data TxDatum = TxDatum
   { txDatumHash :: !ByteString
   , txDatumValue :: !ByteString -- we turn this into json later.
+  , txDatumBytes :: !ByteString
   }
 
+instance Api.SerialiseAsCBOR Api.ScriptData where
+  serialiseToCBOR = CBOR.serialize'
+
+instance CBOR.ToCBOR Api.ScriptData where
+  toCBOR = encode @Plutus.Data . Api.toPlutusData
+
+instance CBOR.FromCBOR Api.ScriptData where
+  fromCBOR = Api.fromPlutusData <$> decode @Plutus.Data
+
 fromAllegraTx :: (Word64, ShelleyTx.Tx StandardAllegra) -> Tx
 fromAllegraTx (blkIndex, tx) =
     Tx
@@ -539,19 +554,23 @@ fromAlonzoTx pp (blkIndex, tx) =
       , txRedeemerPurpose = tag
       , txRedeemerIndex = index
       , txRedeemerScriptHash = findScriptHash ptr
-      , txRedeemerDatum = TxDatum (getDataHash $ Alonzo.hashData dt) (encodeData dt)
+      , txRedeemerDatum = mkTxDatum (Alonzo.hashData dt, dt)
       }
 
-    encodeData :: Alonzo.Data StandardAlonzo -> ByteString
-    encodeData dt = LBS.toStrict $ Aeson.encode $
-      Api.scriptDataToJson Api.ScriptDataJsonDetailedSchema $ Api.fromAlonzoData dt
-
     txDataWitness :: [TxDatum]
     txDataWitness =
       mkTxDatum <$> Map.toList (Ledger.unTxDats $ Ledger.txdats' (getField @"wits" tx))
 
     mkTxDatum :: (Ledger.SafeHash StandardCrypto a, Alonzo.Data StandardAlonzo) -> TxDatum
-    mkTxDatum (dataHash, dt) = TxDatum (getDataHash dataHash) (encodeData dt)
+    mkTxDatum (dataHash, dt) = TxDatum (getDataHash dataHash) (jsonData dt) (cborData dt)
+      where
+        jsonData :: Alonzo.Data StandardAlonzo -> ByteString
+        jsonData = LBS.toStrict . Aeson.encode
+          . Api.scriptDataToJson Api.ScriptDataJsonDetailedSchema
+          . Api.fromAlonzoData
+
+        cborData :: Alonzo.Data StandardAlonzo -> ByteString
+        cborData = Api.serialiseToCBOR . Api.fromAlonzoData
 
     -- For 'Spend' script, we need to resolve the 'TxIn' to find the ScriptHash
     -- so we return 'Left TxIn' and resolve it later from the db. In other cases

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs

@@ -746,6 +746,7 @@ insertDatum tracer txId txd = do
       { DB.datumHash = Generic.txDatumHash txd
       , DB.datumTxId = txId
       , DB.datumValue = value
+      , DB.datumBytes = Just $ Generic.txDatumBytes txd
       }
 
 insertTxMetadata

cardano-db/src/Cardano/Db/Schema.hs

@@ -393,6 +393,7 @@ share
     hash                ByteString          sqltype=hash32type
     txId                TxId                OnDeleteCascade
     value               Text Maybe          sqltype=jsonb
+    bytes               ByteString Maybe    sqltype=bytea
     UniqueData          hash
 
   -- -----------------------------------------------------------------------------------------------
@@ -817,7 +818,8 @@ schemaDocs =
       "A table containing Plutus Data available in the blockchain, found in redeemers or witnesses"
       DatumHash # "The Hash of the Plutus Data"
       DatumTxId # "The Tx table index for the transaction where this script first became available."
-      DatumValue # "The actual data in json format"
+      DatumValue # "The actual data in JSON format (detailed schema)"
+      DatumBytes # "The actual data in CBOR format"
 
     ParamProposal --^ do
       "A table containing block chain parameter change proposals."

default.nix

@@ -22,7 +22,7 @@ let
       (selectProjectPackages cardanoDbSyncHaskellPackages);
 
   packages = {
-    inherit haskellPackages cardano-db-sync cardano-db-sync-extended cardano-node scripts dockerImage;
+    inherit haskellPackages cardano-db-sync cardano-db-sync-extended cardano-node scripts dockerImage backfill-cbor-datums;
 
     # so that eval time gc roots are cached (nix-tools stuff)
     inherit (cardanoDbSyncProject) roots plan-nix;

nix/pkgs.nix

@@ -29,6 +29,8 @@ in {
     cardano-db-tool;
   inherit (cardanoDbSyncHaskellPackages.cardano-node.components.exes)
       cardano-node;
+  inherit (cardanoDbSyncHaskellPackages.backfill-cbor-datums.components.exes)
+      backfill-cbor-datums;
 
   cabal = haskell-nix.tool compiler "cabal" {
     version = "latest";

schema/migration-2-0006-20220509.sql

@@ -0,0 +1,20 @@
+-- Persistent generated migration.
+
+CREATE FUNCTION migrate() RETURNS void AS $$
+DECLARE
+  next_version int ;
+BEGIN
+  SELECT stage_two + 1 INTO next_version FROM schema_version ;
+  IF next_version = 6 THEN
+    EXECUTE 'ALTER TABLE "datum" ADD COLUMN "bytes" bytea' ;
+
+    -- Hand written SQL statements can be added here.
+    UPDATE schema_version SET stage_two = next_version ;
+    RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ;
+  END IF ;
+END ;
+$$ LANGUAGE plpgsql ;
+
+SELECT migrate() ;
+
+DROP FUNCTION migrate() ;