Cross-check constructors existence from API specification vs real imp…

…lemenetation

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

hydra-node/hydra-node.cabal

@@ -216,6 +216,8 @@ test-suite tests
     , io-sim
     , io-classes
     , iproute
+    , lens
+    , lens-aeson
     , network
     , process
     , quickcheck-instances

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,21 +17,23 @@ 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
 
 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 <version number>' otherwise.
-  checkSystemRequirements ::
+  getToolVersion ::
     IO (Maybe String)
-  checkSystemRequirements = do
+  getToolVersion = do
     (exitCode, out, _) <- readProcessWithExitCode "jsonschema" ["--version"] mempty
     pure (dropWhileEnd isSpace out <$ guard (exitCode == ExitSuccess))

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,