start repairing tests comparing arbitrary json with json-schema.

ogmios-server/package.yaml

@@ -117,18 +117,15 @@ tests:
     - -rtsopts
     - -with-rtsopts=-N
     dependencies:
-    - aeson
-    - aeson-pretty
-    - bytestring
-    - cardano-ledger
-    - cardano-ledger-test
+    - cardano-client
     - generic-arbitrary
     - hedgehog-quickcheck
-    - hjsonschema
     - hspec
+    - hspec-json-schema
+    - json-wsp
     - ogmios
-    - ouroboros-consensus-byron
-    - ouroboros-consensus-byron-test
+    - ouroboros-consensus-cardano-test
+    - ouroboros-consensus-shelley
+    - ouroboros-consensus-shelley-test
     - ouroboros-network
     - QuickCheck
-    - text

ogmios-server/test/unit/Ogmios/BridgeSpec.hs

@@ -4,11 +4,13 @@
 
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -18,47 +20,23 @@ module Ogmios.BridgeSpec
 
 import Prelude
 
-import Cardano.Chain.Byron.API
-    ( ApplyMempoolPayloadErr (..) )
-import Cardano.Chain.UTxO.Validation
-    ( UTxOValidationError )
-import Data.Aeson
-    ( ToJSON (..) )
-import Data.String
-    ( IsString )
-import Data.Text
-    ( Text )
-import JSONSchema.Draft4
-    ( Schema (..)
-    , SchemaWithURI (..)
-    , ValidatorFailure (..)
-    , checkSchema
-    , emptySchema
-    , referencesViaFilesystem
-    )
-import JSONSchema.Validator.Draft4.Any
-    ( OneOfInvalid (..), RefInvalid (..) )
-import JSONSchema.Validator.Draft4.Object
-    ( PropertiesRelatedInvalid (..) )
+import Cardano.Network.Protocol.NodeToClient
+    ( Block )
 import Ogmios.Bridge
     ( FindIntersectResponse (..)
     , RequestNextResponse (..)
     , SubmitTxResponse (..)
     )
-import Ouroboros.Consensus.Byron.Ledger
-    ( ByronBlock )
-import Ouroboros.Network.Block
-    ( BlockNo (..), Point (..), Tip (..), blockPoint, legacyTip )
-import Ouroboros.Network.Protocol.LocalTxSubmission.Type
-    ( SubmitResult (..) )
-import Test.Cardano.Chain.UTxO.Gen
-    ( genUTxOValidationError )
 import Test.Hspec
     ( Spec, SpecWith, describe, it )
+import Test.Hspec.Json.Schema
+    ( validateToJSON )
 import Test.QuickCheck
     ( Arbitrary (..)
+    , Gen
     , Positive (..)
     , Property
+    , choose
     , counterexample
     , genericShrink
     , oneof
@@ -72,91 +50,36 @@ import Test.QuickCheck.Hedgehog
 import Test.QuickCheck.Monadic
     ( assert, monadicIO, monitor, run )
 
-import Cardano.Byron.Types.Json.Orphans
-    ()
-import Test.Consensus.Byron.Generators
+import Cardano.Types.Json.Orphans
     ()
 
-import qualified Codec.Json.Wsp.Handler as Wsp
-import qualified Data.Aeson as Json
-import qualified Data.Aeson.Encode.Pretty as Json
-import qualified Data.ByteString.Lazy.Char8 as BL8
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Text as T
+-- import Test.Consensus.Shelley.Generators
+--     ()
 
-spec :: Spec
-spec =
-    describe "validate ToJSON instances against JSON-schema" $ do
-        test (validateAllToJSON @(FindIntersectResponse ByronBlock))
-            "ogmios.wsp.json#/properties/FindIntersectResponse"
-        test (validateAllToJSON @(RequestNextResponse ByronBlock))
-            "ogmios.wsp.json#/properties/RequestNextResponse"
-        test (validateAllToJSON @(SubmitTxResponse ApplyMempoolPayloadErr))
-            "ogmios.wsp.json#/properties/SubmitTxResponse"
-
---
--- Helpers
---
+import qualified Codec.Json.Wsp.Handler as Wsp
 
-newtype SchemaRef = SchemaRef
-    { getSchemaRef :: Text }
-    deriving (Show, IsString)
-
-validateAllToJSON
-    :: ToJSON (Wsp.Response a)
-    => SchemaRef
-    -> Wsp.Response a
-    -> Property
-validateAllToJSON ref a = monadicIO $ do
-    let json = toJSON a
-    errors <- run $ validateSchema ref json
-    monitor $ counterexample $ unlines
-        [ "json:", BL8.unpack $ Json.encodePretty json ]
-    monitor $ counterexample $ unlines
-        (prettyFailure <$> errors)
-    assert (null errors)
-
-validateSchema :: SchemaRef -> Json.Value -> IO [ValidatorFailure]
-validateSchema (SchemaRef ref) value = do
-    let schema = SchemaWithURI (emptySchema { _schemaRef = Just ref }) Nothing
-    refs <- unsafeIO =<< referencesViaFilesystem schema
-    validate <- unsafeIO (checkSchema refs schema)
-    pure $ validate value
-  where
-    unsafeIO :: Show e => Either e a -> IO a
-    unsafeIO = either (fail . show) pure
-
-test
-    :: forall a. (Arbitrary a, Show a)
-    => (SchemaRef -> a -> Property)
-    -> SchemaRef
-    -> SpecWith ()
-test prop ref =
-    it (T.unpack $ getSchemaRef ref) $ withMaxSuccess 100 $ property $ prop ref
-
-prettyFailure
-    :: ValidatorFailure
-    -> String
-prettyFailure = \case
-    FailureRef (RefInvalid _ schema errs) -> unlines
-        [ "schema:", BL8.unpack $ Json.encodePretty schema
-        , "errors:", unlines $ indent $ prettyFailure <$> NE.toList errs
-        ]
+import Ouroboros.Consensus.Shelley.Ledger.Block
+    ( ShelleyBlock )
+import Ouroboros.Consensus.Shelley.Protocol.Crypto
+    ( StandardCrypto )
+import Ouroboros.Network.Block
+    ( BlockNo (..), HeaderHash, Point (..), SlotNo (..), Tip (..) )
 
-    FailureOneOf (NoSuccesses xs _) ->
-        unlines $ concatMap (fmap prettyFailure . NE.toList . snd) $ NE.toList xs
+import Test.Consensus.Cardano.Generators
+    ()
 
-    FailurePropertiesRelated (PropertiesRelatedInvalid prop reg extra) -> unlines
-        [ "properties: " <> show prop
-        , "pattern: " <> show reg
-        , "additional: " <> show extra
-        ]
+import qualified Ouroboros.Network.Point as Point
 
-    anythingElse ->
-        show anythingElse
+spec :: Spec
+spec =
+    describe "validate ToJSON instances against JSON-schema" $ do
+        validateToJSON (arbitrary @(Wsp.Response (FindIntersectResponse Block)))
+            "../ogmios.wsp.json#/properties/FindIntersectResponse"
 
-  where
-    indent xs = ("    " <>) <$> xs
+--        test (validateAllToJSON @(RequestNextResponse ByronBlock))
+--            "ogmios.wsp.json#/properties/RequestNextResponse"
+--        test (validateAllToJSON @(SubmitTxResponse ApplyMempoolPayloadErr))
+--            "ogmios.wsp.json#/properties/SubmitTxResponse"
 
 --
 -- Instances
@@ -165,25 +88,43 @@ prettyFailure = \case
 instance Arbitrary a => Arbitrary (Wsp.Response a) where
     arbitrary = Wsp.Response Nothing <$> arbitrary
 
-instance Arbitrary (FindIntersectResponse ByronBlock) where
+instance Arbitrary (FindIntersectResponse Block) where
     shrink = genericShrink
     arbitrary = genericArbitrary
 
-instance Arbitrary (RequestNextResponse ByronBlock) where
-    shrink = genericShrink
-    arbitrary = genericArbitrary
+-- instance Arbitrary (RequestNextResponse ByronBlock) where
+--     shrink = genericShrink
+--     arbitrary = genericArbitrary
+--
+-- instance Arbitrary (SubmitTxResponse ApplyMempoolPayloadErr) where
+--     arbitrary = oneof
+--         [ pure (SubmitTxResponse SubmitSuccess)
+--         , SubmitTxResponse . SubmitFail. MempoolTxErr <$> arbitrary
+--         ]
+
+-- instance Arbitrary UTxOValidationError where
+--     arbitrary = hedgehog genUTxOValidationError
+
+instance Arbitrary (Point Block) where
+    arbitrary = oneof
+        [ pure (Point Point.Origin)
+        , Point . Point.At <$> genPoint
+        ]
 
-instance Arbitrary (SubmitTxResponse ApplyMempoolPayloadErr) where
+instance Arbitrary (Tip Block) where
     arbitrary = oneof
-        [ pure (SubmitTxResponse SubmitSuccess)
-        , SubmitTxResponse . SubmitFail. MempoolTxErr <$> arbitrary
+        [ pure TipGenesis
+        , Tip <$> genSlotNo <*> genHeaderHash <*> genBlockNo
         ]
 
-instance Arbitrary (Point ByronBlock) where
-    arbitrary = blockPoint <$> arbitrary
+genSlotNo :: Gen SlotNo
+genSlotNo = SlotNo <$> choose (1, 100000)
+
+genBlockNo :: Gen BlockNo
+genBlockNo = BlockNo <$> arbitrary
 
-instance Arbitrary (Tip ByronBlock) where
-    arbitrary = legacyTip <$> arbitrary <*> arbitrary
+genHeaderHash :: Gen (HeaderHash Block)
+genHeaderHash = arbitrary
 
-instance Arbitrary UTxOValidationError where
-    arbitrary = hedgehog genUTxOValidationError
+genPoint :: Gen (Point.Block SlotNo (HeaderHash Block))
+genPoint = Point.Block <$> genSlotNo <*> genHeaderHash

ogmios.wsp.json

@@ -654,14 +654,20 @@
     }
 
   , "Tip":
-    { "type": "object"
-    , "additionalProperties": false
-    , "required": [ "slot", "hash", "blockNo" ]
-    , "properties":
-      { "slot": { "$ref": "#/definitions/Slot" }
-      , "hash": { "$ref": "#/definitions/Hash16" }
-      , "blockNo": { "$ref": "#/definitions/BlockNo" }
-      }
+    { "oneOf":
+      [ { "type": "string"
+        , "enum": [ "origin" ]
+        }
+      , { "type": "object"
+        , "additionalProperties": false
+        , "required": [ "slot", "hash", "blockNo" ]
+        , "properties":
+          { "slot": { "$ref": "#/definitions/Slot" }
+          , "hash": { "$ref": "#/definitions/Hash16" }
+          , "blockNo": { "$ref": "#/definitions/BlockNo" }
+          }
+        }
+      ]
     }
 
   , "Tx":

snapshot.Dockerfile

@@ -9,21 +9,23 @@ RUN apt-get update && apt-get install --no-install-recommends -y \
   git=1:2.11.* \
   libgmp-dev=2:6.1.* \
   libssl-dev=1.1.* \
+  libpcre3-dev=2:8.* \
   libsystemd-dev=232-* \
   libsodium-dev=1.0.* \
   zlib1g-dev=1:1.2.*
 
 RUN stack upgrade --binary-version 2.1.3
 
-COPY modules/cardano-client/package.yaml   modules/cardano-client/package.yaml
-COPY modules/git-th/package.yaml           modules/git-th/package.yaml
-COPY modules/json-wsp/package.yaml         modules/json-wsp/package.yaml
-COPY modules/manufacture/package.yaml      modules/manufacture/package.yaml
-COPY modules/time-extra/package.yaml       modules/time-extra/package.yaml
+COPY modules/cardano-client/package.yaml     modules/cardano-client/package.yaml
+COPY modules/git-th/package.yaml             modules/git-th/package.yaml
+COPY modules/hspec-json-schema/package.yaml  modules/hspec-json-schema/package.yaml
+COPY modules/json-wsp/package.yaml           modules/json-wsp/package.yaml
+COPY modules/manufacture/package.yaml        modules/manufacture/package.yaml
+COPY modules/time-extra/package.yaml         modules/time-extra/package.yaml
 
-COPY ogmios-server/package.yaml            ogmios-server/package.yaml
-COPY stack.yaml                            stack.yaml
-COPY snapshot.yaml                         snapshot.yaml
+COPY ogmios-server/package.yaml              ogmios-server/package.yaml
+COPY stack.yaml                              stack.yaml
+COPY snapshot.yaml                           snapshot.yaml
 
 RUN stack setup
 RUN stack build --only-snapshot

snapshot.yaml

@@ -3,9 +3,10 @@ name: _
 resolver: https://raw.githubusercontent.com/input-output-hk/cardano-haskell/cfe917f0f419b5c9f63c958f335874e4dc0add85/snapshots/cardano-1.20.0.yaml
 
 packages:
+- hedgehog-quickcheck-0.1.1
 - hjsonpointer-1.3.0
 - hjsonschema-1.9.0
-- hedgehog-quickcheck-0.1.1
+- string-interpolate-0.3.0.2
 
 # commit b36ac2404718b0c14296fde557ff2d7dacdde54b (HEAD -> 1.20.0, origin/1.20.0)
 # Author: KtorZ <matthias.benkort@gmail.com>
@@ -23,6 +24,11 @@ packages:
   commit: b36ac2404718b0c14296fde557ff2d7dacdde54b
   subdirs:
     - ouroboros-consensus
+    - ouroboros-consensus-test
+    - ouroboros-consensus-byronspec
+    - ouroboros-consensus-byron-test
+    - ouroboros-consensus-shelley-test
+    - ouroboros-consensus-cardano-test
     - ouroboros-network
 
 # commit a1ed2f2bf23fd8a125bf8b86699783f5d97ab9ab