Simplify the lens expression to check schema completeness

Also addresses some review comments:
* Unify punctuation in yaml spec
* Move Envelope to Logging module and use it
* Add more comments to prop_specIsComplete

hydra-node/api-log.yaml

@@ -65,12 +65,11 @@ definitions:
   Node:
     oneOf:
     - title: ErrorHandlingEvent
-      comment: >-
-        This should be removed from the Log's description as soon as we have some proper
-        error handling strategy in place, be it simply "Close the head" and bail out.
+      # This should be removed from the Log's description as soon as we have some proper
+      # error handling strategy in place, be it simply "Close the head" and bail out.
       description: >-
         Some error happened while processing an event, provides enough context information
-        to troubleshoot the origin of the error
+        to troubleshoot the origin of the error.
       type: object
       required:
       - by
@@ -79,57 +78,57 @@ definitions:
       properties:
         by:
           description: >-
-            The Party emitting the log entry
+            The Party emitting the log entry.
           $ref: "#/definitions/Party"
         event:
           description: >-
-            The event causing the error
+            The event causing the error.
           $ref: "#/definitions/Event"
         reason:
           description: >-
-            Structured description of the cause of the error
+            Structured description of the cause of the error.
           $ref: "#/definitions/LogicError"
     - title: ProcessingEvent
       description: >-
         Head has started processing an event drawn from some pool or queue of events to
-        process
+        process.
       type: object
       required:
       - by
       - event
       properties:
         by:
           description: >-
-            The Party emitting the log entry
+            The Party emitting the log entry.
           $ref: "#/definitions/Party"
         event:
           $ref: "#/definitions/Event"
     - title: ProcessedEvent
       description: >-
-        Head has succesfully finished processing an event
+        Head has succesfully finished processing an event.
       type: object
       required:
       - by
       - event
       properties:
         by:
           description: >-
-            The Party emitting the log entry
+            The Party emitting the log entry.
           $ref: "#/definitions/Party"
         event:
           $ref: "#/definitions/Event"
     - title: ProcessingEffect
       description: >-
         Head has started processing an effect produced by some transition in the
-        protocol
+        protocol.
       type: object
       required:
       - by
       - effect
       properties:
         by:
           description: >-
-            The Party emitting the log entry
+            The Party emitting the log entry.
           $ref: "#/definitions/Party"
         event:
           $ref: "#/definitions/Effect"
@@ -199,18 +198,17 @@ definitions:
         reason:
           type: string
           description: >-
-            A textual description of the reason why this input is invalid
+            A textual description of the reason why this input is invalid.
         inputReceived:
           type: string
           description: >-
             A rendering in text of the input received. This input is invalid hence it's
             potentially invalid JSON so we just encode it as a proper JSON string. Note that if the input contained invalid UTF-8 characters they will be ignored.
   Party:
     type: integer
-    comment: >-
-      Signing is currently implemented using mock crypto hence party is just an integer
+    # Signing is currently implemented using mock crypto hence party is just an integer
     description: >-
-      The verification key for some Party in the Head protocol, uniquely identifying it
+      The verification key for some Party in the Head protocol, uniquely identifying it.
     examples:
       - 10
       - 20
@@ -229,7 +227,7 @@ definitions:
       - tag
       - clientInput
       description: >-
-        An event representing some input from a client
+        An event representing some input from a client.
       properties:
         tag:
           type: string
@@ -268,7 +266,7 @@ definitions:
       required:
       - tag
       description: >-
-        An placeholder event denoting the Head should post a Fanout transaction to close the head.
+        An placeholder event denoting the Head should post a Fanout transaction to finalize the head.
       properties:
         tag:
           type: string
@@ -335,7 +333,7 @@ definitions:
         - signed
         - snapshotNumber
         description: >-
-          Signature of a snapshot by a party
+          Signature of a snapshot by a party.
         properties:
           tag:
             type: string
@@ -410,7 +408,7 @@ definitions:
         - party
         - committed
         description: >-
-          The commit transaction from a party, committing some UTxOs to the Head
+          The commit transaction from a party, committing some UTxO set to the Head.
         properties:
           tag:
             type: string
@@ -477,7 +475,7 @@ ml#/definitions/Utxo"
       - tag
       - serverOutput
       description: >-
-        An effect representing some output to send to the client
+        An effect representing some output to send to the client.
       properties:
         tag:
           type: string
@@ -490,7 +488,7 @@ ml#/definitions/Utxo"
       - tag
       - message
       description: >-
-        An effect representing some message to broadcast to other parties in the Head
+        An effect representing some message to broadcast to other parties in the Head.
       properties:
         tag:
           type: string
@@ -588,7 +586,7 @@ ml#/definitions/Utxo"
         - tag
         - utxos
         description: >-
-          Confirm the opening of the Head collecting all committed UTxOs.
+          Confirm the opening of the Head collecting the committed UTxO set combined from all individual commits.
         properties:
           tag:
             type: string

hydra-node/src/Hydra/Logging.hs

@@ -16,6 +16,7 @@ module Hydra.Logging (
 
   -- * Using it
   Verbosity (..),
+  Envelope (..),
   withTracer,
   contramap,
   showLogsOnFailure,
@@ -33,12 +34,27 @@ import Control.Tracer (
   nullTracer,
   traceWith,
  )
-import Data.Aeson (Value, encode, object, (.=))
+import Data.Aeson (encode)
 import qualified Data.Text as Text
 
 data Verbosity = Quiet | Verbose Text
   deriving (Eq, Show)
 
+-- | Provides logging metadata for entries.
+-- NOTE(AB): setting the `message` to be `HydraLog` would require to pass along
+-- @tx@ and @net@ type arguments which is useless in the context, hence the more
+-- generic type.
+data Envelope a = Envelope
+  { namespace :: Text
+  , timestamp :: UTCTime
+  , threadId :: Int
+  , message :: a
+  }
+  deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+instance Arbitrary a => Arbitrary (Envelope a) where
+  arbitrary = genericArbitrary
+
 defaultQueueSize :: Natural
 defaultQueueSize = 500
 
@@ -52,8 +68,8 @@ withTracer ::
   (Tracer m msg -> IO a) ->
   IO a
 withTracer Quiet action = action nullTracer
-withTracer (Verbose name) action = do
-  msgQueue <- newTBQueueIO @_ @Value defaultQueueSize
+withTracer (Verbose namespace) action = do
+  msgQueue <- newTBQueueIO @_ @(Envelope msg) defaultQueueSize
   withAsync (writeLogs msgQueue) $ \_ ->
     action (tracer msgQueue) `finally` flushLogs msgQueue
  where
@@ -63,17 +79,15 @@ withTracer (Verbose name) action = do
           liftIO (mkEnvelop msg >>= atomically . writeTBQueue queue)
       )
 
-  mkEnvelop :: msg -> IO Value
-  mkEnvelop msg = do
+  mkEnvelop :: msg -> IO (Envelope msg)
+  mkEnvelop message = do
     timestamp <- liftIO getCurrentTime
-    threadId <- Text.drop 9 . show <$> liftIO myThreadId
-    pure $
-      object
-        [ "namespace" .= name
-        , "timestamp" .= timestamp
-        , "thread" .= threadId
-        , "message" .= msg
-        ]
+    threadId <- mkThreadId <$> liftIO myThreadId
+    pure $ Envelope{namespace, timestamp, threadId, message}
+
+  -- NOTE(AB): This is a bit contrived but we want a numeric threadId and we
+  -- get some text which we know the structure of
+  mkThreadId = fromMaybe 0 . readMaybe . Text.unpack . Text.drop 9 . show
 
   writeLogs queue =
     forever $ do

hydra-node/test/Hydra/APISpec.hs

@@ -5,8 +5,7 @@ module Hydra.APISpec where
 
 import Hydra.Prelude
 
-import Control.Lens (to)
-import Data.Aeson.Lens (key, _Array)
+import Data.Aeson.Lens (key)
 import Hydra.ClientInput (ClientInput)
 import Hydra.JSONSchema (SpecificationSelector, prop_specIsComplete, prop_validateToJSON, withJsonSpecifications)
 import Hydra.Ledger (Utxo)
@@ -38,5 +37,5 @@ spec = parallel $ do
         withMaxSuccess 1 $prop_validateToJSON @CardanoTx specs (tmp </> "CardanoTx")
 
 apiSpecificationSelector ::
-  Text -> SpecificationSelector a
-apiSpecificationSelector namespace = key "properties" . key namespace . key "items" . key "oneOf" . _Array . to toList
+  Text -> SpecificationSelector
+apiSpecificationSelector namespace = key "properties" . key namespace . key "items"

hydra-node/test/Hydra/JSONSchema.hs

@@ -8,7 +8,7 @@ module Hydra.JSONSchema where
 
 import Hydra.Prelude
 
-import Control.Lens (Lens', to, (^?))
+import Control.Lens (Traversal', to, (^..), (^?))
 import qualified Data.Aeson as Aeson
 import Data.Aeson.Lens (AsValue, key, _Array, _String)
 import Data.Char (isSpace)
@@ -53,24 +53,36 @@ prop_validateToJSON specFile inputFile =
 -- | Check specification is complete wr.t. to generated data
 -- 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
+-- data-type. This makes sure the document is kept in sync and make sure we don't
 -- left behind constructors which no longer exists.
 --
--- The second argument is a lens-like function that says which part of the
+-- The second argument is a lens that says which part of the
 -- specification to select to check completeness of the specification w.r.t.
 -- constructors for the datatype, for example:
 --
 -- @@
--- key "properties" . key "message" . key "oneOf" . _Array . to toList
+-- key "properties" . key "message"
 -- @@
 --
--- which selects the list of elements under @properties > message > oneOf@ path
--- in the specification file.
+-- which selects the list of elements under @properties > message@ path
+-- in the specification file. This element should be a schema fragment that has
+-- a property @oneOf@ containing a list of objects having a @title@ property.
+--
+-- Given the above selector, this schema fragment is fine:
+--
+-- @@
+-- properties:
+--  message:
+--    oneOf:
+--      - title: APIServer
+--        type: object
+--  ...
+-- @@
 prop_specIsComplete ::
   forall a.
   (Arbitrary a, Show a) =>
   FilePath ->
-  SpecificationSelector Yaml.Value ->
+  SpecificationSelector ->
   Property
 prop_specIsComplete specFile typeSpecificationSelector =
   forAllBlind (vectorOf 1000 arbitrary) $ \(a :: [a]) ->
@@ -90,33 +102,25 @@ prop_specIsComplete specFile typeSpecificationSelector =
         assert False
  where
   -- Like Generics, if you squint hard-enough.
-  strawmanGetConstr :: a -> Text
-  strawmanGetConstr = toText . Prelude.head . words . show
+  poormansGetConstr :: a -> Text
+  poormansGetConstr = toText . Prelude.head . words . show
 
   classify :: Maybe Aeson.Value -> [a] -> Map Text Integer
   classify (Just specs) =
-    let knownKeys =
-          case specs ^? typeSpecificationSelector of
-            Just es ->
-              let ks = mapMaybe (\(e :: Aeson.Value) -> e ^? key "title" . _String) es
-               in Map.fromList $ zip ks (repeat @Integer 0)
-            _ ->
-              mempty
+    let ks = specs ^.. typeSpecificationSelector . key "oneOf" . _Array . traverse . key "title" . _String
+
+        knownKeys = Map.fromList $ zip ks (repeat @Integer 0)
 
-        countMatch (strawmanGetConstr -> tag) =
+        countMatch (poormansGetConstr -> 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
 
-type SpecificationSelector t =
-  forall f.
-  ( Applicative f
-  , Contravariant f
-  ) =>
-  ([Yaml.Value] -> f [Yaml.Value]) ->
-  Yaml.Value ->
-  f Yaml.Value
+-- | 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
 
 -- | 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.

hydra-node/test/Hydra/LoggingSpec.hs

@@ -5,12 +5,11 @@ module Hydra.LoggingSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
-import Control.Lens (to)
 import Data.Aeson (object, (.=))
-import Data.Aeson.Lens (key, _Array)
+import Data.Aeson.Lens (key)
 import Hydra.JSONSchema (SpecificationSelector, prop_specIsComplete, prop_validateToJSON, withJsonSpecifications)
 import Hydra.Ledger.Simple (SimpleTx)
-import Hydra.Logging (Verbosity (Verbose), traceWith, withTracer)
+import Hydra.Logging (Envelope (..), Verbosity (Verbose), traceWith, withTracer)
 import Hydra.Logging.Messages (HydraLog)
 import System.FilePath ((</>))
 import System.IO.Silently (capture_)
@@ -30,24 +29,9 @@ spec = do
       -- TODO(AB): Add arbitrary instances for network log entries
       withMaxSuccess 1 $
         conjoin
-          [ prop_validateToJSON @(Enveloppe (HydraLog SimpleTx ())) specs (tmp </> "HydraLog")
+          [ prop_validateToJSON @(Envelope (HydraLog SimpleTx ())) specs (tmp </> "HydraLog")
           , prop_specIsComplete @(HydraLog SimpleTx ()) specs apiSpecificationSelector
           ]
 
-apiSpecificationSelector :: SpecificationSelector a
-apiSpecificationSelector = key "properties" . key "message" . key "oneOf" . _Array . to toList
-
--- NOTE(AB): This type is used currently only for testing purpose in
--- to provide a simple way to generate arbitrary log entries. In the
--- actual logging code we directly build an `Object` using aeson
--- `Value` combinators.
-data Enveloppe a = Enveloppe
-  { namespace :: Text
-  , timestamp :: UTCTime
-  , thread :: Int
-  , message :: a
-  }
-  deriving (Eq, Show, Generic, ToJSON, FromJSON)
-
-instance Arbitrary a => Arbitrary (Enveloppe a) where
-  arbitrary = genericArbitrary
+apiSpecificationSelector :: SpecificationSelector
+apiSpecificationSelector = key "properties" . key "message"