diff --git a/morpho-checkpoint-node/src/Morpho/Ledger/Serialise.hs b/morpho-checkpoint-node/src/Morpho/Ledger/Serialise.hs index 9fbfe4cd..acc5b56f 100644 --- a/morpho-checkpoint-node/src/Morpho/Ledger/Serialise.hs +++ b/morpho-checkpoint-node/src/Morpho/Ledger/Serialise.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -16,8 +17,6 @@ module Morpho.Ledger.Serialise where import Cardano.Prelude -import Codec.CBOR.Decoding (Decoder) -import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (..)) import Control.Monad.Except @@ -178,33 +177,12 @@ instance (blk ~ MorphoBlock h c, BftCrypto c) => SerialiseNodeToClient blk (SomeSecond Query blk) where - encodeNodeToClient _ _ (SomeSecond q) = encodeMorphoQuery q - decodeNodeToClient _ _ = decodeMorphoQuery + encodeNodeToClient _ _ query = case query of + decodeNodeToClient _ _ = fail "Morpho doesn't support node-to-client queries" instance (blk ~ MorphoBlock h c, BftCrypto c) => SerialiseResult blk (Query blk) where - encodeResult _ _ = encodeMorphoResult - decodeResult _ _ = decodeMorphoResult - -encodeMorphoQuery :: Query (MorphoBlock h c) result -> CBOR.Encoding -encodeMorphoQuery query = case query of - GetDummy -> CBOR.encodeWord8 0 - -decodeMorphoQuery :: Decoder s (SomeSecond Query (MorphoBlock h c)) -decodeMorphoQuery = do - tag <- CBOR.decodeWord8 - case tag of - 0 -> return $ SomeSecond GetDummy - _ -> fail $ "decodeMorphoQuery: invalid tag " <> show tag - -encodeMorphoResult :: Query (MorphoBlock h c) result -> result -> CBOR.Encoding -encodeMorphoResult query = case query of - GetDummy -> encode - -decodeMorphoResult :: - Query (MorphoBlock h c) result -> - forall s. Decoder s result -decodeMorphoResult query = case query of - GetDummy -> decode + encodeResult _ _ query = case query of + decodeResult _ _ query = case query of diff --git a/morpho-checkpoint-node/src/Morpho/Ledger/Update.hs b/morpho-checkpoint-node/src/Morpho/Ledger/Update.hs index 7a76e1fd..a208dd00 100644 --- a/morpho-checkpoint-node/src/Morpho/Ledger/Update.hs +++ b/morpho-checkpoint-node/src/Morpho/Ledger/Update.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -25,7 +24,7 @@ module Morpho.Ledger.Update GenTx (..), LedgerState (..), MorphoStateDefaultConstraints, - Query (..), + Query, ExtractTxError (..), WontPushCheckpoint (..), Ticked (..), @@ -374,16 +373,15 @@ instance HasHardForkHistory (MorphoBlock h c) where QueryLedger -------------------------------------------------------------------------------} -data instance Query (MorphoBlock h c) :: Type -> Type where - GetDummy :: Query (MorphoBlock h c) () +data instance Query (MorphoBlock h c) :: Type -> Type deriving instance Show (Query (MorphoBlock h c) result) instance SameDepIndex (Query (MorphoBlock h c)) where - sameDepIndex GetDummy GetDummy = Just Refl + sameDepIndex query = case query of instance ShowQuery (Query (MorphoBlock h c)) where - showResult GetDummy = show + showResult query = case query of instance QueryLedger (MorphoBlock h c) where - answerQuery _ GetDummy _ = () + answerQuery _ query = case query of diff --git a/morpho-checkpoint-node/tests/Test/Morpho/Generators.hs b/morpho-checkpoint-node/tests/Test/Morpho/Generators.hs index 15d1ffc2..21514a62 100644 --- a/morpho-checkpoint-node/tests/Test/Morpho/Generators.hs +++ b/morpho-checkpoint-node/tests/Test/Morpho/Generators.hs @@ -152,12 +152,6 @@ instance Arbitrary (HeaderHash blk) => Arbitrary (ChainHash blk) where instance Arbitrary (SomeSecond (NestedCtxt Header) TestBlock) where arbitrary = return $ SomeSecond indexIsTrivial -instance Arbitrary (SomeSecond Query TestBlock) where - arbitrary = return $ SomeSecond GetDummy - -instance Arbitrary (SomeResult TestBlock) where - arbitrary = SomeResult GetDummy <$> arbitrary - instance Arbitrary (LedgerState TestBlock) where arbitrary = MorphoLedgerState <$> arbitrary diff --git a/morpho-checkpoint-node/tests/Test/Morpho/Serialisation.hs b/morpho-checkpoint-node/tests/Test/Morpho/Serialisation.hs index ae081a47..a3eced0c 100644 --- a/morpho-checkpoint-node/tests/Test/Morpho/Serialisation.hs +++ b/morpho-checkpoint-node/tests/Test/Morpho/Serialisation.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Morpho.Serialisation @@ -11,21 +12,30 @@ module Test.Morpho.Serialisation ) where +import Cardano.Prelude import Morpho.Ledger.Block import Morpho.Ledger.Serialise -import Ouroboros.Consensus.Node.Serialisation () import Ouroboros.Consensus.Util (Dict (..)) import Test.Morpho.Generators import Test.Tasty +import Test.Tasty.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Serialisation.Roundtrip -import Prelude serialiseTests :: TestTree serialiseTests = testGroup "Serialisation" - [ roundtrip_all testCodecCfg dictNestedHdr + [ testGroup "SerialiseDisk" $ roundtrip_SerialiseDisk testCodecCfg dictNestedHdr, + testGroup "SerialiseNodeToNode" $ roundtrip_SerialiseNodeToNode testCodecCfg, + -- We don't have any node-to-client queries, so we can't derive an Arbitrary instance for testing it + --, testGroup "SerialiseNodeToClient" $ roundtrip_SerialiseNodeToClient testCodecCfg + testProperty "envelopes" $ roundtrip_envelopes testCodecCfg, + testProperty "ConvertRawHash" $ roundtrip_ConvertRawHash (Proxy @TestBlock), + testProperty "hashSize" $ prop_hashSize (Proxy @TestBlock) + -- Currently the prop_estimateBlockSize is not exported by Test.Util.Serialisation.Roundtrip + -- TODO: Uncomment after https://github.com/input-output-hk/ouroboros-network/pull/2972 is included + --, testProperty "estimateBlockSize" $ prop_estimateBlockSize testCodecCfg ] where testCodecCfg :: CodecConfig TestBlock