diff --git a/hydra-node/api-log.yaml b/hydra-node/api-log.yaml index dd86231c50b..bdf8ab3e1da 100644 --- a/hydra-node/api-log.yaml +++ b/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,20 +78,20 @@ 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 @@ -100,13 +99,13 @@ definitions: 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 @@ -114,14 +113,14 @@ definitions: 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 @@ -129,7 +128,7 @@ definitions: properties: by: description: >- - The Party emitting the log entry + The Party emitting the log entry. $ref: "#/definitions/Party" event: $ref: "#/definitions/Effect" @@ -199,7 +198,7 @@ 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: >- @@ -207,10 +206,9 @@ definitions: 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 diff --git a/hydra-node/src/Hydra/Logging.hs b/hydra-node/src/Hydra/Logging.hs index be8997d40be..fa73a8cd603 100644 --- a/hydra-node/src/Hydra/Logging.hs +++ b/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 diff --git a/hydra-node/test/Hydra/APISpec.hs b/hydra-node/test/Hydra/APISpec.hs index 4232297d367..072165af50f 100644 --- a/hydra-node/test/Hydra/APISpec.hs +++ b/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" diff --git a/hydra-node/test/Hydra/JSONSchema.hs b/hydra-node/test/Hydra/JSONSchema.hs index 7b1d86c053f..77540eb1d3f 100644 --- a/hydra-node/test/Hydra/JSONSchema.hs +++ b/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. diff --git a/hydra-node/test/Hydra/LoggingSpec.hs b/hydra-node/test/Hydra/LoggingSpec.hs index e42b56faa97..483a9667551 100644 --- a/hydra-node/test/Hydra/LoggingSpec.hs +++ b/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"