diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index 86dd597c8f0..087b6f84763 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -160,7 +160,7 @@ test-suite tests build-depends: , aeson , async - , base >=4.7 && <5 + , base >=4.7 && <5 , bytestring , containers , directory @@ -168,7 +168,7 @@ test-suite tests , hspec , hydra-cardano-api , hydra-cluster - , hydra-node + , hydra-node:{hydra-node, testlib} , hydra-prelude , hydra-test-utils , io-classes diff --git a/hydra-cluster/test/Test/Hydra/Cluster/CardanoCliSpec.hs b/hydra-cluster/test/Test/Hydra/Cluster/CardanoCliSpec.hs index 61bdbb17f35..d74ff6e76d9 100644 --- a/hydra-cluster/test/Test/Hydra/Cluster/CardanoCliSpec.hs +++ b/hydra-cluster/test/Test/Hydra/Cluster/CardanoCliSpec.hs @@ -11,6 +11,7 @@ import Data.Aeson.Lens (key, _String) import Data.Aeson.Types (parseEither) import Hydra.API.HTTPServer (DraftCommitTxResponse (DraftCommitTxResponse)) import Hydra.Cardano.Api (Tx) +import Hydra.JSONSchema (validateJSON, withJsonSpecifications) import Hydra.Ledger.Cardano.Configuration (pparamsFromJson) import Hydra.Logging (showLogsOnFailure) import System.Exit (ExitCode (..)) @@ -46,8 +47,14 @@ spec = Left e -> failure $ "Failed to decode JSON: " <> e <> "\n" <> show protocolParameters Right _ -> pure () - it "query protocol-parameters matches our schema" $ \_tracer -> - pendingWith "TODO" + it "query protocol-parameters matches our schema" $ \tracer -> + withJsonSpecifications $ \tmpDir -> + withCardanoNodeDevnet tracer tmpDir $ \RunningNode{nodeSocket, networkId} -> do + pparamsValue <- cliQueryProtocolParameters nodeSocket (networkId) + validateJSON + (tmpDir "api.json") + (key "components" . key "schemas" . key "ProtocolParameters") + pparamsValue where cardanoCliSign txFile = proc diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal index d070c7db627..6e852db9a6d 100644 --- a/hydra-node/hydra-node.cabal +++ b/hydra-node/hydra-node.cabal @@ -176,6 +176,28 @@ library ghc-options: -haddock +library testlib + import: project-config + visibility: public + hs-source-dirs: testlib + exposed-modules: Hydra.JSONSchema + other-modules: Paths_hydra_node + build-depends: + , aeson + , base + , containers + , directory + , filepath + , hydra-prelude + , hydra-test-utils + , lens + , lens-aeson + , process + , QuickCheck + , text + , versions + , yaml + executable hydra-node import: project-config hs-source-dirs: exe/hydra-node @@ -274,7 +296,7 @@ test-suite tests Hydra.FireForgetSpec Hydra.HeadLogicSnapshotSpec Hydra.HeadLogicSpec - Hydra.JSONSchema + Hydra.JSONSchemaSpec Hydra.Ledger.Cardano.TimeSpec Hydra.Ledger.CardanoSpec Hydra.Ledger.SimpleSpec @@ -330,7 +352,7 @@ test-suite tests , hspec-wai , HUnit , hydra-cardano-api - , hydra-node + , hydra-node:{hydra-node, testlib} , hydra-plutus , hydra-plutus-extras , hydra-prelude @@ -341,7 +363,6 @@ test-suite tests , lens-aeson , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} >=1.1.1.0 , plutus-tx - , process , QuickCheck , quickcheck-dynamic >=3.3.1 && <3.4 , quickcheck-instances @@ -353,9 +374,7 @@ test-suite tests , time , typed-protocols-examples >=0.1.0.0 , vector - , versions , websockets - , yaml build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts diff --git a/hydra-node/json-schemas/api.yaml b/hydra-node/json-schemas/api.yaml index c900b705968..0137a73f0c4 100644 --- a/hydra-node/json-schemas/api.yaml +++ b/hydra-node/json-schemas/api.yaml @@ -849,9 +849,7 @@ components: ProtocolParameters: title: ProtocolParameters payload: - type: object - additionalProperties: false - $ref: "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/ProtocolParameters" + $ref: "api.yaml#/components/schemas/ProtocolParameters" IgnoredHeadInitializing: title: IgnoredHeadInitializing @@ -1056,6 +1054,129 @@ components: "port": 5001 } + # NOTE: We are not using the cardanonical/cardano.json#ProtocolParameters as + # we need to be compatible with what the cardano-cli provides us + ProtocolParameters: + description: | + Cardano protocol parameters as provided by the cardano-cli and accepted + by the hydra-node on the command line. + type: object + # Allow additional parameters to not be too strict about retired values + # like minUTxOValue + additionalProperties: true + required: + - protocolVersion + - maxBlockHeaderSize + - maxBlockBodySize + - maxTxSize + - txFeeFixed + - txFeePerByte + - stakeAddressDeposit + - stakePoolDeposit + - minPoolCost + - poolRetireMaxEpoch + - stakePoolTargetNum + - poolPledgeInfluence + - monetaryExpansion + - treasuryCut + - costModels # Alonzo onwards + - executionUnitPrices # Alonzo onwards + - maxTxExecutionUnits # Alonzo onwards + - maxBlockExecutionUnits # Alonzo onwards + - maxValueSize # Alonzo onwards + - collateralPercentage # Alonzo onwards + - maxCollateralInputs # Alonzo onwards + - utxoCostPerByte # Babbage onwards + properties: + protocolVersion: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/ProtocolVersion" + maxBlockBodySize: + # XXX: NumberOfBytes in cardanonical + type: integer + minimum: 0 + maxBlockHeaderSize: + # XXX: NumberOfBytes in cardanonical + type: integer + minimum: 0 + maxTxSize: + # XXX: NumberOfBytes in cardanonical + type: integer + minimum: 0 + txFeeFixed: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Lovelace" + txFeePerByte: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/UInt64" + stakeAddressDeposit: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Lovelace" + stakePoolDeposit: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Lovelace" + minPoolCost: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Lovelace" + poolRetireMaxEpoch: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/UInt64" + stakePoolTargetNum: + # XXX: UInt64 in cardanonical, but Natural in cardano-api + type: integer + minimum: 0 + poolPledgeInfluence: + # XXX: would be better "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Ratio" + type: number + monetaryExpansion: + # XXX: would be better "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Ratio" + type: number + treasuryCut: + # XXX: would be better "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Ratio" + type: number + costModels: + type: object + # XXX: Different key naming scheme than in cardanonical + propertyNames: + title: Language + type: string + enum: + - "PlutusV1" + - "PlutusV2" + - "PlutusV3" + additionalProperties: + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/CostModel" + executionUnitPrices: + # XXX: Object fields different in cardanonical and using Ratio + priceMemory: + type: number + priceSteps: + type: number + maxTxExecutionUnits: + # XXX: Object fields different in cardanonical + properties: + # XXX: UInt64 in cardanonical, but Rational in cardano-api + memory: + type: number + cpu: + type: number + maxBlockExecutionUnits: + # XXX: Object fields different in cardanonical + properties: + # XXX: UInt64 in cardanonical, but Rational in cardano-api + memory: + type: number + cpu: + type: number + maxValueSize: + # XXX: NumberOfBytes in cardanonical + type: integer + minimum: 0 + collateralPercentage: + # XXX: UInt64 in cardanonical, but Natural in cardano-api + type: integer + minimum: 0 + maxCollateralInputs: + # XXX: UInt64 in cardanonical, but Natural in cardano-api + type: integer + minimum: 0 + utxoCostPerByte: + # XXX: Coefficient in cardanonical is UInt64, but should be lovelace + "$ref": "https://raw.githubusercontent.com/CardanoSolutions/cardanonical/main/cardano.json#/definitions/Lovelace" + NodeId: type: string description: Hydra Node identifier @@ -1901,7 +2022,7 @@ components: type: object propertyNames: pattern: "^[0-9a-f]{64}#[0-9]+$" - items: + items: # REVIEW: does this work? use additionalProperties here? $ref: "api.yaml#/components/schemas/TxOut" example: { diff --git a/hydra-node/src/Hydra/API/HTTPServer.hs b/hydra-node/src/Hydra/API/HTTPServer.hs index ba0e2d1b547..a28864ed9f7 100644 --- a/hydra-node/src/Hydra/API/HTTPServer.hs +++ b/hydra-node/src/Hydra/API/HTTPServer.hs @@ -25,9 +25,11 @@ import Hydra.Cardano.Api ( TxOut, UTxO', deserialiseFromTextEnvelope, + fromLedgerPParams, mkScriptWitness, proxyToAsType, serialiseToTextEnvelope, + shelleyBasedEra, pattern KeyWitness, pattern ScriptWitness, ) @@ -166,7 +168,8 @@ httpApp tracer directChain pparams getInitializingHeadId request respond = do >>= handleDraftCommitUtxo directChain getInitializingHeadId >>= respond ("GET", ["protocol-parameters"]) -> - respond $ responseLBS status200 [] (Aeson.encode pparams) + respond . responseLBS status200 [] . Aeson.encode $ + fromLedgerPParams shelleyBasedEra pparams ("POST", ["cardano-transaction"]) -> consumeRequestBodyStrict request >>= handleSubmitUserTx directChain diff --git a/hydra-node/test/Hydra/API/HTTPServerSpec.hs b/hydra-node/test/Hydra/API/HTTPServerSpec.hs index 4f139fcd784..7835e6d6588 100644 --- a/hydra-node/test/Hydra/API/HTTPServerSpec.hs +++ b/hydra-node/test/Hydra/API/HTTPServerSpec.hs @@ -4,17 +4,18 @@ import Hydra.Prelude hiding (get) import Test.Hydra.Prelude import Cardano.Binary (serialize') -import Data.Aeson (Result (Error, Success), Value (String), encode, fromJSON) +import Data.Aeson (Result (Error, Success), Value (String), eitherDecode, encode, fromJSON) import Data.Aeson.Lens (key, nth) import Data.ByteString.Base16 qualified as Base16 import Hydra.API.HTTPServer (DraftCommitTxRequest, DraftCommitTxResponse, SubmitTxRequest (..), TransactionSubmitted, httpApp) import Hydra.API.ServerSpec (dummyChainHandle) -import Hydra.Cardano.Api (serialiseToTextEnvelope, toLedgerTx) +import Hydra.Cardano.Api (fromLedgerPParams, serialiseToTextEnvelope, shelleyBasedEra, toLedgerTx) import Hydra.Chain.Direct.Fixture (defaultPParams) -import Hydra.Chain.Direct.State () -import Hydra.JSONSchema (prop_validateJSONSchema) +import Hydra.JSONSchema (SchemaSelector, prop_validateJSONSchema, validateJSON, withJsonSpecifications) import Hydra.Ledger.Cardano (Tx) import Hydra.Logging (nullTracer) +import System.FilePath (()) +import System.IO.Unsafe (unsafePerformIO) import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs) import Test.Hspec.Wai (MatchBody (..), ResponseMatcher (matchBody), get, shouldRespondWith, with) import Test.QuickCheck.Property (counterexample, forAll, property, withMaxSuccess) @@ -87,17 +88,48 @@ apiServerSpec :: Spec apiServerSpec = do with (return webServer) $ do describe "API should respond correctly" $ - it "GET /protocol-parameters works" $ - get "/protocol-parameters" - `shouldRespondWith` 200 - { matchBody = - MatchBody - ( \_ actualBody -> - if actualBody /= encode defaultPParams - then Just "Request body missmatch" - else Nothing - ) - } + describe "GET /protocol-parameters" $ do + it "matches schema" $ + withJsonSpecifications $ \schemaDir -> do + get "/protocol-parameters" + `shouldRespondWith` 200 + { matchBody = + matchValidJSON + (schemaDir "api.json") + (key "components" . key "messages" . key "ProtocolParameters" . key "payload") + } + + it "responds given parameters" $ + get "/protocol-parameters" + `shouldRespondWith` 200 + { matchBody = matchJSON $ fromLedgerPParams shelleyBasedEra defaultPParams + } where webServer = httpApp nullTracer dummyChainHandle defaultPParams getHeadId getHeadId = pure Nothing + +-- * Helpers + +-- | Create a 'ResponseMatcher' or 'MatchBody' from a JSON serializable value +-- (using their 'IsString' instances). +matchJSON :: (IsString s, ToJSON a) => a -> s +matchJSON = fromString . decodeUtf8 . encode + +-- | Create a 'MatchBody' that validates the returned JSON response against a +-- schema. NOTE: This raises impure exceptions, so only use it in this test +-- suite. +matchValidJSON :: FilePath -> SchemaSelector -> MatchBody +matchValidJSON schemaFile selector = + MatchBody $ \_headers body -> + case eitherDecode body of + Left err -> Just $ "failed to decode body: " <> err + Right value -> validateJSONPure value + where + -- NOTE: Uses unsafePerformIO to create a pure API although we are actually + -- calling an external program to verify the schema. This is fine, because the + -- call is referentially transparent and any given invocation of schema file, + -- selector and value will always yield the same result and can be shared. + validateJSONPure value = + unsafePerformIO $ do + validateJSON schemaFile selector value + pure Nothing diff --git a/hydra-node/test/Hydra/JSONSchemaSpec.hs b/hydra-node/test/Hydra/JSONSchemaSpec.hs new file mode 100644 index 00000000000..48456e9a409 --- /dev/null +++ b/hydra-node/test/Hydra/JSONSchemaSpec.hs @@ -0,0 +1,58 @@ +-- | Tests our JSON schema test utilities. +module Hydra.JSONSchemaSpec where + +import Hydra.Prelude +import Test.Hydra.Prelude + +import Control.Exception (IOException) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson.Lens (key) +import Hydra.JSONSchema (prop_validateJSONSchema, validateJSON, withJsonSpecifications) +import System.FilePath (()) +import Test.QuickCheck.Instances.Time () + +spec :: Spec +spec = do + describe "validateJSON withJsonSpecifications" $ do + it "works using identity selector and Null input" $ + withJsonSpecifications $ \dir -> + validateJSON (dir "api.json") id Null + + it "fails on non-existing schema file" $ + validateJSON ("does-not-exist.json") id Null + `shouldThrow` exceptionContaining @IOException "does-not-exist.json" + + it "fails with missing tool" $ do + withClearedPATH $ + validateJSON ("does-not-matter.json") id Null + `shouldThrow` exceptionContaining @IOException "installed" + + it "selects a sub-schema correctly" $ + withJsonSpecifications $ \dir -> + validateJSON + (dir "api.json") + (key "components" . key "schemas" . key "HeadId") + (String "some-head-id") + + it "produces helpful errors" $ + withJsonSpecifications $ \dir -> + validateJSON + (dir "api.json") + (key "components" . key "schemas" . key "HeadId") + (object ["foo" .= String "bar"]) + `shouldThrow` exceptionContaining @HUnitFailure + "{'foo': 'bar'} is not of type 'string'" + + it "resolves refs" $ + withJsonSpecifications $ \dir -> + validateJSON + (dir "api.json") + -- NOTE: MultiSignature has a local ref into api.yaml for Signature + (key "components" . key "schemas" . key "MultiSignature") + (object ["multiSignature" .= [String "bar"]]) + + describe "prop_validateJSONSchema" $ + it "works with api.yaml and UTCTime" $ + prop_validateJSONSchema @UTCTime + "api.yaml" + (key "components" . key "schemas" . key "UTCTime") diff --git a/hydra-node/test/Hydra/JSONSchema.hs b/hydra-node/testlib/Hydra/JSONSchema.hs similarity index 63% rename from hydra-node/test/Hydra/JSONSchema.hs rename to hydra-node/testlib/Hydra/JSONSchema.hs index 61969cd92f4..a4107be9d34 100644 --- a/hydra-node/test/Hydra/JSONSchema.hs +++ b/hydra-node/testlib/Hydra/JSONSchema.hs @@ -1,33 +1,42 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Test utilities to work with JSON schemas. module Hydra.JSONSchema where import Hydra.Prelude +import Test.Hydra.Prelude import Control.Arrow (left) import Control.Lens (Traversal', at, (?~), (^..), (^?)) -import Data.Aeson ((.=)) +import Data.Aeson (Value, (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Lens (key, _Array, _String) import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Text (pack) -import Data.Text qualified as Text import Data.Versions (SemVer (SemVer), prettySemVer, semver) import Data.Yaml qualified as Yaml -import GHC.IO.Exception (IOErrorType (OtherError)) import Paths_hydra_node qualified as Pkg -import System.Directory (listDirectory) +import System.Directory (copyFile, listDirectory) import System.Exit (ExitCode (..)) -import System.FilePath (normalise, takeBaseName, takeExtension, (<.>), ()) -import System.IO.Error (IOError, ioeGetErrorType) +import System.FilePath (normalise, takeBaseName, takeDirectory, takeExtension, takeFileName, (<.>), ()) +import System.IO.Error (IOError, isDoesNotExistError) import System.Process (readProcessWithExitCode) -import Test.Hydra.Prelude (failure, withTempDir) -import Test.QuickCheck (Property, counterexample, forAllShrink, resize, vectorOf) +import Test.QuickCheck (Property, counterexample, forAllShrink, mapSize, vectorOf, withMaxSuccess) import Test.QuickCheck.Monadic (assert, monadicIO, monitor, run) import Prelude qualified --- | Validate an 'Arbitrary' value against a JSON schema. +-- | Validate a specific JSON value against a given JSON schema and throws an +-- HUnitFailure exception if validation did not pass. +-- +-- The path to the schema must be a fully qualified path to .json schema file. +-- Use 'withJsonSpecifications' to convert hydra-specific yaml schemas into +-- proper json schemas, for example: +-- +-- @@ +-- withJsonSpecifications $ \dir -> validateJSON (dir "api.json") id Null +-- @@ -- -- The second argument is a lens that says which part of the JSON file to use to -- do the validation, for example: @@ -38,40 +47,79 @@ import Prelude qualified -- -- which selects the JSON schema for "Address" types in a bigger specification, -- say an asyncapi description. +validateJSON :: + HasCallStack => + -- | Path to the JSON file holding the schema. + FilePath -> + -- | Selector into the JSON file pointing to the schema to be validated. + SchemaSelector -> + Value -> + IO () +validateJSON schemaFilePath selector value = do + ensureSystemRequirements + withTempDir "validateJSON" $ \tmpDir -> do + copySchemasTo tmpDir + -- Write input file + let jsonInput = tmpDir "input.json" + writeFileLBS jsonInput (Aeson.encode value) + -- Write (sub-)schema to use + let jsonSchema = tmpDir "schema.json" + Aeson.eitherDecodeFileStrict schemaFilePath >>= \case + Left err -> fail $ "Failed to decode JSON schema " <> show schemaFilePath <> ": " <> err + Right schemaValue -> do + let jsonSpecSchema = + schemaValue ^? selector + <&> addField "$id" ("file://" <> tmpDir <> "/") + writeFileLBS jsonSchema (Aeson.encode jsonSpecSchema) + -- Validate using external program + (exitCode, out, err) <- + readProcessWithExitCode "check-jsonschema" ["--schemafile", jsonSchema, jsonInput] "" + when (exitCode /= ExitSuccess) $ + failure . toString $ + unlines + [ "check-jsonschema failed on " <> toText jsonInput <> " with schema " <> toText jsonSchema + , toText err <> toText out + ] + where + copySchemasTo dir = do + let sourceDir = takeDirectory schemaFilePath + files <- listDirectory sourceDir + let schemaFiles = filter (\fp -> takeExtension fp `elem` [".json", ".yaml"]) files + forM_ schemaFiles $ \fp -> + copyFile (sourceDir fp) (dir takeFileName fp) + +-- | Validate an 'Arbitrary' value against a JSON schema. +-- +-- See 'validateJSON' for how to provide a selector. prop_validateJSONSchema :: forall a. (ToJSON a, Arbitrary a, Show a) => -- | Path to the JSON file holding the schema. - String -> + FilePath -> -- | Selector into the JSON file pointing to the schema to be validated. - SpecificationSelector -> + SchemaSelector -> Property prop_validateJSONSchema specFileName selector = - forAllShrink (resize 10 arbitrary) shrink $ \(samples :: [a]) -> - monadicIO $ do - withJsonSpecifications $ \tmpDir -> do - run ensureSystemRequirements - let jsonInput = tmpDir "jsonInput" - let jsonSchema = tmpDir "jsonSchema" - let specJsonFile = tmpDir specFileName - mSpecs <- run $ Aeson.decodeFileStrict specJsonFile - case mSpecs of - Nothing -> error "Failed to decode specFile to JSON" - Just specs -> run $ do - let jsonSpecSchema = + -- NOTE: Avoid slow execution (due to external program) by testing the + -- property once with size 100 instead of 100 times with growing sizes. + withMaxSuccess 1 . mapSize (const 100) $ + forAllShrink arbitrary shrink $ \(samples :: [a]) -> + monadicIO $ do + withJsonSpecifications $ \tmpDir -> do + run ensureSystemRequirements + let jsonSchema = tmpDir "jsonSchema" + run $ + Aeson.decodeFileStrict (tmpDir specFileName) >>= \case + Nothing -> error "Failed to decode specFile to JSON" + Just specs -> do + Aeson.encodeFile jsonSchema $ Aeson.object [ "$id" .= ("file://" <> tmpDir <> "/") , "type" .= Aeson.String "array" , "items" .= (specs ^? selector) ] - writeFileLBS jsonInput (Aeson.encode samples) - writeFileLBS jsonSchema (Aeson.encode jsonSpecSchema) - monitor $ counterexample (decodeUtf8 . Aeson.encode $ samples) - (exitCode, out, err) <- run $ do - readProcessWithExitCode "check-jsonschema" ["--schemafile", jsonSchema, jsonInput] mempty - monitor $ counterexample out - monitor $ counterexample err - assert (exitCode == ExitSuccess) + monitor $ counterexample (decodeUtf8 . Aeson.encode $ samples) + run $ validateJSON jsonSchema id (toJSON samples) -- | Check specification is complete wr.t. to generated data -- This second sub-property ensures that any key found in the @@ -105,9 +153,9 @@ prop_specIsComplete :: forall a. (Arbitrary a, Show a) => String -> - SpecificationSelector -> + SchemaSelector -> Property -prop_specIsComplete specFileName typeSpecificationSelector = +prop_specIsComplete specFileName selector = forAllShrink (vectorOf 1000 arbitrary) shrink $ \(a :: [a]) -> monadicIO $ do withJsonSpecifications $ \tmpDir -> do @@ -132,7 +180,7 @@ prop_specIsComplete specFileName typeSpecificationSelector = classify :: FilePath -> Maybe Aeson.Value -> [a] -> Map Text Integer classify _ (Just specs) = - let ks = specs ^.. typeSpecificationSelector . key "oneOf" . _Array . traverse . key "title" . _String + let ks = specs ^.. selector . key "oneOf" . _Array . traverse . key "title" . _String knownKeys = Map.fromList $ zip ks (repeat @Integer 0) @@ -145,7 +193,7 @@ prop_specIsComplete specFileName typeSpecificationSelector = -- | An alias for a traversal selecting some part of a 'Value' -- This alleviates the need for users of this module to import explicitly the types -- from aeson and lens. -type SpecificationSelector = Traversal' Aeson.Value Aeson.Value +type SchemaSelector = Traversal' Aeson.Value Aeson.Value -- | Prepare the environment (temp directory) with the JSON specifications. We -- maintain a YAML version of a JSON-schema, for it is more convenient to write. @@ -177,16 +225,16 @@ addField k v = withObject (at k ?~ toJSON v) Aeson.Object m -> Aeson.Object (fn m) x -> x --- | Make sure that the required `check-jsonschema` tool is available on the system. --- Mark a test as pending when not available. +-- | Check that the required `check-jsonschema` tool is available on the system. +-- Raises an IOException (user error via 'fail') if not found or wrong version. ensureSystemRequirements :: IO () ensureSystemRequirements = getToolVersion >>= \case Right semVer -> unless (semVer >= SemVer 0 21 0 Nothing Nothing) $ - failure . Text.unpack $ + fail . toString $ "check-jsonschema version " <> prettySemVer semVer <> " found but >= 0.21.0 needed" - Left errorMsg -> failure errorMsg + Left errorMsg -> fail errorMsg where getToolVersion :: IO (Either String SemVer) getToolVersion = do @@ -195,7 +243,7 @@ ensureSystemRequirements = Right (exitCode, out, _) -> pure (List.last (List.words out) <$ if exitCode == ExitSuccess then pure () else Left "") Left (err :: IOError) - | ioeGetErrorType err == OtherError -> + | isDoesNotExistError err -> pure (Left "Make sure check-jsonschema is installed and in $PATH") Left err -> pure (Left $ show err) pure $ do diff --git a/hydra-test-utils/src/Test/Hydra/Prelude.hs b/hydra-test-utils/src/Test/Hydra/Prelude.hs index 7d0a89bd9d9..7bd0fc85401 100644 --- a/hydra-test-utils/src/Test/Hydra/Prelude.hs +++ b/hydra-test-utils/src/Test/Hydra/Prelude.hs @@ -10,25 +10,27 @@ module Test.Hydra.Prelude ( genericCoverTable, forAll2, pickBlind, - - -- * HSpec re-exports module Test.Hspec, module Test.Hspec.QuickCheck, withTempDir, withLogFile, checkProcessHasNotDied, + exceptionContaining, + withClearedPATH, ) where import Hydra.Prelude import Test.Hspec import Test.Hspec.QuickCheck +import Data.List (isInfixOf) import Data.Ratio ((%)) import Data.Text.IO (hGetContents) import Data.Typeable (typeRep) import GHC.Exception (SrcLoc (..)) import GHC.IO.Exception (IOErrorType (..), IOException (..)) import System.Directory (createDirectoryIfMissing, removePathForcibly) +import System.Environment (getEnv, setEnv) import System.Exit (ExitCode (..)) import System.FilePath (takeDirectory) import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) @@ -225,3 +227,23 @@ pickBlind gen = MkPropertyM $ \k -> do a <- gen mp <- k a pure (forAllBlind (return a) . const <$> mp) + +-- | Selector for use with 'shouldThrow' to select exceptions containing some +-- string. Use with TypeApplications, e.g. +-- +-- @@ +-- exceptionContaining @IOException "foo" +-- @@ +exceptionContaining :: Exception e => String -> Selector e +exceptionContaining msg e = + msg `isInfixOf` displayException e + +-- | Clear PATH environment variable while executing given action. +withClearedPATH :: IO () -> IO () +withClearedPATH act = + bracket capture (setEnv "PATH") (const act) + where + capture = do + env <- getEnv "PATH" + setEnv "PATH" "" + pure env diff --git a/nix/hydra/packages.nix b/nix/hydra/packages.nix index b056508a2bf..f16a5c8e02d 100644 --- a/nix/hydra/packages.nix +++ b/nix/hydra/packages.nix @@ -135,6 +135,7 @@ rec { cardano-node.packages.${system}.cardano-node cardano-node.packages.${system}.cardano-cli hydra-chain-observer + pkgs.check-jsonschema ]; }; hydra-tui = pkgs.mkShellNoCC {