diff --git a/cabal.project b/cabal.project index 107eeabd..9837bce0 100644 --- a/cabal.project +++ b/cabal.project @@ -5,8 +5,8 @@ index-state: 2024-02-01T00:00:00Z source-repository-package type: git location: https://github.com/kadena-io/chainweb-api.git - tag: 1b2de025cfdc09698bfb1ec3807cd85405d6a339 - --sha256: sha256-06jvD1kmkmthcRkyWhVLTbytwabghInxqXQD/Lm7kbA= + tag: fc84dcef8197bcfb5415c855421bb1921a749c9f + --sha256: sha256-2qpkAlpJ9qtfsD1WHuW5IYXWHoVXBxRYs5Pd9GOOXz8= package vault documentation: false @@ -14,6 +14,7 @@ package vault write-ghc-environment-files: never constraints: http2 <4.2 +constraints: configuration-tools >= 0.7.0 allow-newer: beam-migrate:pqueue allow-newer: beam-migrate:aeson diff --git a/haskell-src/chainweb-data.cabal b/haskell-src/chainweb-data.cabal index 42247801..e52b6ea7 100644 --- a/haskell-src/chainweb-data.cabal +++ b/haskell-src/chainweb-data.cabal @@ -74,6 +74,7 @@ library ChainwebDb.Types.Signer ChainwebDb.Types.Transaction ChainwebDb.Types.Transfer + ChainwebDb.Types.Verifier build-depends: base64-bytestring >=1.0 , cryptohash @@ -87,7 +88,7 @@ library , servant-client , servant-openapi3 , vector - , yet-another-logger + , yet-another-logger >= 0.4.2 if flag(ghc-flags) build-tool-depends: hsinspect:hsinspect -any @@ -151,7 +152,7 @@ executable chainweb-data , warp , warp-tls , witherable - , yet-another-logger + , yet-another-logger >= 0.4.2 other-modules: Chainweb.Backfill @@ -174,6 +175,7 @@ test-suite testsuite other-modules: Chainweb.Data.Test.Backfill Chainweb.Data.Test.Parser + Chainweb.Data.Test.Verifier build-depends: , aeson @@ -182,7 +184,11 @@ test-suite testsuite , chainweb-api , chainweb-data , containers >=0.6 + , directory + , lens + , lens-aeson , neat-interpolation >=0.5 + , optparse-applicative >=0.14 , tasty >=1.2 , tasty-hunit >=0.10 , text diff --git a/haskell-src/exec/Chainweb/Listen.hs b/haskell-src/exec/Chainweb/Listen.hs index 8d78fe77..19584be4 100644 --- a/haskell-src/exec/Chainweb/Listen.hs +++ b/haskell-src/exec/Chainweb/Listen.hs @@ -78,7 +78,7 @@ processNewHeader logTxSummaries env ph@(PowHeader h _) = do addendum = if S.null ts then "" else printf " with %d transactions" (S.length ts) when logTxSummaries $ do logg Debug $ fromString $ msg <> addendum - forM_ tos $ \txWithOutput -> + forM_ tos $ \txWithOutput -> logg Debug $ fromString $ show txWithOutput insertNewHeader (_nodeInfo_chainwebVer $ _env_nodeInfo env) (_env_dbConnPool env) ph pl @@ -91,10 +91,14 @@ insertNewHeader version pool ph pl = do !ss = concat $ map (mkTransactionSigners . fst) (_blockPayloadWithOutputs_transactionsWithOutputs pl) !k = bpwoMinerKeys pl - err = printf "insertNewHeader failed because we don't know how to work this version %s" version - withEventsMinHeight version err $ \minHeight -> do - let !tf = mkTransferRows (fromIntegral $ _blockHeader_height $ _hwp_header ph) (_blockHeader_chainId $ _hwp_header ph) (DbHash $ hashB64U $ _blockHeader_hash $ _hwp_header ph) (posixSecondsToUTCTime $ _blockHeader_creationTime $ _hwp_header ph) pl minHeight - writes pool b k t es ss tf + eventErr = printf "insertNewHeader failed to insert event row because we don't know how to work this version %s" version + verifierErr = printf "insertNewHeader failed to insert verifier row because we don't know how to work this version %s" version + withEventsMinHeight version eventErr $ \eventMinHeight -> + withVerifiersMinHeight version verifierErr $ \verifierMinHeight -> do + let currentHeight = fromIntegral $ _blockHeader_height $ _hwp_header ph + let !tf = mkTransferRows currentHeight (_blockHeader_chainId $ _hwp_header ph) (DbHash $ hashB64U $ _blockHeader_hash $ _hwp_header ph) (posixSecondsToUTCTime $ _blockHeader_creationTime $ _hwp_header ph) pl eventMinHeight + let !vs = concat $ map (mkTransactionVerifiers currentHeight verifierMinHeight . fst) (_blockPayloadWithOutputs_transactionsWithOutputs pl) + writes pool b k t es ss tf vs mkRequest :: UrlScheme -> ChainwebVersion -> Request mkRequest us (ChainwebVersion cv) = defaultRequest diff --git a/haskell-src/exec/Chainweb/Lookups.hs b/haskell-src/exec/Chainweb/Lookups.hs index 1bcd44e5..af11513d 100644 --- a/haskell-src/exec/Chainweb/Lookups.hs +++ b/haskell-src/exec/Chainweb/Lookups.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} @@ -20,6 +21,7 @@ module Chainweb.Lookups , mkBlockEventsWithCreationTime , mkCoinbaseEvents , mkTransactionSigners + , mkTransactionVerifiers , mkTransferRows , bpwoMinerKeys @@ -38,6 +40,7 @@ import Chainweb.Api.NodeInfo import Chainweb.Api.PactCommand import Chainweb.Api.Payload import Chainweb.Api.Sig +import qualified Chainweb.Api.Verifier as CW import qualified Chainweb.Api.Signer as CW import qualified Chainweb.Api.Transaction as CW import ChainwebData.Env @@ -49,6 +52,7 @@ import ChainwebDb.Types.Event import ChainwebDb.Types.Signer import ChainwebDb.Types.Transaction import ChainwebDb.Types.Transfer +import ChainwebDb.Types.Verifier import Control.Applicative import Control.Lens import Control.Monad @@ -278,6 +282,22 @@ mkTransactionSigners t = zipWith3 mkSigner signers sigs [0..] (PgJSONB $ map toJSON $ CW._signer_capList signer) (Signature $ unSig sig) +mkTransactionVerifiers :: Int64 -> Int -> CW.Transaction -> [Verifier] +mkTransactionVerifiers height verifierMinHeight t + | height < fromIntegral verifierMinHeight = [] + | otherwise = maybe [] (zipWith mkVerifier [0..]) verifiers + where + verifiers :: Maybe [CW.Verifier] + verifiers = _pactCommand_verifiers $ CW._transaction_cmd t + requestkey = CW._transaction_hash t + mkVerifier idx verifier = Verifier + { _verifier_requestkey = DbHash $ hashB64U requestkey + , _verifier_idx = idx + , _verifier_name = CW._verifier_name verifier + , _verifier_proof = (CW._verifier_proof verifier) ^? _String + , _verifier_caps = PgJSONB $ map toJSON $ CW._verifier_capList verifier + } + mkCoinbaseEvents :: Int64 -> ChainId -> DbHash BlockHash -> BlockPayloadWithOutputs -> [Event] mkCoinbaseEvents height cid blockhash pl = _blockPayloadWithOutputs_coinbase pl & coinbaseTO diff --git a/haskell-src/exec/Chainweb/Server.hs b/haskell-src/exec/Chainweb/Server.hs index 7c09d121..64e65231 100644 --- a/haskell-src/exec/Chainweb/Server.hs +++ b/haskell-src/exec/Chainweb/Server.hs @@ -63,6 +63,7 @@ import Chainweb.Api.Common (BlockHeight) import Chainweb.Api.StringEncoded (StringEncoded(..)) import qualified Chainweb.Api.Sig as Api import qualified Chainweb.Api.Signer as Api +import qualified Chainweb.Api.Verifier as Api import Chainweb.Coins import ChainwebDb.Database import ChainwebDb.Queries @@ -84,6 +85,7 @@ import ChainwebDb.Types.DbHash import ChainwebDb.Types.Signer import ChainwebDb.Types.Transfer import ChainwebDb.Types.Transaction +import ChainwebDb.Types.Verifier import ChainwebDb.Types.Event import ChainwebDb.BoundedScan ------------------------------------------------------------------------------ @@ -354,8 +356,9 @@ toApiTxDetail :: [Event] -> [Api.Signer] -> [Api.Sig] -> + Maybe [Api.Verifier] -> TxDetail -toApiTxDetail tx contHist blk evs signers sigs = TxDetail +toApiTxDetail tx contHist blk evs signers sigs verifiers = TxDetail { _txDetail_ttl = fromIntegral $ _tx_ttl tx , _txDetail_gasLimit = fromIntegral $ _tx_gasLimit tx , _txDetail_gasPrice = _tx_gasPrice tx @@ -387,6 +390,7 @@ toApiTxDetail tx contHist blk evs signers sigs = TxDetail , _txDetail_previousSteps = V.toList (chSteps contHist) <$ chCode contHist , _txDetail_signers = signers , _txDetail_sigs = sigs + , _txDetail_verifiers = verifiers } where unMaybeValue = maybe Null unPgJsonb @@ -436,9 +440,27 @@ queryTxsByKey logger rk c = let sigs = Api.Sig . unSignature . _signer_sig <$> dbSigners sameBlock tx ev = (unBlockId $ _tx_block tx) == (unBlockId $ _ev_block ev) + dbVerifiers <- runSelectReturningList $ select $ orderBy_ (asc_ . _verifier_idx) $ do + verifier <- all_ (_cddb_verifiers database) + guard_ (_verifier_requestkey verifier ==. val_ (DbHash rk)) + return verifier + + verifiers <- forM dbVerifiers $ \v -> do + caps <- forM (unPgJsonb $ _verifier_caps v) $ \capsJson -> case fromJSON capsJson of + A.Success a -> return a + A.Error e -> liftIO $ throwIO $ userError $ "Failed to parse signer capabilities: " <> e + proof <- case _verifier_proof v of + Just s -> return $ A.String s + Nothing -> liftIO $ throwIO $ userError $ "Verifier proof doesn't exist?" + return $ Api.Verifier + { Api._verifier_name = _verifier_name v + , Api._verifier_proof = proof + , Api._verifier_capList = caps + } + return $ (`fmap` r) $ \(tx,contHist, blk) -> let evsInTxBlock = filter (sameBlock tx) evs - in toApiTxDetail tx contHist blk evsInTxBlock signers sigs + in toApiTxDetail tx contHist blk evsInTxBlock signers sigs (verifiers <$ guard (not $ null verifiers)) queryTxsByPactId :: LogFunctionIO Text -> Limit -> Text -> Connection -> IO [TxSummary] queryTxsByPactId logger limit pactid c = diff --git a/haskell-src/exec/Chainweb/Worker.hs b/haskell-src/exec/Chainweb/Worker.hs index 57f4ee13..fd84d330 100644 --- a/haskell-src/exec/Chainweb/Worker.hs +++ b/haskell-src/exec/Chainweb/Worker.hs @@ -28,6 +28,7 @@ import ChainwebDb.Types.MinerKey import ChainwebDb.Types.Signer import ChainwebDb.Types.Transaction import ChainwebDb.Types.Transfer +import ChainwebDb.Types.Verifier import Control.Lens (iforM_) import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as B16 @@ -47,8 +48,8 @@ import Database.PostgreSQL.Simple.Transaction (withTransaction,withSav -- | Write a Block and its Transactions to the database. Also writes the Miner -- if it hasn't already been via some other block. -writes :: P.Pool Connection -> Block -> [T.Text] -> [Transaction] -> [Event] -> [Signer] -> [Transfer] -> IO () -writes pool b ks ts es ss tf = P.withResource pool $ \c -> withTransaction c $ do +writes :: P.Pool Connection -> Block -> [T.Text] -> [Transaction] -> [Event] -> [Signer] -> [Transfer] -> [Verifier] -> IO () +writes pool b ks ts es ss tf vs = P.withResource pool $ \c -> withTransaction c $ do runBeamPostgres c $ do -- Write the Block if unique -- runInsert @@ -75,6 +76,9 @@ writes pool b ks ts es ss tf = P.withResource pool $ \c -> withTransaction c $ d runInsert $ insert (_cddb_transfers database) (insertValues tf) $ onConflict (conflictingFields primaryKey) onConflictDoNothing + runInsert + $ insert (_cddb_verifiers database) (insertValues vs) + $ onConflict (conflictingFields primaryKey) onConflictDoNothing -- liftIO $ printf "[OKAY] Chain %d: %d: %s %s\n" -- (_block_chainId b) -- (_block_height b) @@ -89,8 +93,9 @@ batchWrites -> [[Event]] -> [[Signer]] -> [[Transfer]] + -> [[Verifier]] -> IO () -batchWrites pool bs kss tss ess sss tfs = P.withResource pool $ \c -> withTransaction c $ do +batchWrites pool bs kss tss ess sss tfs vss = P.withResource pool $ \c -> withTransaction c $ do runBeamPostgres c $ do -- Write the Blocks if unique @@ -124,6 +129,10 @@ batchWrites pool bs kss tss ess sss tfs = P.withResource pool $ \c -> withTransa $ insert (_cddb_transfers database) (insertValues $ concat tfs) $ onConflict (conflictingFields primaryKey) onConflictDoNothing + runInsert + $ insert (_cddb_verifiers database) (insertValues $ concat vss) + $ onConflict (conflictingFields primaryKey) onConflictDoNothing + asPow :: BlockHeader -> PowHeader asPow bh = PowHeader bh (T.decodeUtf8 . B16.encode . B.reverse . unHash $ powHash bh) @@ -139,11 +148,16 @@ writeBlock env pool count (bh, pwo) = do !ss = concat $ map (mkTransactionSigners . fst) (_blockPayloadWithOutputs_transactionsWithOutputs pwo) version = _nodeInfo_chainwebVer $ _env_nodeInfo env !k = bpwoMinerKeys pwo - err = printf "writeBlock failed because we don't know how to work this version %s" version - withEventsMinHeight version err $ \evMinHeight -> do - let !tf = mkTransferRows (fromIntegral $ _blockHeader_height bh) (_blockHeader_chainId bh) (DbHash $ hashB64U $ _blockHeader_hash bh) (posixSecondsToUTCTime $ _blockHeader_creationTime bh) pwo evMinHeight + eventErr = printf "writeBlock failed to write event and transfer rows because we don't know how to work this version %s" version + verifierErr = printf "writeBlock failed to write verifier row because we don't know how to work this version %s" version + withEventsMinHeight version eventErr $ \evMinHeight -> + withVerifiersMinHeight version verifierErr $ \verifierMinHeight -> do + let currentHeight = fromIntegral $ _blockHeader_height bh + !tf = mkTransferRows currentHeight (_blockHeader_chainId bh) (DbHash $ hashB64U $ _blockHeader_hash bh) (posixSecondsToUTCTime $ _blockHeader_creationTime bh) pwo evMinHeight + let !vs = concat $ map (mkTransactionVerifiers currentHeight verifierMinHeight . fst) (_blockPayloadWithOutputs_transactionsWithOutputs pwo) + atomicModifyIORef' count (\n -> (n+1, ())) - writes pool b k t es ss tf + writes pool b k t es ss tf vs writeBlocks :: Env -> P.Pool Connection -> IORef Int -> [(BlockHeader, BlockPayloadWithOutputs)] -> IO () writeBlocks env pool count blocks = do @@ -160,10 +174,15 @@ writeBlocks env pool count blocks = do (makeBlockMap bhs') !sss = M.intersectionWith (\pl _ -> concat $ mkTransactionSigners . fst <$> _blockPayloadWithOutputs_transactionsWithOutputs pl) pls (makeBlockMap bhs') !kss = M.intersectionWith (\p _ -> bpwoMinerKeys p) pls (makeBlockMap bhs') - err = printf "writeBlocks failed because we don't know how to work this version %s" version - withEventsMinHeight version err $ \evMinHeight -> do - let !tfs = M.intersectionWith (\pl bh -> mkTransferRows (fromIntegral $ _blockHeader_height bh) (_blockHeader_chainId bh) (DbHash $ hashB64U $ _blockHeader_hash bh) (posixSecondsToUTCTime $ _blockHeader_creationTime bh) pl evMinHeight) pls (makeBlockMap bhs') - batchWrites pool (M.elems bs) (M.elems kss) (M.elems tss) (M.elems ess) (M.elems sss) (M.elems tfs) + eventErr = printf "writeBlocks failed to write event and transfer rows because we don't know how to work this version %s" version + verifierErr = printf "writeBlocks failed to write verifier row because we don't know how to work this version %s" version + withEventsMinHeight version eventErr $ \evMinHeight -> + withVerifiersMinHeight version verifierErr $ \verifierMinHeight -> do + let currentHeight bh = fromIntegral $ _blockHeader_height bh + !tfs = M.intersectionWith (\pl bh -> mkTransferRows (currentHeight bh) (_blockHeader_chainId bh) (DbHash $ hashB64U $ _blockHeader_hash bh) (posixSecondsToUTCTime $ _blockHeader_creationTime bh) pl evMinHeight) pls (makeBlockMap bhs') + !vss = M.intersectionWith (\pl bh -> concat $ mkTransactionVerifiers (currentHeight bh) verifierMinHeight . fst <$> _blockPayloadWithOutputs_transactionsWithOutputs pl) pls (makeBlockMap bhs') + + batchWrites pool (M.elems bs) (M.elems kss) (M.elems tss) (M.elems ess) (M.elems sss) (M.elems tfs) (M.elems vss) atomicModifyIORef' count (\n -> (n + numWrites, ())) where @@ -186,21 +205,28 @@ writePayload -> IO () writePayload pool chain blockHash blockHeight version creationTime bpwo = do let (cbEvents, txEvents) = mkBlockEvents' blockHeight chain blockHash bpwo - err = printf "writePayload failed because we don't know how to work this version %s" version - withEventsMinHeight version err $ \evMinHeight -> do - let !tfs = mkTransferRows blockHeight chain blockHash creationTime bpwo evMinHeight - P.withResource pool $ \c -> - withTransaction c $ do - runBeamPostgres c $ do - runInsert - $ insert (_cddb_events database) (insertValues $ cbEvents ++ concatMap snd txEvents) - $ onConflict (conflictingFields primaryKey) onConflictDoNothing - runInsert - $ insert (_cddb_transfers database) (insertValues tfs) - $ onConflict (conflictingFields primaryKey) onConflictDoNothing - withSavepoint c $ runBeamPostgres c $ - forM_ txEvents $ \(reqKey, events) -> - runUpdate - $ update (_cddb_transactions database) - (\tx -> _tx_numEvents tx <-. val_ (Just $ fromIntegral $ length events)) - (\tx -> _tx_requestKey tx ==. val_ reqKey) + eventErr = printf "writePayload failed to insert event and transfer rows because we don't know how to work this version %s" version + verifierErr = printf "writePayload failed to insert verifier row because we don't know how to work this version %s" version + withEventsMinHeight version eventErr $ \evMinHeight -> + withVerifiersMinHeight version verifierErr $ \verifierMinHeight -> do + let !tfs = mkTransferRows blockHeight chain blockHash creationTime bpwo evMinHeight + let !vss = concat $ map (mkTransactionVerifiers blockHeight verifierMinHeight . fst) $ _blockPayloadWithOutputs_transactionsWithOutputs bpwo + P.withResource pool $ \c -> + withTransaction c $ do + runBeamPostgres c $ do + runInsert + $ insert (_cddb_events database) (insertValues $ cbEvents ++ concatMap snd txEvents) + $ onConflict (conflictingFields primaryKey) onConflictDoNothing + runInsert + $ insert (_cddb_transfers database) (insertValues tfs) + $ onConflict (conflictingFields primaryKey) onConflictDoNothing + -- TODO: This might be necessary. Will need to think about this further + runInsert + $ insert (_cddb_verifiers database) (insertValues vss) + $ onConflict (conflictingFields primaryKey) onConflictDoNothing + withSavepoint c $ runBeamPostgres c $ + forM_ txEvents $ \(reqKey, events) -> + runUpdate + $ update (_cddb_transactions database) + (\tx -> _tx_numEvents tx <-. val_ (Just $ fromIntegral $ length events)) + (\tx -> _tx_requestKey tx ==. val_ reqKey) diff --git a/haskell-src/lib/ChainwebData/Spec.hs b/haskell-src/lib/ChainwebData/Spec.hs index 666a669b..8a0ebc5d 100644 --- a/haskell-src/lib/ChainwebData/Spec.hs +++ b/haskell-src/lib/ChainwebData/Spec.hs @@ -25,7 +25,9 @@ import Servant.OpenApi import ChainwebData.Pagination import Chainweb.Api.ChainId import Chainweb.Api.Sig +import Chainweb.Api.SigCapability import Chainweb.Api.Signer +import Chainweb.Api.Verifier import ChainwebData.TxSummary import Data.OpenApi @@ -115,6 +117,18 @@ instance ToSchema (StringEncoded Scientific) where & example ?~ A.String "-1234.5e6" & pattern ?~ "[-+]?[0-9]*\\.?[0-9]+([eE][-+]?[0-9]+)?" -spec :: OpenApi -spec = toOpenApi (Proxy :: Proxy ChainwebDataApi) +instance ToSchema Verifier where + declareNamedSchema _ = do + textSchema <- declareSchemaRef (Proxy :: Proxy T.Text) + sigCapabilitySchema <- declareSchemaRef (Proxy :: Proxy [SigCapability]) + return $ NamedSchema (Just "Verifier") $ mempty + & type_ ?~ OpenApiObject + & properties + .~ [ ("name", textSchema) + , ("proof", textSchema) + , ("clist", sigCapabilitySchema) + ] + & required .~ ["pubKey", "clist"] +spec :: OpenApi +spec = toOpenApi (Proxy :: Proxy ChainwebDataApi) \ No newline at end of file diff --git a/haskell-src/lib/ChainwebData/Types.hs b/haskell-src/lib/ChainwebData/Types.hs index 56178f00..e156b315 100644 --- a/haskell-src/lib/ChainwebData/Types.hs +++ b/haskell-src/lib/ChainwebData/Types.hs @@ -18,6 +18,7 @@ module ChainwebData.Types , rangeToDescGroupsOf , blockRequestSize , withEventsMinHeight + , withVerifiersMinHeight ) where import BasePrelude @@ -125,3 +126,17 @@ withEventsMinHeight version errorMessage action = withVersion version onVersion "recap-development" -> Just 14 "development" -> Just 0 _ -> Nothing + + +withVerifiersMinHeight :: Num a => MonadIO m => T.Text -> String -> (a -> m b) -> m b +withVerifiersMinHeight version errorMessage action = withVersion version onVersion $ \case + Just height -> action height + Nothing -> liftIO $ die errorMessage + where + -- Associate each version with the fork height for ChainwebPact223 + onVersion = \case + "mainnet01" -> Just 4_577_530 + "testnet04" -> Just 4_100_681 + "recap-development" -> Just 600 + "development" -> Just 0 + _ -> Nothing diff --git a/haskell-src/lib/ChainwebDb/Database.hs b/haskell-src/lib/ChainwebDb/Database.hs index 38ed007f..5143d684 100644 --- a/haskell-src/lib/ChainwebDb/Database.hs +++ b/haskell-src/lib/ChainwebDb/Database.hs @@ -24,6 +24,7 @@ import ChainwebDb.Types.MinerKey import ChainwebDb.Types.Signer import ChainwebDb.Types.Transaction import ChainwebDb.Types.Transfer +import ChainwebDb.Types.Verifier import qualified Data.Pool as P import Data.Text (Text) import qualified Data.Text as T @@ -41,6 +42,7 @@ data ChainwebDataDb f = ChainwebDataDb , _cddb_events :: f (TableEntity EventT) , _cddb_signers :: f (TableEntity SignerT) , _cddb_transfers :: f (TableEntity TransferT) + , _cddb_verifiers :: f (TableEntity VerifierT) } deriving stock (Generic) deriving anyclass (Database be) @@ -137,6 +139,14 @@ database = defaultDbSettings `withDbModification` dbModification , _tr_amount = "amount" , _tr_block = BlockId "block" } + , _cddb_verifiers = modifyEntityName modTableName <> + modifyTableFields tableModification + { _verifier_requestkey = "requestkey" + , _verifier_idx = "idx" + , _verifier_name = "name" + , _verifier_proof = "proof" + , _verifier_caps = "caps" + } } withDb :: Env -> Pg b -> IO b diff --git a/haskell-src/lib/ChainwebDb/Types/Verifier.hs b/haskell-src/lib/ChainwebDb/Types/Verifier.hs new file mode 100644 index 00000000..eeb4e84c --- /dev/null +++ b/haskell-src/lib/ChainwebDb/Types/Verifier.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module ChainwebDb.Types.Verifier where + +------------------------------------------------------------------------------ +import Data.Aeson +import Data.Int +import Data.Text (Text) +import Database.Beam +import Database.Beam.Backend.SQL.Row () +import Database.Beam.Backend.SQL.SQL92 () +import Database.Beam.Postgres +------------------------------------------------------------------------------ +import ChainwebDb.Types.DbHash +------------------------------------------------------------------------------ + + +data VerifierT f = Verifier + { _verifier_requestkey :: C f (DbHash TxHash) + , _verifier_idx :: C f Int32 + , _verifier_name :: C f (Maybe Text) + , _verifier_proof :: C f (Maybe Text) + , _verifier_caps :: C f (PgJSONB [Value]) + } + deriving stock (Generic) + deriving anyclass (Beamable) + +type Verifier = VerifierT Identity +type VerifierId = PrimaryKey VerifierT Identity + +instance Table VerifierT where + data PrimaryKey VerifierT f = VerifierT (C f (DbHash TxHash)) (C f Int32) + deriving stock (Generic) + deriving anyclass (Beamable) + primaryKey = VerifierT <$> _verifier_requestkey <*> _verifier_idx diff --git a/haskell-src/test/Chainweb/Data/Test/Verifier.hs b/haskell-src/test/Chainweb/Data/Test/Verifier.hs new file mode 100644 index 00000000..777d6344 --- /dev/null +++ b/haskell-src/test/Chainweb/Data/Test/Verifier.hs @@ -0,0 +1,107 @@ +{-# language LambdaCase #-} +{-# language OverloadedStrings #-} +{-# language RecordWildCards #-} +{-# language TypeApplications #-} +module Chainweb.Data.Test.Verifier +( tests +) where + +import Control.Exception +import Control.Lens +import Control.Monad +import qualified Data.Aeson as A +import Data.Aeson.KeyMap (fromList) +import Data.Aeson.Lens +import qualified Data.ByteString.Lazy as BL +import Data.Maybe +import Data.List +import System.Directory +import Text.Printf + +import Options.Applicative + +import Chainweb.Api.PactCommand +import Chainweb.Api.Transaction +import Chainweb.Api.Verifier +-- import Chainweb.Data.Test.Utils + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup "Verifier plugin tests" + [parseVerifier + , parseVerifierFromCommandTextCWApi + , parseVerifierFromCommandText] + + +parseVerifier :: TestTree +parseVerifier = testCase "verifier decoding test" $ do + mfile <- findFile ["./haskell-src/test","./test"] "test-verifier.txt" + case mfile of + Just file -> do + rawFile <- BL.readFile file + either (throwIO . userError) (expectedValue @=?) $ A.eitherDecode @Verifier rawFile + Nothing -> assertFailure (failureMsg ["./haskell-src/test","./test"] "test-verifier.txt") + where + expectedValue = + Verifier + {_verifier_name = Just "allow" + , _verifier_proof = A.Object (fromList [("keysetref",A.Object (fromList [("ksn",A.String "\120167\&4hy3@un~\185384tYM|y_"),("ns",A.String "?k%B\96883\153643\38839\68129P\139946=\97190$Wk\95172es8QQVIu\197146ypX")]))]) + , _verifier_capList = [] + } + +parseVerifierFromCommandTextCWApi :: TestTree +parseVerifierFromCommandTextCWApi = testCase "Command Text verifier decoding test with CW-API" $ do + mfile <- findFile ["./haskell-src/test","./test"] "command-text-with-verifier.txt" + case mfile of + Just file -> do + rawFile <- BL.readFile file + either (throwIO . userError) (expectedValue @=?) $ + -- assume verifiers field is a Just value + fromJust . _pactCommand_verifiers . _transaction_cmd <$> A.eitherDecode @Transaction rawFile + Nothing -> assertFailure (failureMsg ["./haskell-src/test","./test"] "command-text-with-verifier.txt") + where + expectedValue = + [Verifier + {_verifier_name = Just "allow" + , _verifier_proof = A.String "emmanuel" + , _verifier_capList = [] + }] + +parseVerifierFromCommandText :: TestTree +parseVerifierFromCommandText = testCase "Command Text verifier decoding test" $ do + mfile <- findFile ["./haskell-src/test","./test"] "command-text-with-verifier.txt" + case mfile of + Just file -> do + rawFile <- BL.readFile file + either (throwIO . userError) (expectedValue @=?) $ + A.eitherDecode @A.Value rawFile >>= \r -> + r ^? key "cmd" . _String . key "verifiers" . _JSON + & note verifyMsg + Nothing -> assertFailure (failureMsg ["./haskell-src/test","./test"] "command-text-with-verifier.txt") + where + verifyMsg = "Can't find expected verifiers key command text" + note msg = maybe (Left msg) Right + expectedValue = + [Verifier + {_verifier_name = Just "allow" + , _verifier_proof = A.String "emmanuel" + , _verifier_capList = [] + }] + +failureMsg :: [FilePath] -> FilePath -> String +failureMsg dirs s = printf "This file %s was not found in either of these directories %s" s (intercalate "," dirs) + +-- TODO: Maybe come back to this later +-- findVerifiers :: FilePath -> TestTree +-- findVerifiers path = +-- withResource (mkOpts modernDefaultOptions) freeOpts $ \opts' -> +-- withResource (open opts' path) closeRocksDb test +-- where +-- open opts' path = do +-- Options'{..} <- opts' +-- openReadOnlyRocksDb path _optsPtr +-- test _iordb = testCase "inner" $ assertEqual "testing" 1 1 + diff --git a/haskell-src/test/Main.hs b/haskell-src/test/Main.hs index 557fccf5..b8bf5137 100644 --- a/haskell-src/test/Main.hs +++ b/haskell-src/test/Main.hs @@ -5,12 +5,18 @@ module Main import Chainweb.Data.Test.Parser as Parser import Chainweb.Data.Test.Backfill as Backfill +import Chainweb.Data.Test.Verifier as Verifier +-- import Chainweb.Data.Test.Utils import Test.Tasty +import Test.Tasty.Options +import Data.Proxy +import Debug.Trace main :: IO () main = defaultMain $ testGroup "Chainweb Data Test suite" [ Parser.tests , Backfill.tests + , Verifier.tests ] diff --git a/haskell-src/test/command-text-with-verifier.txt b/haskell-src/test/command-text-with-verifier.txt new file mode 100644 index 00000000..2c1888bd --- /dev/null +++ b/haskell-src/test/command-text-with-verifier.txt @@ -0,0 +1,2 @@ +{"hash":"bq-o2qG2gF50itBxmPltD9OCTV0wSnMTydUoEnH8LC0","sigs":[],"cmd":"{\"verifiers\":[{\"proof\":\"emmanuel\",\"name\":\"allow\",\"clist\":[]}],\"networkId\":null,\"payload\":{\"exec\":{\"data\":null,\"code\":\"(+ 1 1)\"}},\"signers\":[],\"meta\":{\"creationTime\":0,\"ttl\":28800,\"gasLimit\":1000,\"chainId\":\"0\",\"gasPrice\":1.0e-7,\"sender\":\"sender00\"},\"nonce\":\"2024-04-17 07:49:29.788988 UTC\"}"} + diff --git a/haskell-src/test/test-verifier.txt b/haskell-src/test/test-verifier.txt new file mode 100644 index 00000000..21db2856 --- /dev/null +++ b/haskell-src/test/test-verifier.txt @@ -0,0 +1,2 @@ +{"name":"allow","proof":{"keysetref":{"ns":"?k%B𗩳𥠫鞷𐨡P𢊪=𗮦$Wk𗏄es8QQVIu𰈚ypX","ksn":"𝕧4hy3@un~𭐨tYM|y_"}},"clist":[]} +