diff --git a/hydra-node/api.yaml b/hydra-node/api.yaml index 5d2b44b9072..a47364988db 100644 --- a/hydra-node/api.yaml +++ b/hydra-node/api.yaml @@ -55,7 +55,7 @@ properties: utxo: $ref: "#/definitions/Utxo" - - title: NewTransaction + - title: NewTx type: object required: - input @@ -66,7 +66,7 @@ properties: transaction: $ref: "#/definitions/Transaction" - - title: NewSnapshot + - title: NewSn type: object description: >- Request creation of a new snapshot. @@ -213,7 +213,7 @@ properties: utxo: $ref: "#/definitions/Utxo" - - title: TransactionSeen + - title: TxSeen type: object required: - output @@ -225,7 +225,7 @@ properties: transaction: $ref: "#/definitions/Transaction" - - title: TransactionValid + - title: TxValid type: object required: - output @@ -237,7 +237,7 @@ properties: transaction: $ref: "#/definitions/Transaction" - - title: TransactionInvalid + - title: TxInvalid type: object required: - output diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal index 4a7a1a2f5e2..a4c6349ad4a 100644 --- a/hydra-node/hydra-node.cabal +++ b/hydra-node/hydra-node.cabal @@ -216,6 +216,8 @@ test-suite tests , io-sim , io-classes , iproute + , lens + , lens-aeson , network , process , quickcheck-instances diff --git a/hydra-node/test/Hydra/APISpec.hs b/hydra-node/test/Hydra/APISpec.hs index 6cacc7cd43f..bcb04ce5d29 100644 --- a/hydra-node/test/Hydra/APISpec.hs +++ b/hydra-node/test/Hydra/APISpec.hs @@ -5,7 +5,9 @@ module Hydra.APISpec where import Hydra.Prelude +import Control.Lens ((^?)) import Data.Aeson ((.=)) +import Data.Aeson.Lens (key, _Array, _String) import Data.Char (isSpace) import Data.List (dropWhileEnd) import Hydra.HeadLogic (ClientInput (..), ServerOutput (..)) @@ -15,10 +17,12 @@ import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import System.Process (readProcessWithExitCode) import Test.Hspec (Spec, aroundAll, context, parallel, pendingWith, specify) -import Test.QuickCheck (Property, counterexample, forAllShrink, property, vectorOf, withMaxSuccess) +import Test.QuickCheck (Property, conjoin, counterexample, forAllBlind, forAllShrink, property, vectorOf, withMaxSuccess) import Test.QuickCheck.Monadic (assert, monadicIO, monitor, run) +import qualified Prelude import qualified Data.Aeson as Aeson +import qualified Data.Map.Strict as Map import qualified Data.Yaml as Yaml import qualified Paths_hydra_node as Pkg @@ -26,10 +30,10 @@ spec :: Spec spec = parallel $ do aroundAll withJsonSpecifications $ do context "Validate JSON representations with API specification" $ do - specify "ServerOutput" $ \(specs, tmp) -> - property $ prop_validateToJSON @(ServerOutput SimpleTx) specs "outputs" (tmp "ServerOutput") specify "ClientInput" $ \(specs, tmp) -> property $ prop_validateToJSON @(ClientInput SimpleTx) specs "inputs" (tmp "ClientInput") + specify "ServerOutput" $ \(specs, tmp) -> + property $ prop_validateToJSON @(ServerOutput SimpleTx) specs "outputs" (tmp "ServerOutput") -- | Generate arbitrary serializable (JSON) value, and check their validity -- against a known JSON schema. @@ -40,19 +44,56 @@ prop_validateToJSON :: Text -> FilePath -> Property -prop_validateToJSON specs namespace inputFile = +prop_validateToJSON specFile namespace inputFile = withMaxSuccess 1 $ - forAllShrink (vectorOf 100 arbitrary) shrink $ \(a :: [a]) -> - monadicIO $ do - run ensureSystemRequirements - (exitCode, _out, err) <- run $ do - Aeson.encodeFile inputFile (Aeson.object [namespace .= a]) - readProcessWithExitCode "jsonschema" ["-i", inputFile, specs] mempty - -- run $ print (Aeson.encode [Aeson.object [namespace .= a]]) - -- run $ print (exitCode, _out, err) - monitor $ counterexample err - monitor $ counterexample (show a) - assert (exitCode == ExitSuccess) + conjoin + -- This first sub-property ensures that JSON instances we produce abide by + -- the specification. Note this, because this uses an external tool each + -- property iteration is pretty slow. So instead, we run the property only + -- once, but on a list of 100 elements all arbitrarily generated. + [ forAllShrink (vectorOf 100 arbitrary) shrink $ \(a :: [a]) -> + monadicIO $ + do + run ensureSystemRequirements + (exitCode, _out, err) <- run $ do + Aeson.encodeFile inputFile (Aeson.object [namespace .= a]) + readProcessWithExitCode "jsonschema" ["-i", inputFile, specFile] mempty + monitor $ counterexample err + monitor $ counterexample (show a) + assert (exitCode == ExitSuccess) + , -- This second sub-property ensures that any key found in the + -- specification corresponds to a constructor in the corresponding + -- data-type. This in order the document in sync and make sure we don't + -- left behind constructors which no longer exists. + forAllBlind (vectorOf 1000 arbitrary) $ + \(a :: [a]) -> monadicIO $ do + specs <- run $ Aeson.decodeFileStrict specFile + let unknownConstructors = Map.keys $ Map.filter (== 0) $ classify specs a + when (length unknownConstructors > 0) $ do + let commaSeparated = intercalate ", " (toString <$> unknownConstructors) + monitor $ counterexample $ "Unimplemented constructors present in specification: " <> commaSeparated + assert False + ] + where + -- Like Generics, if you squint hard-enough. + strawmanGetConstr :: a -> Text + strawmanGetConstr = toText . Prelude.head . words . show + + classify :: Maybe Aeson.Value -> [a] -> Map Text Integer + classify (Just specs) = + let knownKeys = + case specs ^? key "properties" . key namespace . key "items" . key "oneOf" . _Array of + Just (toList -> es) -> + let ks = mapMaybe (\(e :: Aeson.Value) -> e ^? key "title" . _String) es + in Map.fromList $ zip ks (repeat @Integer 0) + _ -> + mempty + + countMatch (strawmanGetConstr -> tag) = + Map.alter (Just . maybe 1 (+ 1)) tag + in foldr countMatch knownKeys + classify _ = + error $ "Invalid specification file. Does not decode to an object: " <> show specFile -- | Prepare the environment (temp directory) with the JSON specification. We -- maintain a YAML version of a JSON-schema, for it is more convenient to write. @@ -73,13 +114,13 @@ withJsonSpecifications action = do ensureSystemRequirements :: IO () ensureSystemRequirements = do - checkSystemRequirements >>= \case + getToolVersion >>= \case Just "3.2.0" -> pure () _ -> pendingWith "This test requires the python library 'jsonschema==3.2.0' to be in scope." where -- Returns 'Nothing' when not available and 'Just ' otherwise. - checkSystemRequirements :: + getToolVersion :: IO (Maybe String) - checkSystemRequirements = do + getToolVersion = do (exitCode, out, _) <- readProcessWithExitCode "jsonschema" ["--version"] mempty pure (dropWhileEnd isSpace out <$ guard (exitCode == ExitSuccess)) diff --git a/hydra-prelude/src/Hydra/Prelude.hs b/hydra-prelude/src/Hydra/Prelude.hs index 80031942f94..d83cd9b0e2d 100644 --- a/hydra-prelude/src/Hydra/Prelude.hs +++ b/hydra-prelude/src/Hydra/Prelude.hs @@ -8,6 +8,10 @@ module Hydra.Prelude ( module Control.Monad.Class.MonadTimer, module Control.Monad.Class.MonadFork, module Control.Monad.Class.MonadThrow, + StaticMap (..), + DynamicMap (..), + keys, + elems, FromCBOR (..), ToCBOR (..), FromJSON (..), @@ -113,6 +117,12 @@ import Relude hiding ( tryTakeTMVar, writeTVar, ) +import Relude.Extra.Map ( + DynamicMap (..), + StaticMap (..), + elems, + keys, + ) import Test.QuickCheck ( Arbitrary (..), Gen,