diff --git a/.gitignore b/.gitignore index 32dffbd5d4a..2094d806f33 100644 --- a/.gitignore +++ b/.gitignore @@ -63,6 +63,8 @@ logs # Ignore files generated by scripts /example /testnet +bench/trace-schemas/types/ +bench/trace-schemas/messages/ .vscode/ diff --git a/Makefile b/Makefile index 9c95950da3b..50df92b1333 100644 --- a/Makefile +++ b/Makefile @@ -38,6 +38,18 @@ cli node: trace-documentation: cabal run -- exe:cardano-node trace-documentation --config 'configuration/cardano/mainnet-config.yaml' --output-file 'doc/new-tracing/tracers_doc_generated.md' +trace-schemas-regenerate: ## Regenerate trace schemas, apply overrides, validate + bash bench/trace-schemas/scripts/schema-gen/RegenerateTraceSchemas.sh + +trace-schemas-overrides-check: ## Check whether all schema overrides are applied + nix run .#apply-schema-overrides -- --check --verbose + +trace-schemas-overrides-coverage: ## Fail when generated schema files change without matching override sidecars (use RANGE=origin/master...HEAD in CI) + nix run .#check-override-coverage -- ${if ${RANGE},--range ${RANGE}} + +trace-schemas-validate: ## Validate trace message schemas against meta.schema.json + nix run .#validate-trace-schemas + ### ### Workbench ### diff --git a/bench/trace-schemas/TraceMessage.schema.json b/bench/trace-schemas/TraceMessage.schema.json new file mode 100644 index 00000000000..71ddbb4c889 --- /dev/null +++ b/bench/trace-schemas/TraceMessage.schema.json @@ -0,0 +1,51 @@ +{ + "$schema": "https://json-schema.org/draft/2020-12/schema", + "$id": "io.example.tracing/TraceMessage.schema.json", + "title": "TraceMessage", + "description": "Common envelope for trace messages.", + "type": "object", + "additionalProperties": false, + "required": [ + "at", + "ns", + "sev", + "thread", + "host", + "data" + ], + "properties": { + "at": { + "type": "string", + "format": "date-time", + "description": "Timestamp of the trace event (RFC 3339 / ISO 8601)." + }, + "ns": { + "type": "string", + "description": "Trace namespace." + }, + "sev": { + "type": "string", + "description": "Severity level.", + "enum": [ + "Debug", + "Info", + "Notice", + "Warning", + "Error", + "Critical" + ] + }, + "thread": { + "type": "string", + "description": "Thread identifier." + }, + "host": { + "type": "string", + "description": "Host name or node identifier." + }, + "data": { + "description": "Payload of the trace message.", + "type": "object" + } + } +} diff --git a/bench/trace-schemas/meta.schema.json b/bench/trace-schemas/meta.schema.json new file mode 100644 index 00000000000..fc718c7c522 --- /dev/null +++ b/bench/trace-schemas/meta.schema.json @@ -0,0 +1,65 @@ +{ + "$id": "io.example.tracing/generated-schema-entry.json", + "$schema": "https://json-schema.org/draft/2020-12/schema", + "additionalProperties": false, + "oneOf": [ + { + "not": { + "required": [ + "variants" + ] + }, + "required": [ + "data" + ] + }, + { + "not": { + "required": [ + "data" + ] + }, + "required": [ + "variants" + ] + } + ], + "properties": { + "data": { + "type": "object" + }, + "ns": { + "type": "string" + }, + "variants": { + "items": { + "additionalProperties": false, + "properties": { + "data": { + "type": "object" + }, + "detailLevel": { + "enum": [ + "Minimal", + "Normal", + "Detailed", + "Maximum" + ], + "type": "string" + } + }, + "required": [ + "detailLevel", + "data" + ], + "type": "object" + }, + "type": "array" + } + }, + "required": [ + "ns" + ], + "title": "GeneratedTraceSchemaEntry", + "type": "object" +} diff --git a/bench/trace-schemas/newNamespaces.txt b/bench/trace-schemas/newNamespaces.txt new file mode 100644 index 00000000000..fe7cdae72ae --- /dev/null +++ b/bench/trace-schemas/newNamespaces.txt @@ -0,0 +1,665 @@ +BlockFetch.Client.AcknowledgedFetchRequest +BlockFetch.Client.AddedFetchRequest +BlockFetch.Client.ClientMetrics +BlockFetch.Client.ClientTerminating +BlockFetch.Client.CompletedBlockFetch +BlockFetch.Client.CompletedFetchBatch +BlockFetch.Client.RejectedFetchBatch +BlockFetch.Client.SendFetchRequest +BlockFetch.Client.StartedFetchBatch +BlockFetch.Decision.Accept +BlockFetch.Decision.Decline +BlockFetch.Decision.EmptyPeersFetch +BlockFetch.Remote.Receive.BatchDone +BlockFetch.Remote.Receive.Block +BlockFetch.Remote.Receive.ClientDone +BlockFetch.Remote.Receive.NoBlocks +BlockFetch.Remote.Receive.RequestRange +BlockFetch.Remote.Receive.StartBatch +BlockFetch.Remote.Send.BatchDone +BlockFetch.Remote.Send.Block +BlockFetch.Remote.Send.ClientDone +BlockFetch.Remote.Send.NoBlocks +BlockFetch.Remote.Send.RequestRange +BlockFetch.Remote.Send.StartBatch +BlockFetch.Remote.Serialised.Receive.BatchDone +BlockFetch.Remote.Serialised.Receive.Block +BlockFetch.Remote.Serialised.Receive.ClientDone +BlockFetch.Remote.Serialised.Receive.NoBlocks +BlockFetch.Remote.Serialised.Receive.RequestRange +BlockFetch.Remote.Serialised.Receive.StartBatch +BlockFetch.Remote.Serialised.Send.BatchDone +BlockFetch.Remote.Serialised.Send.Block +BlockFetch.Remote.Serialised.Send.ClientDone +BlockFetch.Remote.Serialised.Send.NoBlocks +BlockFetch.Remote.Serialised.Send.RequestRange +BlockFetch.Remote.Serialised.Send.StartBatch +BlockFetch.Server.SendBlock +BlockchainTime.CurrentSlotUnknown +BlockchainTime.StartTimeInTheFuture +BlockchainTime.SystemClockMovedBack +ChainDB.AddBlockEvent.AddBlockValidation.InvalidBlock +ChainDB.AddBlockEvent.AddBlockValidation.UpdateLedgerDb +ChainDB.AddBlockEvent.AddBlockValidation.ValidCandidate +ChainDB.AddBlockEvent.AddedBlockToQueue +ChainDB.AddBlockEvent.AddedBlockToVolatileDB +ChainDB.AddBlockEvent.AddedReprocessLoEBlocksToQueue +ChainDB.AddBlockEvent.AddedToCurrentChain +ChainDB.AddBlockEvent.ChainSelectionLoEDebug +ChainDB.AddBlockEvent.ChangingSelection +ChainDB.AddBlockEvent.IgnoreBlockAlreadyInVolatileDB +ChainDB.AddBlockEvent.IgnoreBlockOlderThanK +ChainDB.AddBlockEvent.IgnoreInvalidBlock +ChainDB.AddBlockEvent.PipeliningEvent.OutdatedTentativeHeader +ChainDB.AddBlockEvent.PipeliningEvent.SetTentativeHeader +ChainDB.AddBlockEvent.PipeliningEvent.TrapTentativeHeader +ChainDB.AddBlockEvent.PoppedBlockFromQueue +ChainDB.AddBlockEvent.PoppedReprocessLoEBlocksFromQueue +ChainDB.AddBlockEvent.PoppingFromQueue +ChainDB.AddBlockEvent.StoreButDontChange +ChainDB.AddBlockEvent.SwitchedToAFork +ChainDB.AddBlockEvent.TryAddToCurrentChain +ChainDB.AddBlockEvent.TrySwitchToAFork +ChainDB.AddPerasCertEvent.AddedPerasCertToQueue +ChainDB.AddPerasCertEvent.ChainSelectionForBoostedBlock +ChainDB.AddPerasCertEvent.IgnorePerasCertTooOld +ChainDB.AddPerasCertEvent.PerasCertBoostsBlockNotYetReceived +ChainDB.AddPerasCertEvent.PerasCertBoostsCurrentChain +ChainDB.AddPerasCertEvent.PerasCertBoostsGenesis +ChainDB.AddPerasCertEvent.PoppedPerasCertFromQueue +ChainDB.ChainSelStarvationEvent +ChainDB.CopyToImmutableDBEvent.CopiedBlockToImmutableDB +ChainDB.CopyToImmutableDBEvent.NoBlocksToCopyToImmutableDB +ChainDB.FollowerEvent.FollowerNewImmIterator +ChainDB.FollowerEvent.FollowerNoLongerInMem +ChainDB.FollowerEvent.FollowerSwitchToMem +ChainDB.FollowerEvent.NewFollower +ChainDB.GCEvent.PerformedGC +ChainDB.GCEvent.ScheduledGC +ChainDB.ImmDbEvent.CacheEvent.CurrentChunkHit +ChainDB.ImmDbEvent.CacheEvent.PastChunkEvict +ChainDB.ImmDbEvent.CacheEvent.PastChunkExpired +ChainDB.ImmDbEvent.CacheEvent.PastChunkHit +ChainDB.ImmDbEvent.CacheEvent.PastChunkMiss +ChainDB.ImmDbEvent.ChunkFileDoesntFit +ChainDB.ImmDbEvent.ChunkValidation.InvalidChunkFile +ChainDB.ImmDbEvent.ChunkValidation.InvalidPrimaryIndex +ChainDB.ImmDbEvent.ChunkValidation.InvalidSecondaryIndex +ChainDB.ImmDbEvent.ChunkValidation.MissingChunkFile +ChainDB.ImmDbEvent.ChunkValidation.MissingPrimaryIndex +ChainDB.ImmDbEvent.ChunkValidation.MissingSecondaryIndex +ChainDB.ImmDbEvent.ChunkValidation.RewritePrimaryIndex +ChainDB.ImmDbEvent.ChunkValidation.RewriteSecondaryIndex +ChainDB.ImmDbEvent.ChunkValidation.StartedValidatingChunk +ChainDB.ImmDbEvent.ChunkValidation.ValidatedChunk +ChainDB.ImmDbEvent.DBAlreadyClosed +ChainDB.ImmDbEvent.DBClosed +ChainDB.ImmDbEvent.DeletingAfter +ChainDB.ImmDbEvent.Migrating +ChainDB.ImmDbEvent.NoValidLastLocation +ChainDB.ImmDbEvent.ValidatedLastLocation +ChainDB.InitChainSelEvent.InitialChainSelected +ChainDB.InitChainSelEvent.StartedInitChainSelection +ChainDB.InitChainSelEvent.Validation.InvalidBlock +ChainDB.InitChainSelEvent.Validation.UpdateLedgerDb +ChainDB.InitChainSelEvent.Validation.ValidCandidate +ChainDB.IteratorEvent.BlockGCedFromVolatileDB +ChainDB.IteratorEvent.BlockMissingFromVolatileDB +ChainDB.IteratorEvent.BlockWasCopiedToImmutableDB +ChainDB.IteratorEvent.StreamFromBoth +ChainDB.IteratorEvent.StreamFromImmutableDB +ChainDB.IteratorEvent.StreamFromVolatileDB +ChainDB.IteratorEvent.SwitchBackToVolatileDB +ChainDB.IteratorEvent.UnknownRangeRequested.ForkTooOld +ChainDB.IteratorEvent.UnknownRangeRequested.MissingBlock +ChainDB.LastShutdownUnclean +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.AlreadyClosed +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Closed +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Closing +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Copied +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Copying +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.CreatedValueHandle +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.CreatingValueHandle +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.InitialisedFromCopy +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.InitialisedFromValues +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.InitialisingFromCopy +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.InitialisingFromValues +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Opened +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Opening +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.AlreadyClosed +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.Closed +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.Closing +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.RangeRead +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.RangeReading +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.Read +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.Reading +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.Statted +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.ValueHandleTrace.Statting +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Writing +ChainDB.LedgerEvent.Flavor.V1.LMDB.BackingStoreEvent.Written +ChainDB.LedgerEvent.Flavor.V1.LMDB.Initialise +ChainDB.LedgerEvent.Flavor.V2.BackendTrace.LSM.LSMLookup +ChainDB.LedgerEvent.Flavor.V2.BackendTrace.LSM.LSMOpenSession +ChainDB.LedgerEvent.Flavor.V2.BackendTrace.LSM.LSMSnap +ChainDB.LedgerEvent.Flavor.V2.BackendTrace.LSM.LSMTrace +ChainDB.LedgerEvent.Flavor.V2.BackendTrace.LSM.LSMUpdate +ChainDB.LedgerEvent.Flavor.V2.LedgerTablesHandleClose +ChainDB.LedgerEvent.Flavor.V2.LedgerTablesHandleCreate +ChainDB.LedgerEvent.Flavor.V2.LedgerTablesHandleCreateFirst +ChainDB.LedgerEvent.Flavor.V2.LedgerTablesHandleDuplicate +ChainDB.LedgerEvent.Flavor.V2.LedgerTablesHandlePush +ChainDB.LedgerEvent.Flavor.V2.LedgerTablesHandleRead +ChainDB.LedgerEvent.Forker.Close +ChainDB.LedgerEvent.Forker.Open +ChainDB.LedgerEvent.Forker.Push +ChainDB.LedgerEvent.Forker.RangeRead +ChainDB.LedgerEvent.Forker.Read +ChainDB.LedgerEvent.Forker.Statistics +ChainDB.LedgerEvent.Replay.ReplayProgress.ReplayedBlock +ChainDB.LedgerEvent.Replay.ReplayStart.ReplayFromGenesis +ChainDB.LedgerEvent.Replay.ReplayStart.ReplayFromSnapshot +ChainDB.LedgerEvent.Snapshot.DeletedSnapshot +ChainDB.LedgerEvent.Snapshot.InvalidSnapshot +ChainDB.LedgerEvent.Snapshot.TookSnapshot +ChainDB.OpenEvent.ClosedDB +ChainDB.OpenEvent.OpenedDB +ChainDB.OpenEvent.OpenedImmutableDB +ChainDB.OpenEvent.OpenedLgrDB +ChainDB.OpenEvent.OpenedVolatileDB +ChainDB.OpenEvent.StartedOpeningDB +ChainDB.OpenEvent.StartedOpeningImmutableDB +ChainDB.OpenEvent.StartedOpeningLgrDB +ChainDB.OpenEvent.StartedOpeningVolatileDB +ChainDB.PerasCertDbEvent.AddedPerasCert +ChainDB.PerasCertDbEvent.AddingPerasCert +ChainDB.PerasCertDbEvent.ClosedPerasCertDB +ChainDB.PerasCertDbEvent.IgnoredCertAlreadyInDB +ChainDB.PerasCertDbEvent.OpenedPerasCertDB +ChainDB.ReplayBlock.LedgerReplay +ChainDB.VolatileDbEvent.BlockAlreadyHere +ChainDB.VolatileDbEvent.DBAlreadyClosed +ChainDB.VolatileDbEvent.DBClosed +ChainDB.VolatileDbEvent.InvalidFileNames +ChainDB.VolatileDbEvent.Truncate +ChainSync.Client.AccessingForecastHorizon +ChainSync.Client.DownloadedHeader +ChainSync.Client.DrainingThePipe +ChainSync.Client.Exception +ChainSync.Client.FoundIntersection +ChainSync.Client.GaveLoPToken +ChainSync.Client.JumpResult +ChainSync.Client.JumpingInstructionIs +ChainSync.Client.JumpingWaitingForNextInstruction +ChainSync.Client.OfferJump +ChainSync.Client.RolledBack +ChainSync.Client.Termination +ChainSync.Client.ValidatedHeader +ChainSync.Client.WaitingBeyondForecastHorizon +ChainSync.Local.Receive.AwaitReply +ChainSync.Local.Receive.Done +ChainSync.Local.Receive.FindIntersect +ChainSync.Local.Receive.IntersectFound +ChainSync.Local.Receive.IntersectNotFound +ChainSync.Local.Receive.RequestNext +ChainSync.Local.Receive.RollBackward +ChainSync.Local.Receive.RollForward +ChainSync.Local.Send.AwaitReply +ChainSync.Local.Send.Done +ChainSync.Local.Send.FindIntersect +ChainSync.Local.Send.IntersectFound +ChainSync.Local.Send.IntersectNotFound +ChainSync.Local.Send.RequestNext +ChainSync.Local.Send.RollBackward +ChainSync.Local.Send.RollForward +ChainSync.Remote.Receive.AwaitReply +ChainSync.Remote.Receive.Done +ChainSync.Remote.Receive.FindIntersect +ChainSync.Remote.Receive.IntersectFound +ChainSync.Remote.Receive.IntersectNotFound +ChainSync.Remote.Receive.RequestNext +ChainSync.Remote.Receive.RollBackward +ChainSync.Remote.Receive.RollForward +ChainSync.Remote.Send.AwaitReply +ChainSync.Remote.Send.Done +ChainSync.Remote.Send.FindIntersect +ChainSync.Remote.Send.IntersectFound +ChainSync.Remote.Send.IntersectNotFound +ChainSync.Remote.Send.RequestNext +ChainSync.Remote.Send.RollBackward +ChainSync.Remote.Send.RollForward +ChainSync.Remote.Serialised.Receive.AwaitReply +ChainSync.Remote.Serialised.Receive.Done +ChainSync.Remote.Serialised.Receive.FindIntersect +ChainSync.Remote.Serialised.Receive.IntersectFound +ChainSync.Remote.Serialised.Receive.IntersectNotFound +ChainSync.Remote.Serialised.Receive.RequestNext +ChainSync.Remote.Serialised.Receive.RollBackward +ChainSync.Remote.Serialised.Receive.RollForward +ChainSync.Remote.Serialised.Send.AwaitReply +ChainSync.Remote.Serialised.Send.Done +ChainSync.Remote.Serialised.Send.FindIntersect +ChainSync.Remote.Serialised.Send.IntersectFound +ChainSync.Remote.Serialised.Send.IntersectNotFound +ChainSync.Remote.Serialised.Send.RequestNext +ChainSync.Remote.Serialised.Send.RollBackward +ChainSync.Remote.Serialised.Send.RollForward +ChainSync.ServerBlock.Update +ChainSync.ServerHeader.Update +Consensus.CSJ.BecomingObjector +Consensus.CSJ.BlockedOnJump +Consensus.CSJ.InitializedAsDynamo +Consensus.CSJ.NoLongerDynamo +Consensus.CSJ.NoLongerObjector +Consensus.CSJ.SentJumpInstruction +Consensus.DevotedBlockFetch.RotatedDynamo +Consensus.GDD.TraceGDDEvent +Consensus.GSM.EnterCaughtUp +Consensus.GSM.InitializedInCaughtUp +Consensus.GSM.InitializedInPreSyncing +Consensus.GSM.LeaveCaughtUp +Consensus.GSM.PreSyncingToSyncing +Consensus.GSM.SyncingToPreSyncing +Consensus.SanityCheck.SanityCheckIssue +Consensus.Startup.ConsensusStartupException +Forge.Loop.AdoptedBlock +Forge.Loop.AdoptionThreadDied +Forge.Loop.BlockContext +Forge.Loop.BlockFromFuture +Forge.Loop.DidntAdoptBlock +Forge.Loop.ForgeStateUpdateError +Forge.Loop.ForgeTickedLedgerState +Forge.Loop.ForgedBlock +Forge.Loop.ForgedInvalidBlock +Forge.Loop.ForgingMempoolSnapshot +Forge.Loop.LedgerState +Forge.Loop.LedgerView +Forge.Loop.NoLedgerState +Forge.Loop.NoLedgerView +Forge.Loop.NodeCannotForge +Forge.Loop.NodeIsLeader +Forge.Loop.NodeNotLeader +Forge.Loop.SlotIsImmutable +Forge.Loop.StartLeadershipCheck +Forge.StateInfo +Forge.ThreadStats.ForgingStats +LedgerMetrics +Mempool.AddedTx +Mempool.AttemptAdd +Mempool.ManuallyRemovedTxs +Mempool.RejectedTx +Mempool.RemoveTxs +Mempool.SyncNotNeeded +Mempool.Synced +Mempool.TipMovedBetweenSTMBlocks +Net.AcceptPolicy.ConnectionHardLimit +Net.AcceptPolicy.ConnectionLimitResume +Net.AcceptPolicy.ConnectionRateLimiting +Net.ConnectionManager.Local.Connect +Net.ConnectionManager.Local.ConnectError +Net.ConnectionManager.Local.ConnectionCleanup +Net.ConnectionManager.Local.ConnectionExists +Net.ConnectionManager.Local.ConnectionFailure +Net.ConnectionManager.Local.ConnectionHandler.Error +Net.ConnectionManager.Local.ConnectionHandler.HandshakeClientError +Net.ConnectionManager.Local.ConnectionHandler.HandshakeQuery +Net.ConnectionManager.Local.ConnectionHandler.HandshakeServerError +Net.ConnectionManager.Local.ConnectionHandler.HandshakeSuccess +Net.ConnectionManager.Local.ConnectionManagerCounters +Net.ConnectionManager.Local.ConnectionNotFound +Net.ConnectionManager.Local.ConnectionTimeWait +Net.ConnectionManager.Local.ConnectionTimeWaitDone +Net.ConnectionManager.Local.ForbiddenConnection +Net.ConnectionManager.Local.ForbiddenOperation +Net.ConnectionManager.Local.IncludeConnection +Net.ConnectionManager.Local.PruneConnections +Net.ConnectionManager.Local.Shutdown +Net.ConnectionManager.Local.State +Net.ConnectionManager.Local.TerminatedConnection +Net.ConnectionManager.Local.TerminatingConnection +Net.ConnectionManager.Local.UnexpectedlyFalseAssertion +Net.ConnectionManager.Local.UnregisterConnection +Net.ConnectionManager.Remote.Connect +Net.ConnectionManager.Remote.ConnectError +Net.ConnectionManager.Remote.ConnectionCleanup +Net.ConnectionManager.Remote.ConnectionExists +Net.ConnectionManager.Remote.ConnectionFailure +Net.ConnectionManager.Remote.ConnectionHandler.Error +Net.ConnectionManager.Remote.ConnectionHandler.HandshakeClientError +Net.ConnectionManager.Remote.ConnectionHandler.HandshakeQuery +Net.ConnectionManager.Remote.ConnectionHandler.HandshakeServerError +Net.ConnectionManager.Remote.ConnectionHandler.HandshakeSuccess +Net.ConnectionManager.Remote.ConnectionManagerCounters +Net.ConnectionManager.Remote.ConnectionNotFound +Net.ConnectionManager.Remote.ConnectionTimeWait +Net.ConnectionManager.Remote.ConnectionTimeWaitDone +Net.ConnectionManager.Remote.ForbiddenConnection +Net.ConnectionManager.Remote.ForbiddenOperation +Net.ConnectionManager.Remote.IncludeConnection +Net.ConnectionManager.Remote.PruneConnections +Net.ConnectionManager.Remote.Shutdown +Net.ConnectionManager.Remote.State +Net.ConnectionManager.Remote.TerminatedConnection +Net.ConnectionManager.Remote.TerminatingConnection +Net.ConnectionManager.Remote.UnexpectedlyFalseAssertion +Net.ConnectionManager.Remote.UnregisterConnection +Net.ConnectionManager.Transition.Transition +Net.InboundGovernor.Local.DemotedToColdRemote +Net.InboundGovernor.Local.DemotedToWarmRemote +Net.InboundGovernor.Local.Inactive +Net.InboundGovernor.Local.InboundGovernorCounters +Net.InboundGovernor.Local.InboundGovernorError +Net.InboundGovernor.Local.MaturedConnections +Net.InboundGovernor.Local.MuxCleanExit +Net.InboundGovernor.Local.MuxErrored +Net.InboundGovernor.Local.NewConnection +Net.InboundGovernor.Local.PromotedToHotRemote +Net.InboundGovernor.Local.PromotedToWarmRemote +Net.InboundGovernor.Local.RemoteState +Net.InboundGovernor.Local.ResponderErrored +Net.InboundGovernor.Local.ResponderRestarted +Net.InboundGovernor.Local.ResponderStartFailure +Net.InboundGovernor.Local.ResponderStarted +Net.InboundGovernor.Local.ResponderTerminated +Net.InboundGovernor.Local.UnexpectedlyFalseAssertion +Net.InboundGovernor.Local.WaitIdleRemote +Net.InboundGovernor.Remote.DemotedToColdRemote +Net.InboundGovernor.Remote.DemotedToWarmRemote +Net.InboundGovernor.Remote.Inactive +Net.InboundGovernor.Remote.InboundGovernorCounters +Net.InboundGovernor.Remote.InboundGovernorError +Net.InboundGovernor.Remote.MaturedConnections +Net.InboundGovernor.Remote.MuxCleanExit +Net.InboundGovernor.Remote.MuxErrored +Net.InboundGovernor.Remote.NewConnection +Net.InboundGovernor.Remote.PromotedToHotRemote +Net.InboundGovernor.Remote.PromotedToWarmRemote +Net.InboundGovernor.Remote.RemoteState +Net.InboundGovernor.Remote.ResponderErrored +Net.InboundGovernor.Remote.ResponderRestarted +Net.InboundGovernor.Remote.ResponderStartFailure +Net.InboundGovernor.Remote.ResponderStarted +Net.InboundGovernor.Remote.ResponderTerminated +Net.InboundGovernor.Remote.UnexpectedlyFalseAssertion +Net.InboundGovernor.Remote.WaitIdleRemote +Net.InboundGovernor.Transition.Transition +Net.KeepAliveClient +Net.Mux.Local.CleanExit +Net.Mux.Local.ExceptionExit +Net.Mux.Local.NewMux +Net.Mux.Local.StartEagerly +Net.Mux.Local.StartOnDemand +Net.Mux.Local.StartOnDemandAny +Net.Mux.Local.StartedOnDemand +Net.Mux.Local.Starting +Net.Mux.Local.State +Net.Mux.Local.Stopped +Net.Mux.Local.Stopping +Net.Mux.Local.Terminating +Net.Mux.Remote.CleanExit +Net.Mux.Remote.ExceptionExit +Net.Mux.Remote.NewMux +Net.Mux.Remote.StartEagerly +Net.Mux.Remote.StartOnDemand +Net.Mux.Remote.StartOnDemandAny +Net.Mux.Remote.StartedOnDemand +Net.Mux.Remote.Starting +Net.Mux.Remote.State +Net.Mux.Remote.Stopped +Net.Mux.Remote.Stopping +Net.Mux.Remote.Terminating +Net.PeerSelection.Actions.ConnectionError +Net.PeerSelection.Actions.MonitoringError +Net.PeerSelection.Actions.MonitoringResult +Net.PeerSelection.Actions.PeerHotDuration +Net.PeerSelection.Actions.StatusChangeFailure +Net.PeerSelection.Actions.StatusChanged +Net.PeerSelection.Counters.Counters +Net.PeerSelection.Initiator.GovernorState +Net.PeerSelection.Responder.GovernorState +Net.PeerSelection.Selection.BigLedgerPeersFailure +Net.PeerSelection.Selection.BigLedgerPeersRequest +Net.PeerSelection.Selection.BigLedgerPeersResults +Net.PeerSelection.Selection.BootstrapPeersFlagChangedWhilstInSensitiveState +Net.PeerSelection.Selection.ChurnAction +Net.PeerSelection.Selection.ChurnTimeout +Net.PeerSelection.Selection.ChurnWait +Net.PeerSelection.Selection.DebugState +Net.PeerSelection.Selection.DemoteAsynchronous +Net.PeerSelection.Selection.DemoteBigLedgerPeersAsynchronous +Net.PeerSelection.Selection.DemoteHotBigLedgerPeerDone +Net.PeerSelection.Selection.DemoteHotBigLedgerPeerFailed +Net.PeerSelection.Selection.DemoteHotBigLedgerPeerFailed.CoolingToColdTimeout +Net.PeerSelection.Selection.DemoteHotBigLedgerPeers +Net.PeerSelection.Selection.DemoteHotDone +Net.PeerSelection.Selection.DemoteHotFailed +Net.PeerSelection.Selection.DemoteHotFailed.CoolingToColdTimeout +Net.PeerSelection.Selection.DemoteHotPeers +Net.PeerSelection.Selection.DemoteLocalAsynchronous +Net.PeerSelection.Selection.DemoteLocalHotPeers +Net.PeerSelection.Selection.DemoteWarmBigLedgerPeerDone +Net.PeerSelection.Selection.DemoteWarmBigLedgerPeerFailed +Net.PeerSelection.Selection.DemoteWarmBigLedgerPeerFailed.CoolingToColdTimeout +Net.PeerSelection.Selection.DemoteWarmBigLedgerPeers +Net.PeerSelection.Selection.DemoteWarmDone +Net.PeerSelection.Selection.DemoteWarmFailed +Net.PeerSelection.Selection.DemoteWarmFailed.CoolingToColdTimeout +Net.PeerSelection.Selection.DemoteWarmPeers +Net.PeerSelection.Selection.ForgetBigLedgerPeers +Net.PeerSelection.Selection.ForgetColdPeers +Net.PeerSelection.Selection.GovernorWakeup +Net.PeerSelection.Selection.LedgerStateJudgementChanged +Net.PeerSelection.Selection.LocalRootPeersChanged +Net.PeerSelection.Selection.OnlyBootstrapPeers +Net.PeerSelection.Selection.OutboundGovernorCriticalFailure +Net.PeerSelection.Selection.PeerShareRequests +Net.PeerSelection.Selection.PeerShareResults +Net.PeerSelection.Selection.PeerShareResultsFiltered +Net.PeerSelection.Selection.PickInboundPeers +Net.PeerSelection.Selection.PromoteColdBigLedgerPeerDone +Net.PeerSelection.Selection.PromoteColdBigLedgerPeerFailed +Net.PeerSelection.Selection.PromoteColdBigLedgerPeers +Net.PeerSelection.Selection.PromoteColdDone +Net.PeerSelection.Selection.PromoteColdFailed +Net.PeerSelection.Selection.PromoteColdLocalPeers +Net.PeerSelection.Selection.PromoteColdPeers +Net.PeerSelection.Selection.PromoteWarmAborted +Net.PeerSelection.Selection.PromoteWarmBigLedgerPeerAborted +Net.PeerSelection.Selection.PromoteWarmBigLedgerPeerDone +Net.PeerSelection.Selection.PromoteWarmBigLedgerPeerFailed +Net.PeerSelection.Selection.PromoteWarmBigLedgerPeers +Net.PeerSelection.Selection.PromoteWarmDone +Net.PeerSelection.Selection.PromoteWarmFailed +Net.PeerSelection.Selection.PromoteWarmLocalPeers +Net.PeerSelection.Selection.PromoteWarmPeers +Net.PeerSelection.Selection.PublicRootsFailure +Net.PeerSelection.Selection.PublicRootsRequest +Net.PeerSelection.Selection.PublicRootsResults +Net.PeerSelection.Selection.TargetsChanged +Net.PeerSelection.Selection.UseBootstrapPeersChanged +Net.PeerSelection.Selection.VerifyPeerSnapshot +Net.Peers.Ledger.DisabledLedgerPeers +Net.Peers.Ledger.FallingBackToPublicRootPeers +Net.Peers.Ledger.FetchingNewLedgerState +Net.Peers.Ledger.NotEnoughBigLedgerPeers +Net.Peers.Ledger.NotEnoughLedgerPeers +Net.Peers.Ledger.PickedBigLedgerPeer +Net.Peers.Ledger.PickedBigLedgerPeers +Net.Peers.Ledger.PickedLedgerPeer +Net.Peers.Ledger.PickedLedgerPeers +Net.Peers.Ledger.RequestForPeers +Net.Peers.Ledger.ReusingLedgerState +Net.Peers.Ledger.TraceLedgerPeersDomains +Net.Peers.Ledger.TraceUseLedgerAfter +Net.Peers.Ledger.UsingBigLedgerPeerSnapshot +Net.Peers.Ledger.WaitingOnRequest +Net.Peers.LocalRoot.LocalRootDNSMap +Net.Peers.LocalRoot.LocalRootDomains +Net.Peers.LocalRoot.LocalRootError +Net.Peers.LocalRoot.LocalRootFailure +Net.Peers.LocalRoot.LocalRootGroups +Net.Peers.LocalRoot.LocalRootReconfigured +Net.Peers.LocalRoot.LocalRootWaiting +Net.Peers.PublicRoot.PublicRootDomains +Net.Peers.PublicRoot.PublicRootRelayAccessPoint +Net.Server.Local.AcceptConnection +Net.Server.Local.AcceptError +Net.Server.Local.AcceptPolicy +Net.Server.Local.Error +Net.Server.Local.Started +Net.Server.Local.Stopped +Net.Server.Remote.AcceptConnection +Net.Server.Remote.AcceptError +Net.Server.Remote.AcceptPolicy +Net.Server.Remote.Error +Net.Server.Remote.Started +Net.Server.Remote.Stopped +NodeInfo +NodeStartupInfo +NodeState.NodeAddBlock +NodeState.NodeInitChainSelection +NodeState.NodeKernelOnline +NodeState.NodeReplays +NodeState.NodeShutdown +NodeState.NodeStartup +NodeState.NodeTracingFailure +NodeState.NodeTracingForwardingInterrupted +NodeState.NodeTracingOnlineConfiguring +NodeState.OpeningDbs +NodeState.PrometheusSimple.Start +NodeState.PrometheusSimple.Stop +RPC.Error +RPC.FatalError +RPC.QueryService.ReadParams.Span +RPC.QueryService.ReadUtxos.Span +RPC.SubmitService.N2cConnectionError +RPC.SubmitService.SubmitTx.Span +RPC.SubmitService.TxDecodingError +RPC.SubmitService.TxValidationError +Reflection.MetricsInfo +Reflection.RememberLimiting +Reflection.StartLimiting +Reflection.StopLimiting +Reflection.TracerConfigInfo +Reflection.TracerConsistencyWarnings +Reflection.TracerInfo +Reflection.UnknownNamespace +Resources +Shutdown.Abnormal +Shutdown.ArmedAt +Shutdown.Requested +Shutdown.Requesting +Shutdown.UnexpectedInput +Startup.BlockForgingBlockTypeMismatch +Startup.BlockForgingUpdate +Startup.Byron +Startup.Common +Startup.DBValidation +Startup.DiffusionInit.ConfiguringLocalSocket +Startup.DiffusionInit.ConfiguringServerSocket +Startup.DiffusionInit.CreateSystemdSocketForSnocketPath +Startup.DiffusionInit.CreatedLocalSocket +Startup.DiffusionInit.CreatingServerSocket +Startup.DiffusionInit.DiffusionErrored +Startup.DiffusionInit.ListeningLocalSocket +Startup.DiffusionInit.ListeningServerSocket +Startup.DiffusionInit.LocalSocketUp +Startup.DiffusionInit.RunLocalServer +Startup.DiffusionInit.RunServer +Startup.DiffusionInit.ServerSocketUp +Startup.DiffusionInit.SystemdSocketConfiguration +Startup.DiffusionInit.UnsupportedLocalSystemdSocket +Startup.DiffusionInit.UnsupportedReadySocketCase +Startup.DiffusionInit.UsingSystemdSocket +Startup.Info +Startup.LedgerPeerSnapshot +Startup.LedgerPeerSnapshot.Incompatible +Startup.MovedTopLevelOption +Startup.Network +Startup.NetworkConfig +Startup.NetworkConfigUpdate +Startup.NetworkConfigUpdateError +Startup.NetworkConfigUpdateUnsupported +Startup.NetworkMagic +Startup.NonP2PWarning +Startup.P2PInfo +Startup.ShelleyBased +Startup.SocketConfigError +Startup.Time +Startup.WarningDevelopmentNodeToClientVersions +Startup.WarningDevelopmentNodeToNodeVersions +StateQueryServer.Receive.Acquire +StateQueryServer.Receive.Acquired +StateQueryServer.Receive.Done +StateQueryServer.Receive.Failure +StateQueryServer.Receive.Query +StateQueryServer.Receive.ReAcquire +StateQueryServer.Receive.Release +StateQueryServer.Receive.Result +StateQueryServer.Send.Acquire +StateQueryServer.Send.Acquired +StateQueryServer.Send.Done +StateQueryServer.Send.Failure +StateQueryServer.Send.Query +StateQueryServer.Send.ReAcquire +StateQueryServer.Send.Release +StateQueryServer.Send.Result +TxSubmission.Local.Receive.AcceptTx +TxSubmission.Local.Receive.Done +TxSubmission.Local.Receive.RejectTx +TxSubmission.Local.Receive.SubmitTx +TxSubmission.Local.Send.AcceptTx +TxSubmission.Local.Send.Done +TxSubmission.Local.Send.RejectTx +TxSubmission.Local.Send.SubmitTx +TxSubmission.LocalServer.ReceivedTx +TxSubmission.MonitorClient.Receive.Acquire +TxSubmission.MonitorClient.Receive.Acquired +TxSubmission.MonitorClient.Receive.AwaitAcquire +TxSubmission.MonitorClient.Receive.Done +TxSubmission.MonitorClient.Receive.GetMeasures +TxSubmission.MonitorClient.Receive.GetSizes +TxSubmission.MonitorClient.Receive.HasTx +TxSubmission.MonitorClient.Receive.NextTx +TxSubmission.MonitorClient.Receive.Release +TxSubmission.MonitorClient.Receive.ReplyGetMeasures +TxSubmission.MonitorClient.Receive.ReplyGetSizes +TxSubmission.MonitorClient.Receive.ReplyHasTx +TxSubmission.MonitorClient.Receive.ReplyNextTx +TxSubmission.MonitorClient.Send.Acquire +TxSubmission.MonitorClient.Send.Acquired +TxSubmission.MonitorClient.Send.AwaitAcquire +TxSubmission.MonitorClient.Send.Done +TxSubmission.MonitorClient.Send.GetMeasures +TxSubmission.MonitorClient.Send.GetSizes +TxSubmission.MonitorClient.Send.HasTx +TxSubmission.MonitorClient.Send.NextTx +TxSubmission.MonitorClient.Send.Release +TxSubmission.MonitorClient.Send.ReplyGetMeasures +TxSubmission.MonitorClient.Send.ReplyGetSizes +TxSubmission.MonitorClient.Send.ReplyHasTx +TxSubmission.MonitorClient.Send.ReplyNextTx +TxSubmission.Remote.Receive.Done +TxSubmission.Remote.Receive.MsgInit +TxSubmission.Remote.Receive.ReplyTxIds +TxSubmission.Remote.Receive.ReplyTxs +TxSubmission.Remote.Receive.RequestTxIds +TxSubmission.Remote.Receive.RequestTxs +TxSubmission.Remote.Send.Done +TxSubmission.Remote.Send.MsgInit +TxSubmission.Remote.Send.ReplyTxIds +TxSubmission.Remote.Send.ReplyTxs +TxSubmission.Remote.Send.RequestTxIds +TxSubmission.Remote.Send.RequestTxs +TxSubmission.TxInbound.AddedToMempool +TxSubmission.TxInbound.CanRequestMoreTxs +TxSubmission.TxInbound.CannotRequestMoreTxs +TxSubmission.TxInbound.Collected +TxSubmission.TxInbound.Decision +TxSubmission.TxInbound.Error +TxSubmission.TxInbound.Processed +TxSubmission.TxInbound.RejectedFromMempool +TxSubmission.TxInbound.Terminated +TxSubmission.TxOutbound.ControlMessage +TxSubmission.TxOutbound.RecvMsgRequest +TxSubmission.TxOutbound.SendMsgReply +Version.NodeVersion diff --git a/bench/trace-schemas/overrides/README.md b/bench/trace-schemas/overrides/README.md new file mode 100644 index 00000000000..34522f0c41a --- /dev/null +++ b/bench/trace-schemas/overrides/README.md @@ -0,0 +1,181 @@ +# Trace Schema Overrides + +Use this directory for human-maintained patches that must survive schema regeneration. + +## Why + +Files under `bench/trace-schemas/messages` and `bench/trace-schemas/types` are generated. +Direct edits in those generated files are hard to track and can be overwritten. + +Store manual changes as sidecar override files here instead. + +## Layout + +Mirror the generated tree, with `.override.json` suffix: + +- `bench/trace-schemas/overrides/messages/.../Foo.schema.override.json` +- `bench/trace-schemas/overrides/types/.../Bar.schema.override.json` + +Each override maps to a target by: + +- removing the `overrides/` path segment +- replacing `.schema.override.json` with `.schema.json` + +Example: + +- Override: `bench/trace-schemas/overrides/messages/Startup/Info.schema.override.json` +- Target: `bench/trace-schemas/messages/Startup/Info.schema.json` + +## Override format + +Override files use JSON Merge Patch semantics (RFC 7396). + +You can use either: + +1. A raw patch object. +2. An envelope with metadata: + +```json +{ + "_meta": { + "owner": "tracing-team", + "reason": "Keep strict enum until upstream type metadata is available", + }, + "patch": { + "data": { + "properties": { + "kind": { + "enum": ["ExpectedKindA", "ExpectedKindB"] + } + } + } + } +} +``` + +Notes: + +- Set a key to `null` in a patch to delete it. +- Arrays are replaced as whole values (standard merge-patch behavior). + +### RFC 7396 behavior summary + +Merge Patch is value-oriented and simple: + +- If the patch is an object, it is merged key-by-key into the target object. +- If a patch key value is `null`, that key is removed from the target object. +- If a patch key value is an object, merge continues recursively. +- If a patch key value is a scalar (`string`, `number`, `boolean`) or an array, that value fully replaces the target value. +- If the patch itself is not an object (for example an array or string), it replaces the whole target document. + +Practical implications for schema overrides: + +- Prefer object patches to avoid replacing entire schema files. +- Be explicit when patching `required`: it is an array, so your patch replaces the full `required` list. +- Deleting one item from an array is not supported directly by merge patch; replace the array with the exact desired final array. +- Keep patches focused to the minimal affected subtree to reduce conflicts during regeneration. + +### Mini before/after example + +Target fragment: + +```json +{ + "data": { + "properties": { + "kind": { "type": "string" }, + "error": { "type": "string" } + }, + "required": ["kind"] + } +} +``` + +Patch: + +```json +{ + "data": { + "properties": { + "error": null, + "kind": { + "enum": ["A", "B"] + } + }, + "required": ["kind", "code"] + } +} +``` + +Result: + +- `data.properties.error` is removed. +- `data.properties.kind` is updated (merged/replaced under that key). +- `data.required` becomes exactly `["kind", "code"]`. + +## Examples + +Concrete example files are also available in: + +`bench/trace-schemas/overrides/examples/` + +### 1) Raw patch: tighten an enum in a message schema + +`bench/trace-schemas/overrides/messages/Startup/Info.schema.override.json` + +```json +{ + "data": { + "properties": { + "kind": { + "enum": ["StartupInfo", "StartupInfoLegacy"] + } + } + } +} +``` + +### 2) Envelope patch with metadata: add description and required field + +`bench/trace-schemas/overrides/messages/Net/Server/Local/Error.schema.override.json` + +```json +{ + "_meta": { + "owner": "tracing-team", + "reason": "Document operator-facing semantics", + }, + "patch": { + "data": { + "description": "Local server accept loop error payload", + "required": ["kind", "error"] + } + } +} +``` + +### 3) Delete generated key: remove an unwanted property + +`bench/trace-schemas/overrides/types/ConnectionId.schema.override.json` + +```json +{ + "properties": { + "legacyDebugField": null + } +} +``` + +## Apply / Check + +Apply overrides: + +`nix run .#apply-schema-overrides -- --verbose` + +Check that overrides are already applied: + +`nix run .#apply-schema-overrides -- --check --verbose` + +Fail when generated schema files changed without matching override file updates: + +`nix run .#check-override-coverage -- --range origin/master...HEAD` diff --git a/bench/trace-schemas/overrides/examples/01-startup-info.schema.override.example.json b/bench/trace-schemas/overrides/examples/01-startup-info.schema.override.example.json new file mode 100644 index 00000000000..e121b260fea --- /dev/null +++ b/bench/trace-schemas/overrides/examples/01-startup-info.schema.override.example.json @@ -0,0 +1,13 @@ +{ + "_target": "bench/trace-schemas/messages/Startup/Info.schema.json", + "data": { + "properties": { + "kind": { + "enum": [ + "StartupInfo", + "StartupInfoLegacy" + ] + } + } + } +} diff --git a/bench/trace-schemas/overrides/examples/02-net-server-local-error.schema.override.example.json b/bench/trace-schemas/overrides/examples/02-net-server-local-error.schema.override.example.json new file mode 100644 index 00000000000..0ec68cd5f9a --- /dev/null +++ b/bench/trace-schemas/overrides/examples/02-net-server-local-error.schema.override.example.json @@ -0,0 +1,16 @@ +{ + "_target": "bench/trace-schemas/messages/Net/Server/Local/Error.schema.json", + "_meta": { + "owner": "tracing-team", + "reason": "Document operator-facing semantics" + }, + "patch": { + "data": { + "description": "Local server accept loop error payload", + "required": [ + "kind", + "error" + ] + } + } +} \ No newline at end of file diff --git a/bench/trace-schemas/overrides/examples/03-connection-id.schema.override.example.json b/bench/trace-schemas/overrides/examples/03-connection-id.schema.override.example.json new file mode 100644 index 00000000000..513e2cf3520 --- /dev/null +++ b/bench/trace-schemas/overrides/examples/03-connection-id.schema.override.example.json @@ -0,0 +1,6 @@ +{ + "_target": "bench/trace-schemas/types/ConnectionId.schema.json", + "properties": { + "legacyDebugField": null + } +} diff --git a/bench/trace-schemas/scripts/schema-gen/ApplySchemaOverrides.hs b/bench/trace-schemas/scripts/schema-gen/ApplySchemaOverrides.hs new file mode 100644 index 00000000000..27957d7f5e5 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/ApplySchemaOverrides.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified TraceSchemaGen.ApplySchemaOverrides as Apply + +main :: IO () +main = Apply.main diff --git a/bench/trace-schemas/scripts/schema-gen/CheckOverrideCoverage.hs b/bench/trace-schemas/scripts/schema-gen/CheckOverrideCoverage.hs new file mode 100644 index 00000000000..983cbbc720c --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/CheckOverrideCoverage.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified TraceSchemaGen.CheckOverrideCoverage as Coverage + +main :: IO () +main = Coverage.main diff --git a/bench/trace-schemas/scripts/schema-gen/GhciSchemaGen.hs b/bench/trace-schemas/scripts/schema-gen/GhciSchemaGen.hs new file mode 100644 index 00000000000..63ba981a475 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/GhciSchemaGen.hs @@ -0,0 +1,2027 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Aeson.Key as K +import qualified Data.Vector as V +import Data.Char (isAlphaNum, isLower, isUpper, isSpace, toLower) +import Data.List (elemIndex, foldl', isInfixOf, isPrefixOf, isSuffixOf, sortOn, stripPrefix) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Ord (Down (..)) +import System.Directory +import System.Environment (getArgs) +import System.FilePath +import System.Process +import System.Exit +import System.IO +import Data.IORef +import Control.Exception (catch, IOException, bracket) +import qualified Data.Aeson as A +import qualified Data.Aeson.Encode.Pretty as AP +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Control.Monad (filterM, forM, guard, unless, when) + +-------------------------------------------------------------------------------- +-- Entry point / high-level flow +-------------------------------------------------------------------------------- + +rootDirs :: [FilePath] +rootDirs = + [ "cardano-node/src" + , "cardano-submit-api/src" + , "cardano-tracer/src" + , "../ouroboros-network/ouroboros-network/lib" + , "../ouroboros-network/ouroboros-network/tracing" + , "../ouroboros-network/ouroboros-network/protocols/lib" + , "../ouroboros-network/ouroboros-network/api/lib" + , "../ouroboros-network/network-mux/src" + , "../ouroboros-network/cardano-diffusion/lib" + , "../ouroboros-network/cardano-diffusion/tracing" + , "../ouroboros-network/cardano-diffusion/protocols/lib" + , "../ouroboros-network/cardano-diffusion/api/lib" + , "../ouroboros-network/cardano-diffusion/subscription" + , "../ouroboros-consensus/ouroboros-consensus/src/ouroboros-consensus" + , "../ouroboros-consensus/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol" + , "../ouroboros-consensus/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion" + , "../ouroboros-consensus/ouroboros-consensus-cardano/src" + , "../hermod-tracing/trace-dispatcher/src" + , "trace-forward/src" + , "trace-resources/src" + ] + +type ConstructorName = String +type TypeName = String +type NamespaceParts = [String] +type DetailLevel = String +type HelperFieldMap = Map.Map String (Map.Map String String) + +diffusionHandshakeCtor :: ConstructorName +diffusionHandshakeCtor = "__DiffusionHandshakeAnyMessageAndAgency__" + +serialisedBlockFetchMsgBlockCtor :: ConstructorName +serialisedBlockFetchMsgBlockCtor = "__SerialisedBlockFetchMsgBlock__" + +connectionManagerStateCtor :: ConstructorName +connectionManagerStateCtor = "TrState" + +muxStateCtor :: ConstructorName +muxStateCtor = "TraceState" + +connectionManagerUnexpectedlyFalseAssertionCtor :: ConstructorName +connectionManagerUnexpectedlyFalseAssertionCtor = "__ConnectionManagerUnexpectedlyFalseAssertion__" + +inboundGovernorUnexpectedlyFalseAssertionCtor :: ConstructorName +inboundGovernorUnexpectedlyFalseAssertionCtor = "__InboundGovernorUnexpectedlyFalseAssertion__" + +detailLevels :: [DetailLevel] +detailLevels = ["Minimal", "Normal", "Detailed", "Maximum"] + +newtype Config = Config + { cfgPruneStaleProperties :: Bool + } + +main :: IO () +main = do + warningsRef <- newIORef [] + let emitWarning msg = do + hPutStrLn stderr msg + modifyIORef' warningsRef (<> [msg]) + config <- parseArgs =<< getArgs + let nsFile = "bench/trace-schemas/newNamespaces.txt" + putStrLn $ "Reading namespaces from " <> nsFile + namespaces <- filter (not . null) . lines <$> readFile' nsFile + putStrLn $ "Loaded " <> show (length namespaces) <> " namespace(s)" + + validatedRootDirs <- validateSourceDirs emitWarning rootDirs + putStrLn "Collecting Haskell source files..." + hsFiles <- collectTargets validatedRootDirs + putStrLn $ "Found " <> show (length hsFiles) <> " candidate source file(s)" + + -- Build constructor -> namespace map from namespaceFor clauses + putStrLn "Building namespace map..." + sources <- forM hsFiles $ \fp -> do + src <- readFileSafe fp + pure (fp, src) + let nsMap = foldl' mergeNs Map.empty [ normalizeNamespaceMap fp (parseNamespaceMap src) | (fp, src) <- sources ] + -- Parse forMachine clauses and map their field bindings to variables + putStrLn "Parsing forMachine clauses..." + let helperFieldMaps = map (parseObjectHelperMap . snd) sources + let clausesByFile = + [ (fp, parseForMachineClauses src, helpers) + | ((fp, src), helpers) <- zip sources helperFieldMaps + ] + + let fieldVarMap = + foldl' + (Map.unionWith (Map.unionWith Map.union)) + Map.empty + [ normalizeFieldVarMap fp (parseFieldVarMap helpers clauses) + | (fp, clauses, helpers) <- clausesByFile + ] + + -- Ask GHCi for variable types used in forMachine patterns + putStrLn "Querying GHCi for field types..." + varTypesMaps <- forM (zip [1 :: Int ..] clausesByFile) $ \(idx, (fp, clauses, _helpers)) -> do + putStrLn $ + "[ghci " <> show idx <> "/" <> show (length clausesByFile) <> "] " + <> fp + normalizeVarTypesMap fp <$> ghciTypesForFile fp clauses + let varTypes = foldl' (Map.unionWith Map.union) Map.empty varTypesMaps + + let msgOutDir = "bench/trace-schemas/messages" + let typeOutDir = "bench/trace-schemas/types" + createDirectoryIfMissing True msgOutDir + createDirectoryIfMissing True typeOutDir + + putStrLn "Generating schema files..." + mapM_ + (\(idx, ns) -> do + putStrLn $ + "[schema " <> show idx <> "/" <> show (length namespaces) <> "] " + <> ns + updateSchemaForNamespaceWithWarning emitWarning config msgOutDir typeOutDir nsMap fieldVarMap varTypes ns) + (zip [1 :: Int ..] namespaces) + putStrLn "Schema generation complete." + warnings <- readIORef warningsRef + unless (null warnings) $ do + let uniqueWarnings = nubPreserve warnings + putStrLn "" + putStrLn $ + "Schema generation warnings summary (" <> show (length uniqueWarnings) <> " unique warning(s)):" + mapM_ putStrLn uniqueWarnings + putStrLn $ + "Schema generation problems: " <> show (length (nubPreserve warnings)) + +parseArgs :: [String] -> IO Config +parseArgs args = + case args of + [] -> pure (Config False) + ["--prune-stale-properties"] -> pure (Config True) + ["--help"] -> printHelp >> exitSuccess + ["-h"] -> printHelp >> exitSuccess + _ -> do + putStrLn $ "Unrecognized arguments: " <> unwords args + printHelp + exitFailure + +printHelp :: IO () +printHelp = + putStrLn $ + unlines + [ "Usage: nix develop -c bash -c 'runghc bench/trace-schemas/scripts/schema-gen/GhciSchemaGen.hs [--prune-stale-properties]'" + , "" + , "Options:" + , " --prune-stale-properties Remove data.properties not supported by current inference." + ] + +-- Utilities + +validateSourceDirs :: (String -> IO ()) -> [FilePath] -> IO [FilePath] +validateSourceDirs emitWarning dirs = do + dirPresence <- forM dirs $ \dir -> do + exists <- doesDirectoryExist dir + pure (dir, exists) + let missingDirs = [dir | (dir, False) <- dirPresence] + existingDirs = [dir | (dir, True) <- dirPresence] + mapM_ (\dir -> emitWarning $ "Warning: source directory missing: " <> dir) missingDirs + when (null existingDirs) $ do + hPutStrLn stderr "Error: no configured source directories exist for schema generation." + exitFailure + pure existingDirs + +-- Read file for quick text parsing; tolerate missing files. +readFileSafe :: FilePath -> IO String +readFileSafe fp = readFile fp `catch` (\(_e :: IOException) -> pure "") + +collectTargets :: [FilePath] -> IO [FilePath] +collectTargets roots = do + files <- concat <$> mapM listHsFiles roots + filterM (\fp -> do + content <- T.readFile fp + if "forMachine" `T.isInfixOf` content || "namespaceFor" `T.isInfixOf` content + then pure True + else pure False) files + +listHsFiles :: FilePath -> IO [FilePath] +listHsFiles root = do + exists <- doesDirectoryExist root + if not exists then pure [] else go root + where + go dir = do + entries <- listDirectory dir + concat <$> mapM (\e -> do + let p = dir e + isDir <- doesDirectoryExist p + if isDir then go p else pure [p | ".hs" `isSuffixOf` p]) entries + +-- Namespace mapping + +mergeNs :: Map.Map ConstructorName [NamespaceParts] + -> Map.Map ConstructorName [NamespaceParts] + -> Map.Map ConstructorName [NamespaceParts] +mergeNs = Map.unionWith (++) + +-- Parse namespaceFor clauses and collect constructor -> namespace mappings. +parseNamespaceMap :: String -> Map.Map ConstructorName [NamespaceParts] +parseNamespaceMap src = go Nothing (lines src) Map.empty + where + typeConstructors = parseTypeConstructors src + + startsHeader line = + "namespaceFor" `isPrefixOf` trim line + + go _ [] acc = acc + go currentType allLines@(l:ls) acc + | startsMetaTraceInstance l = + let (_hdr, rest, nextType) = spanMetaTraceInstanceHeader allLines + in go nextType rest acc + | startsTopLevelDecl l = + go Nothing ls acc + | startsHeader l = + let (headerLines, afterHeader) = spanUntilHeaderEnd [l] ls + (bodyLines, rest) = spanNamespaceBody afterHeader + clauseLines = headerLines ++ bodyLines + header = unwords headerLines + bodyAfterLambda = dropLeadingLambdaCase bodyLines + acc' + | "\\case" `isInfixOf` header || isLambdaCaseBody bodyLines = + foldl' insertNamespaceClause acc (parseNamespaceLambdaClauses bodyAfterLambda) + | hasBranchArrows bodyLines = + case ctorsAfter "namespaceFor" (takeWhile (/= '=') (unwords headerLines)) of + [] -> acc + ctors -> foldl' insertNamespaceClause acc (parseNamespaceCaseBranches ctors bodyLines) + | otherwise = + case extractNamespaceClause currentType typeConstructors (unwords clauseLines) of + Just clauseInfo -> insertNamespaceClause acc clauseInfo + Nothing -> acc + in go currentType rest acc' + | otherwise = go currentType ls acc + + spanUntilHeaderEnd acc [] = (reverse acc, []) + spanUntilHeaderEnd acc (x:xs) + | any ("=" `isInfixOf`) acc = (reverse acc, x:xs) + | otherwise = spanUntilHeaderEnd (x:acc) xs + + spanNamespaceBody [] = ([], []) + spanNamespaceBody allLines@(x:xs) + | startsTopLevelMethod x = ([], allLines) + | otherwise = + let (body, rest) = break startsTopLevelMethod xs + in (x : body, rest) + + startsTopLevelMethod line = + let t = trim line + in any (`isPrefixOf` t) + [ "namespaceFor" + , "severityFor" + , "privacyFor" + , "detailsFor" + , "documentFor" + , "allNamespaces" + , "metricsDocFor" + ] + + startsTopLevelDecl line = + let t = trim line + in not (null line) + && not (startsIndented line) + && not ("--" `isPrefixOf` t) + && any (`isPrefixOf` t) + [ "instance" + , "data " + , "newtype " + , "type " + , "class " + ] + + startsMetaTraceInstance line = + let t = trim line + in "instance" `isPrefixOf` t && "MetaTrace" `isInfixOf` t + + spanMetaTraceInstanceHeader :: [String] -> ([String], [String], Maybe TypeName) + spanMetaTraceInstanceHeader [] = ([], [], Nothing) + spanMetaTraceInstanceHeader (x:xs) = finish [x] xs + where + finish acc [] = + let hdr = reverse acc + in (hdr, [], parseMetaTraceInstanceType (unwords hdr)) + finish acc rest@(y:ys) + | any ("where" `isInfixOf`) acc = + let hdr = reverse acc + in (hdr, rest, parseMetaTraceInstanceType (unwords hdr)) + | otherwise = finish (y:acc) ys + + extractNamespaceClause currentType ctorMap clause = do + guard ("namespaceFor" `isInfixOf` clause) + let lhs = takeWhile (/= '=') clause + parts <- extractNamespaceParts clause + let ctors = ctorsAfter "namespaceFor" lhs + let inferredCtors = + case ctors of + [] | isWildcardNamespaceLhs lhs -> + maybe [] (`singletonConstructors` ctorMap) currentType + [] | isListEmptyNamespaceLhs lhs -> + [listEmptyCtor] + _ -> ctors + guard (not (null inferredCtors)) + pure (inferredCtors, parts) + +parseMetaTraceInstanceType :: String -> Maybe TypeName +parseMetaTraceInstanceType hdr = do + (_, rest) <- breakSub "MetaTrace" hdr + let tyExpr = trim . takeWhile (/= '=') . fst $ breakOn "where" (stripOuterParens (trim rest)) + guard (not (null tyExpr)) + guard (headMay tyExpr /= Just '[') + firstCtorToken tyExpr + +isWildcardNamespaceLhs :: String -> Bool +isWildcardNamespaceLhs lhs = + let marker = ("namespaceFor" :: String) + after = trim (drop (length marker) lhs) + in after == "_" + +isListEmptyNamespaceLhs :: String -> Bool +isListEmptyNamespaceLhs lhs = + let marker = ("namespaceFor" :: String) + after = trim (drop (length marker) lhs) + in after == "[]" + +listEmptyCtor :: ConstructorName +listEmptyCtor = "__list_empty__" + +singletonConstructors :: TypeName -> Map.Map TypeName [ConstructorName] -> [ConstructorName] +singletonConstructors ty ctorMap = + case Map.lookup ty ctorMap of + Just [ctor] -> [ctor] + _ -> [] + +parseTypeConstructors :: String -> Map.Map TypeName [ConstructorName] +parseTypeConstructors src = go (lines src) Map.empty + where + go [] acc = acc + go allLines@(l:ls) acc + | startsTypeDecl l = + let (declLines, rest) = spanTypeDecl allLines + acc' = case parseTypeDecl (unwords declLines) of + Just (ty, ctors) | not (null ctors) -> Map.insert ty ctors acc + _ -> acc + in go rest acc' + | otherwise = go ls acc + + startsTypeDecl line = + let t = trim line + in not (null line) + && not (startsIndented line) + && (("data " `isPrefixOf` t) || ("newtype " `isPrefixOf` t)) + + spanTypeDecl [] = ([], []) + spanTypeDecl (x:xs) = step [x] xs + where + step acc [] = (reverse acc, []) + step acc rest@(y:ys) + | any hasDeclBody acc && startsNextTopLevel y = (reverse acc, rest) + | otherwise = step (y:acc) ys + + hasDeclBody line = + "=" `isInfixOf` line || " where" `isInfixOf` line + + startsNextTopLevel line = + let t = trim line + in not (null line) + && not (startsIndented line) + && not ("--" `isPrefixOf` t) + + parseTypeDecl decl = do + let t = trim decl + keyword <- if ("data " :: String) `isPrefixOf` t + then Just ("data " :: String) + else if ("newtype " :: String) `isPrefixOf` t + then Just ("newtype " :: String) + else Nothing + let afterKeyword = trim (drop (length keyword) t) + tyName = takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') afterKeyword + guard (not (null tyName)) + (_, rhsText0) <- breakSub "=" afterKeyword + let rhsText = trim rhsText0 + let ctorSegments = splitTopLevelBars rhsText + ctors = mapMaybe firstCtorToken ctorSegments + guard (not (null ctors)) + pure (tyName, nubPreserve ctors) + +splitTopLevelBars :: String -> [String] +splitTopLevelBars = go (0 :: Int) (0 :: Int) (0 :: Int) "" [] + where + go :: Int -> Int -> Int -> String -> [String] -> String -> [String] + go _ _ _ cur acc [] = reverse (trim cur : acc) + go paren bracketDepth brace cur acc (c:cs) + | c == '(' = go (paren + 1) bracketDepth brace (cur ++ [c]) acc cs + | c == ')' = go (paren - 1) bracketDepth brace (cur ++ [c]) acc cs + | c == '[' = go paren (bracketDepth + 1) brace (cur ++ [c]) acc cs + | c == ']' = go paren (bracketDepth - 1) brace (cur ++ [c]) acc cs + | c == '{' = go paren bracketDepth (brace + 1) (cur ++ [c]) acc cs + | c == '}' = go paren bracketDepth (brace - 1) (cur ++ [c]) acc cs + | c == '|' && paren == 0 && bracketDepth == 0 && brace == 0 = + go paren bracketDepth brace "" (trim cur : acc) cs + | otherwise = go paren bracketDepth brace (cur ++ [c]) acc cs + +extractNamespaceParts :: String -> Maybe NamespaceParts +extractNamespaceParts clause = + case extractNsPrependInnerParts clause ++ extractNamespaceLiteralParts clause of + [] -> Nothing + parts -> Just parts + +extractNsPrependInnerParts :: String -> NamespaceParts +extractNsPrependInnerParts clause = + case breakOn "nsPrependInner" clause of + (_, "") -> [] + (_, rhs) -> take 1 (quotedStrings rhs) + +extractNamespaceLiteralParts :: String -> NamespaceParts +extractNamespaceLiteralParts clause = + case breakOn "Namespace" clause of + (_, "") -> [] + (_, rhs) -> quotedStrings rhs + +insertNamespaceClause :: Map.Map ConstructorName [NamespaceParts] + -> ([ConstructorName], NamespaceParts) + -> Map.Map ConstructorName [NamespaceParts] +insertNamespaceClause acc (ctors, parts) = + foldl' (\m ctor -> Map.insertWith (++) ctor [parts] m) acc ctors + +isLambdaCaseBody :: [String] -> Bool +isLambdaCaseBody (l:_) = "\\case" `isInfixOf` trim l +isLambdaCaseBody _ = False + +dropLeadingLambdaCase :: [String] -> [String] +dropLeadingLambdaCase (l:ls) + | "\\case" `isInfixOf` trim l = ls +dropLeadingLambdaCase ls = ls + +hasBranchArrows :: [String] -> Bool +hasBranchArrows = any ("->" `isInfixOf`) + +parseNamespaceLambdaClauses :: [String] -> [([ConstructorName], NamespaceParts)] +parseNamespaceLambdaClauses = mapMaybe parseBranch . go + where + go [] = [] + go (l:ls) + | "->" `isInfixOf` l = + let (pat0, rhs0) = case breakSub "->" l of + Just (a, b) -> (trim a, trim b) + Nothing -> ("", "") + (more, rest) = spanBranchLines ls + body = unwords ([rhs0 | not (null rhs0)] ++ more) + in (pat0, body) : go rest + | otherwise = go ls + + spanBranchLines = step [] + where + step acc [] = (reverse acc, []) + step acc allLines@(x:xs) + | isBranchStart x = (reverse acc, allLines) + | otherwise = step (x:acc) xs + + isBranchStart l = "->" `isInfixOf` l && startsIndented l + + parseBranch (pat, body) = do + let parts = quotedStrings body + let ctors = ctorTokens pat + if null parts || null ctors then Nothing else Just (ctors, parts) + +parseNamespaceCaseBranches :: [ConstructorName] -> [String] -> [([ConstructorName], NamespaceParts)] +parseNamespaceCaseBranches ctors = mapMaybe parseBranch . go + where + go [] = [] + go (l:ls) + | "->" `isInfixOf` l = + let (_pat0, rhs0) = case breakSub "->" l of + Just (a, b) -> (trim a, trim b) + Nothing -> ("", "") + (more, rest) = spanBranchLines ls + body = unwords ([rhs0 | not (null rhs0)] ++ more) + in body : go rest + | otherwise = go ls + + spanBranchLines = step [] + where + step acc [] = (reverse acc, []) + step acc allLines@(x:xs) + | isBranchStart x = (reverse acc, allLines) + | otherwise = step (x:acc) xs + + isBranchStart l = "->" `isInfixOf` l && startsIndented l + + parseBranch body = do + let parts = quotedStrings body + if null parts then Nothing else Just (ctors, parts) + + +ctorsAfter :: String -> String -> [String] +ctorsAfter marker line = + case T.splitOn (T.pack marker) (T.pack line) of + (_:rest:_) -> ctorTokens (T.unpack rest) + _ -> ctorTokens line + +firstCtorToken :: String -> Maybe String +firstCtorToken s = + case normalizedCtorTokens s of + [] -> Nothing + xs -> Just (selectCtorToken xs) + +ctorTokens :: String -> [String] +ctorTokens s = nubPreserve (normalizedCtorTokens s) + +quotedStrings :: String -> [String] +quotedStrings [] = [] +quotedStrings ('"':xs) = + let (a, b) = break (== '"') xs + in a : quotedStrings (drop 1 b) +quotedStrings (_:xs) = quotedStrings xs + +-- forMachine parsing + +data Clause = Clause + { clauseLevel :: String + , clauseCtor :: Maybe ConstructorName + , clausePattern :: String + , clauseBody :: [String] + } + +parseObjectHelperMap :: String -> HelperFieldMap +parseObjectHelperMap src = + Map.fromList + [ (name, fields) + | (name, body) <- helperBodies (lines src) + , let fields = parseHelperFields body + , not (Map.null fields) + ] + where + helperNames = + Set.fromList + [ trim (takeWhile (\c -> isAlphaNum c || c == '_') l) + | l <- lines src + , "::" `isInfixOf` l + , "Aeson.Object" `isInfixOf` l + ] + + helperBodies [] = [] + helperBodies (l:ls) + | Just name <- helperDefName l + , name `Set.member` helperNames + , "= \\case" `isInfixOf` l = + let (body, rest) = spanIndented ls + in (name, body) : helperBodies rest + | otherwise = helperBodies ls + + helperDefName l = + let t = trim l + nm = takeWhile (\c -> isAlphaNum c || c == '_') t + in if null nm then Nothing else Just nm + + spanIndented = go [] + where + go acc [] = (reverse acc, []) + go acc allLines@(x:xs) + | isTopLevelDecl x = (reverse acc, allLines) + | otherwise = go (x:acc) xs + + isTopLevelDecl l = + not (null l) + && not (startsIndented l) + && not ("--" `isPrefixOf` trim l) + + parseHelperFields body = + foldl' (Map.unionWith preferSpecific) Map.empty (mapMaybe parseBranch (helperBranches body)) + + helperBranches [] = [] + helperBranches (l:ls) + | "->" `isInfixOf` l = + let (pat0, rhs0) = case breakSub "->" l of + Just (a, b) -> (trim a, trim b) + Nothing -> ("", "") + (more, rest) = spanBranchLines ls + body = [rhs0 | not (null rhs0)] ++ more + in Clause "" Nothing pat0 body : helperBranches rest + | otherwise = helperBranches ls + + spanBranchLines = go [] + where + go acc [] = (reverse acc, []) + go acc allLines@(x:xs) + | isBranchStart x = (reverse acc, allLines) + | isTopLevelDecl x = (reverse acc, allLines) + | otherwise = go (x:acc) xs + + isBranchStart l = "->" `isInfixOf` l && startsIndented l + + parseBranch cl = + let vars = Set.fromList (extractVars (clausePattern cl)) + pairs = mapMaybe (parseFieldLine vars) (collectFieldEntries (clauseBody cl)) + in if null pairs then Nothing else Just (Map.fromListWith preferSpecific pairs) + + preferSpecific old new + | old == literalStringVar = new + | otherwise = old + +-- Extract forMachine function clauses with their patterns and bodies. +parseForMachineClauses :: String -> [Clause] +parseForMachineClauses src = go Nothing (lines src) + where + typeConstructors = parseTypeConstructors src + + startsHeader line = + let t = trim line + in "forMachine" `isPrefixOf` t || "forMachineGov" `isPrefixOf` t + hasEquals line = "=" `isInfixOf` line + go _ [] = [] + go currentType allLines@(l:ls) + | startsLogFormattingInstance l = + let (_hdr, rest, nextType) = spanInstanceHeader "LogFormatting" allLines + in go nextType rest + | startsTopLevelDeclForMachine l = + go Nothing ls + | startsHeader l = + let (headerLines, afterHeader) = spanUntilHeaderEnd [l] ls + header = unwords headerLines + (lvlTok, pat) = parseHeader header + (body, rest) = break startsHeader afterHeader + bodyAfterLambda = dropLeadingLambdaCase body + in if "\\case" `isInfixOf` header || isLambdaCaseBody body + then parseLambdaCaseClauses lvlTok currentType typeConstructors bodyAfterLambda ++ go currentType rest + else expandNestedCaseClauses lvlTok currentType typeConstructors pat body ++ go currentType rest + | otherwise = go currentType ls + + spanUntilHeaderEnd acc [] = (reverse acc, []) + spanUntilHeaderEnd acc (x:xs) + | any hasEquals acc = (reverse acc, x:xs) + | otherwise = spanUntilHeaderEnd (x:acc) xs + + startsLogFormattingInstance line = + let t = trim line + in "instance" `isPrefixOf` t && "LogFormatting" `isInfixOf` t + + startsTopLevelDeclForMachine line = + let t = trim line + in not (null line) + && not (startsIndented line) + && not ("--" `isPrefixOf` t) + && any (`isPrefixOf` t) + [ "instance" + , "data " + , "newtype " + , "type " + , "class " + ] + +parseLambdaCaseClauses :: String -> Maybe TypeName -> Map.Map TypeName [ConstructorName] -> [String] -> [Clause] +parseLambdaCaseClauses lvl currentType typeConstructors = go + where + go [] = [] + go (l:ls) + | "->" `isInfixOf` l = + let (pat0, rhs0) = case breakSub "->" l of + Just (a, b) -> (trim a, trim b) + Nothing -> ("", "") + (more, rest) = spanBranchLines ls + body = [rhs0 | not (null rhs0)] ++ more + in expandNestedCaseClauses lvl currentType typeConstructors pat0 body ++ go rest + | otherwise = go ls + + spanBranchLines = step [] + where + step acc [] = (reverse acc, []) + step acc allLines@(x:xs) + | isBranchStart x = (reverse acc, allLines) + | otherwise = step (x:acc) xs + + isBranchStart l = "->" `isInfixOf` l && startsIndented l + +expandNestedCaseClauses :: String -> Maybe TypeName -> Map.Map TypeName [ConstructorName] -> String -> [String] -> [Clause] +expandNestedCaseClauses lvl currentType typeConstructors pat body = + case splitCaseOnBoundVar (Set.fromList (extractVars pat)) body of + Just (prefix, branchLines) -> + Clause lvl (inferClauseCtor typeConstructors currentType pat) pat body + : concatMap descend (parseLambdaCaseClauses lvl currentType typeConstructors branchLines) + where + descend cl = expandNestedCaseClauses lvl currentType typeConstructors (clausePattern cl) (prefix ++ clauseBody cl) + Nothing -> + [Clause lvl (inferClauseCtor typeConstructors currentType pat) pat body] + +splitCaseOnBoundVar :: Set.Set String -> [String] -> Maybe ([String], [String]) +splitCaseOnBoundVar boundVars = go [] + where + go _ [] = Nothing + go acc (line:rest) = + case splitCaseLine boundVars line of + Just prefixLine -> + let prefix = reverse acc ++ [prefixLine | not (null (trim prefixLine))] + in Just (prefix, rest) + Nothing -> go (line:acc) rest + +splitCaseLine :: Set.Set String -> String -> Maybe String +splitCaseLine boundVars line = + listToMaybe + [ trim prefix + | var <- Set.toList boundVars + , let needle = "case " <> var <> " of" + , Just (prefix, _) <- [breakSub needle line] + ] + +parseHeader :: String -> (String, String) +parseHeader line = + let ws = words line + keyword = case () of + _ | "forMachineGov" `isInfixOf` line -> "forMachineGov" + | otherwise -> "forMachine" + lvl = case dropWhile (/= keyword) ws of + (_:l:_) -> l + _ -> "_" + pat = case breakSub keyword line of + Just (_, rest) -> + let rhs = dropWhile isSpace rest + afterLvl = dropWhile isSpace (drop (length lvl) rhs) + in stripOuterParens (trim (takeWhile (/= '=') afterLvl)) + Nothing -> "" + in (lvl, pat) + +spanInstanceHeader :: String -> [String] -> ([String], [String], Maybe TypeName) +spanInstanceHeader _className [] = ([], [], Nothing) +spanInstanceHeader className (x:xs) = finish [x] xs + where + finish acc [] = + let hdr = reverse acc + in (hdr, [], parseInstanceTypeForClass className (unwords hdr)) + finish acc rest@(y:ys) + | any ("where" `isInfixOf`) acc = + let hdr = reverse acc + in (hdr, rest, parseInstanceTypeForClass className (unwords hdr)) + | otherwise = finish (y:acc) ys + +parseInstanceTypeForClass :: String -> String -> Maybe TypeName +parseInstanceTypeForClass className hdr = do + (_, rest) <- breakSub className hdr + let tyExpr = trim . takeWhile (/= '=') . fst $ breakOn "where" (stripOuterParens (trim rest)) + guard (not (null tyExpr)) + guard (headMay tyExpr /= Just '[') + firstCtorToken tyExpr + +stripOuterParens :: String -> String +stripOuterParens s + | headMay s == Just '(' + , lastMay s == Just ')' + , parensWrapWhole s = trim (dropOuterDelims s) + | otherwise = s + +parensWrapWhole :: String -> Bool +parensWrapWhole = go (0 :: Int) + where + go :: Int -> String -> Bool + go _ [] = True + go depth (c:cs) + | c == '(' = go (depth + 1) cs + | c == ')' = + let depth' = depth - 1 + in depth' >= 0 + && (depth' /= 0 || null cs) + && go depth' cs + | otherwise = go depth cs + +-- Variables that appear in a forMachine pattern. +extractVars :: String -> [String] +extractVars s = filter (not . null) $ filter isVarToken (tokenize s) + where + isVarToken (c:_) = isLower c || c == '_' + isVarToken _ = False + +isRelevantVar :: String -> Bool +isRelevantVar [] = False +isRelevantVar ('_':_) = False +isRelevantVar _ = True + +tokenize :: String -> [String] +tokenize = filter (not . null) . splitTokens + where + splitTokens [] = [] + splitTokens xs = + let (tok, rest) = span isTokenChar xs + rest' = dropWhile (not . isTokenChar) rest + in tok : splitTokens rest' + isTokenChar c = isAlphaNum c || c == '_' || c == '\'' || c == '.' + +ctorFromPattern :: String -> Maybe String +ctorFromPattern pat = case normalizedCtorTokens pat of + [] -> Nothing + xs -> Just (selectCtorToken xs) + +normalizeCtorToken :: String -> String +normalizeCtorToken tok = + case reverse (splitOn "." tok) of + (x:_) -> x + [] -> tok + +normalizedCtorTokens :: String -> [String] +normalizedCtorTokens = + map normalizeCtorToken . filter isCtorToken . tokenize + where + isCtorToken (c:_) = isUpper c + isCtorToken _ = False + +nubPreserve :: Ord a => [a] -> [a] +nubPreserve = go Set.empty + where + go _ [] = [] + go seen (x:xs) + | Set.member x seen = go seen xs + | otherwise = x : go (Set.insert x seen) xs + +selectCtorToken :: [String] -> String +selectCtorToken [] = "" +selectCtorToken [x] = x +selectCtorToken xs@(x:_) + | x `elem` ["AnyMessageAndAgency", "AnyMessage"] = last xs + | otherwise = x + +inferClauseCtor :: Map.Map TypeName [ConstructorName] -> Maybe TypeName -> String -> Maybe ConstructorName +inferClauseCtor typeConstructors currentType pat = + case ctorFromPattern pat of + Just ctor -> Just ctor + Nothing + | trim pat == "[]" -> Just listEmptyCtor + Nothing + | isVariableOnlyPattern pat -> + currentType >>= \ty -> + case Map.lookup ty typeConstructors of + Just [ctor] -> Just ctor + _ -> Nothing + | otherwise -> Nothing + +isVariableOnlyPattern :: String -> Bool +isVariableOnlyPattern pat = + case filter isRelevantVar (extractVars pat) of + [_] -> null (normalizedCtorTokens pat) + _ -> False + +-- Map JSON field keys to the pattern variable they come from. +parseFieldVarMap :: HelperFieldMap -> [Clause] -> Map.Map ConstructorName (Map.Map DetailLevel (Map.Map String String)) +parseFieldVarMap helperMap = foldl' step Map.empty + where + step acc cl = + case clauseCtor cl of + Nothing -> acc + Just ctor -> + let vars = Set.fromList (filter isRelevantVar (extractVars (clausePattern cl))) + lvls = case clauseLevel cl of + "DMinimal" -> ["Minimal"] + "DNormal" -> ["Normal"] + "DDetailed" -> ["Detailed"] + "DMaximum" -> ["Maximum"] + _ -> detailLevels + sanitizedBody = stripCommentBlocks (clauseBody cl) + directPairs = mapMaybe (parseFieldLine vars) (collectFieldEntries sanitizedBody) + helperPairs = concatMap helperPairsForLine sanitizedBody + pairs = Map.toList (Map.fromListWith preferSpecific (directPairs ++ helperPairs)) + addOne m (k,v) = foldl' (\mm lvl -> Map.insertWith Map.union lvl (Map.singleton k v) mm) m lvls + in Map.insertWith (Map.unionWith Map.union) ctor (foldl' addOne Map.empty pairs) acc + + helperPairsForLine line = + concatMap helperPairsForName (tokenize line) + + helperPairsForName name = + maybe [] Map.toList (Map.lookup name helperMap) + + preferSpecific old new + | old == literalStringVar = new + | old == renderedStringVar && new /= renderedStringVar = new + | otherwise = old + +collectFieldEntries :: [String] -> [String] +collectFieldEntries = finalize . foldl' step [] + where + step :: [String] -> String -> [String] + step [] line + | ".=" `isInfixOf` line = [line] + | otherwise = [] + step acc@(cur:rest) line + | fieldEntryNeedsContinuation cur = (cur <> " " <> trim line) : rest + | ".=" `isInfixOf` line = line : acc + | otherwise = acc + + finalize = concatMap splitFieldFragments . reverse . filter (".=" `isInfixOf`) + + splitFieldFragments :: String -> [String] + splitFieldFragments = + filter (".=" `isInfixOf`) . map trim . splitTopLevelCommasGeneral . stripOuterList . trim + + stripOuterList s + | headMay s == Just '[' && lastMay s == Just ']' = dropOuterDelims s + | otherwise = + case outerBracketSpan s of + Just (i, j) + | trim (take i s) /= "" + , j == length s - 1 -> + trim (take (j - i - 1) (drop (i + 1) s)) + _ -> s + + outerBracketSpan :: String -> Maybe (Int, Int) + outerBracketSpan s = + case elemIndex '[' s of + Nothing -> Nothing + Just start -> matchBracket start (0 :: Int) start + where + matchBracket :: Int -> Int -> Int -> Maybe (Int, Int) + matchBracket _ _ i | i >= length s = Nothing + matchBracket start depth i = + case s !! i of + '[' -> + let depth' = depth + 1 + in matchBracket start depth' (i + 1) + ']' -> + let depth' = depth - 1 + in if depth' == 0 + then Just (start, i) + else matchBracket start depth' (i + 1) + _ -> matchBracket start depth (i + 1) + +fieldEntryNeedsContinuation :: String -> Bool +fieldEntryNeedsContinuation = hasOpenBalance . trim + where + hasOpenBalance s = + case go (0 :: Int) (0 :: Int) (0 :: Int) s of + (paren, bracketDepth, brace) -> paren > 0 || bracketDepth > 0 || brace > 0 + + go :: Int -> Int -> Int -> String -> (Int, Int, Int) + go paren bracketDepth brace [] = (paren, bracketDepth, brace) + go paren bracketDepth brace (c:cs) + | c == '(' = go (paren + 1) bracketDepth brace cs + | c == ')' = go (paren - 1) bracketDepth brace cs + | c == '[' = go paren (bracketDepth + 1) brace cs + | c == ']' = go paren (bracketDepth - 1) brace cs + | c == '{' = go paren bracketDepth (brace + 1) cs + | c == '}' = go paren bracketDepth (brace - 1) cs + | otherwise = go paren bracketDepth brace cs + +stripCommentBlocks :: [String] -> [String] +stripCommentBlocks = snd . foldl' step (0 :: Int, []) + where + step (depth, acc) line = + let (depth', cleaned) = stripLine depth line + in (depth', acc ++ [cleaned]) + + stripLine depth [] = (depth, []) + stripLine depth ('{':'-':cs) = stripLine (depth + 1) cs + stripLine depth ('-':'}':cs) + | depth > 0 = stripLine (depth - 1) cs + stripLine depth ('-':'-':_) + | depth == 0 = (depth, []) + stripLine depth (c:cs) + | depth > 0 = stripLine depth cs + | otherwise = + let (depth', rest) = stripLine depth cs + in (depth', c : rest) + +splitTopLevelCommasGeneral :: String -> [String] +splitTopLevelCommasGeneral = go (0 :: Int) (0 :: Int) (0 :: Int) "" [] + where + go :: Int -> Int -> Int -> String -> [String] -> String -> [String] + go _ _ _ cur acc [] = reverse (trim cur : acc) + go paren bracketDepth brace cur acc (c:cs) + | c == '(' = go (paren + 1) bracketDepth brace (cur ++ [c]) acc cs + | c == ')' = go (paren - 1) bracketDepth brace (cur ++ [c]) acc cs + | c == '[' = go paren (bracketDepth + 1) brace (cur ++ [c]) acc cs + | c == ']' = go paren (bracketDepth - 1) brace (cur ++ [c]) acc cs + | c == '{' = go paren bracketDepth (brace + 1) (cur ++ [c]) acc cs + | c == '}' = go paren bracketDepth (brace - 1) (cur ++ [c]) acc cs + | c == ',' && paren == 0 && bracketDepth == 0 && brace == 0 = + go paren bracketDepth brace "" (trim cur : acc) cs + | otherwise = go paren bracketDepth brace (cur ++ [c]) acc cs + +parseFieldLine :: Set.Set String -> String -> Maybe (String, String) +parseFieldLine vars line = do + key <- parseQuotedKey line + rhs <- parseDotEqRhs line + case extractForwardedVar vars rhs of + Just v -> Just (key, v) + Nothing -> + case inferRhsMarker rhs of + Just marker -> Just (key, marker) + Nothing -> do + let rhsTokens = Set.fromList (tokenize rhs) + let hits = filter (`Set.member` rhsTokens) (Set.toList vars) + case hits of + [v] -> Just (key, v) + _ -> + if isStringLiteral rhs + then Just (key, literalStringVar) + else Nothing + +extractForwardedVar :: Set.Set String -> String -> Maybe String +extractForwardedVar vars rhs = + listToMaybe + [ v + | v <- Set.toList vars + , isDirectForwardTo v (trim rhs) + ] + +isDirectForwardTo :: String -> String -> Bool +isDirectForwardTo var rhs = + any (`matchesCall` rhs) + [ "forMachine" + , "forMachineGov" + , "toObject" + , "toJSON" + ] + where + matchesCall fn s = + case words s of + [] -> False + (w:rest) + | w == fn -> + case reverse rest of + (lastArg:_) -> normalizeForwardedArg lastArg == var + _ -> False + | otherwise -> False + +normalizeForwardedArg :: String -> String +normalizeForwardedArg = + trim . dropTrailingPunctuation . takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'' || c == '.') + +dropTrailingPunctuation :: String -> String +dropTrailingPunctuation = reverse . dropWhile (`elem` (")],}" :: String)) . reverse + +-- Special marker for string literals (e.g. "kind" .= String "..."). +literalStringVar :: String +literalStringVar = "__literal_string__" + +renderedStringVar :: String +renderedStringVar = "__rendered_string__" + +integerExprVar :: String +integerExprVar = "__integer_expr__" + +numberExprVar :: String +numberExprVar = "__number_expr__" + +booleanExprVar :: String +booleanExprVar = "__boolean_expr__" + +objectExprVar :: String +objectExprVar = "__object_expr__" + +arrayExprVar :: String +arrayExprVar = "__array_expr__" + +stringArrayExprVar :: String +stringArrayExprVar = "__string_array_expr__" + +-- Heuristic detection for String-literal RHS. +isStringLiteral :: String -> Bool +isStringLiteral s = + "String \"" `isInfixOf` s || "String '" `isInfixOf` s + +inferRhsMarker :: String -> Maybe String +inferRhsMarker rhs + | isStringLiteral rhs = Just literalStringVar + | "Number (fromIntegral" `isInfixOf` rhs = Just integerExprVar + | "Number (fromRational" `isInfixOf` rhs = Just numberExprVar + | "Number " `isPrefixOf` trim rhs = Just numberExprVar + | "String " `isPrefixOf` trim rhs = Just renderedStringVar + | "forMachine " `isInfixOf` rhs = Just objectExprVar + | "toObject " `isInfixOf` rhs = Just objectExprVar + | "Aeson.object" `isInfixOf` rhs = Just objectExprVar + | "object [" `isInfixOf` rhs = Just objectExprVar + | "mconcat [" `isInfixOf` rhs = Just objectExprVar + | "toJSON [" `isInfixOf` rhs = Just arrayExprVar + | "toJSONList (map show" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSONList (map showT" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSONList (map textShow" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSONList (map (show" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSONList " `isInfixOf` rhs = Just arrayExprVar + | "toJSON (map show" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSON (map showT" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSON (map textShow" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSON (map (show" `isInfixOf` rhs = Just stringArrayExprVar + | "toJSON (map (" `isInfixOf` rhs = Just arrayExprVar + | "toJSON (Set.toList" `isInfixOf` rhs = Just arrayExprVar + | "toJSON (Map.keys" `isInfixOf` rhs = Just arrayExprVar + | "toJSON (Map.elems" `isInfixOf` rhs = Just arrayExprVar + | "toJSON True" `isInfixOf` rhs = Just booleanExprVar + | "toJSON False" `isInfixOf` rhs = Just booleanExprVar + | "toJSON (" `isInfixOf` rhs && any (`isInfixOf` rhs) [" is", "==", "/=", "&&", "||", " not "] = Just booleanExprVar + | "String (" `isInfixOf` rhs = Just renderedStringVar + | "textShow" `isInfixOf` rhs = Just renderedStringVar + | "showT" `isInfixOf` rhs = Just renderedStringVar + | "renderHeaderHash" `isInfixOf` rhs = Just renderedStringVar + | "renderChainHash" `isInfixOf` rhs = Just renderedStringVar + | "renderPoint" `isInfixOf` rhs = Just renderedStringVar + | "toJSON (unBlockNo" `isInfixOf` rhs = Just integerExprVar + | "toJSON (unSlotNo" `isInfixOf` rhs = Just integerExprVar + | "toJSON (fromIntegral" `isInfixOf` rhs = Just integerExprVar + | "toJSON (" `isInfixOf` rhs && any (`isInfixOf` rhs) ["Word", "Int", "SlotNo", "BlockNo", "EpochNo", "length ", "length(", "fragmentLength"] = Just integerExprVar + | "toJSON (" `isInfixOf` rhs && any (`isInfixOf` rhs) ["Double", "Float", "NominalDiffTime", "DiffTime"] = Just numberExprVar + | otherwise = Nothing + +parseQuotedKey :: String -> Maybe String +parseQuotedKey s = case dropWhile (/= '"') s of + [] -> Nothing + (_:rest) -> Just (takeWhile (/= '"') rest) + +parseDotEqRhs :: String -> Maybe String +parseDotEqRhs s = + case breakSub ".=" s of + Nothing -> Nothing + Just (_, rhs) -> Just (dropWhile (== ' ') rhs) + +breakSub :: String -> String -> Maybe (String, String) +breakSub needle hay = + let (a, b) = breakOn needle hay + in if null b then Nothing else Just (a, drop (length needle) b) + +breakOn :: String -> String -> (String, String) +breakOn needle hay = + case T.breakOn (T.pack needle) (T.pack hay) of + (a, b) -> (T.unpack a, T.unpack b) + +-- GHCI type extraction + +type VarTypes = Map.Map ConstructorName (Map.Map String String) + +-- For each file, ask GHCi for the types of variables extracted from forMachine clauses. +ghciTypesForFile :: FilePath -> [Clause] -> IO VarTypes +ghciTypesForFile fp clauses = do + src <- readFileSafe fp + let + moduleName = extractModuleName src + imports = extractImports src + queries = mapMaybe buildQuery clauses + if null queries then pure Map.empty else do + out <- runGhci moduleName imports (map (fst . snd) queries) + let outputs = splitOutputs out (length queries) + let pairs = zip queries outputs + pure $ foldl' mergeVarTypes Map.empty (map parseQueryResult pairs) + where + mergeVarTypes = Map.unionWith Map.union + +extractImports :: String -> [String] +extractImports src = + [ stripComment l + | l <- lines src + , let l' = dropWhile (== ' ') l + , "import " `isPrefixOf` l' + ] + where + stripComment = takeWhile (/= '-') + +extractModuleName :: String -> Maybe String +extractModuleName src = + listToMaybe + [ takeWhile (\c -> isAlphaNum c || c == '_' || c == '.') rest + | l <- lines src + , let t = trim l + , "module " `isPrefixOf` t + , let rest = drop (length ("module " :: String)) t + ] + +buildQuery :: Clause -> Maybe (ConstructorName, (String, [String])) +buildQuery cl = do + ctor <- clauseCtor cl + let vars = filter isRelevantVar (extractVars (clausePattern cl)) + if null vars then Nothing else do + let body = singletonOrTuple vars + let expr = "(\\(" ++ clausePattern cl ++ ") -> " ++ body ++ ")" + let cmd = ":t " ++ expr + Just (ctor, (cmd, vars)) + +commaSep :: [String] -> String +commaSep = foldr1 (\a b -> a ++ ", " ++ b) + +runGhci :: Maybe String -> [String] -> [String] -> IO String +runGhci moduleName imports cmds = + withFilteredGhciProjectFile $ \projectFile -> do + let ghciCmd = + [ "cabal" + , "--project-file=" ++ projectFile + , "repl" + , "cardano-node" + , "--repl-options=-ignore-dot-ghci" + , "--repl-options=-v0" + ] + let marker i = "__CMD_" ++ show i ++ "__" + let cmdLines = + [":set -XGADTs -XTypeFamilies -XDataKinds -XTypeOperators -XRankNTypes -XScopedTypeVariables"] + ++ maybe [] (\m -> [":module + *" ++ m]) moduleName + ++ imports + ++ concat [ [cmd, ":! echo " ++ marker i] | (i, cmd) <- zip [(0 :: Int)..] cmds ] + ++ [":quit"] + let (ghciProg, ghciArgs) = + case ghciCmd of + prog:args -> (prog, args) + [] -> ("cabal", []) + (code, out, err) <- readCreateProcessWithExitCode (proc ghciProg ghciArgs) (unlines cmdLines) + let combined = out ++ err + case code of + ExitSuccess -> pure combined + _ -> pure combined + +withFilteredGhciProjectFile :: (FilePath -> IO a) -> IO a +withFilteredGhciProjectFile = + bracket create remove + where + create = do + let fp = ".ghci-schema.cabal.project.tmp" + src <- readFile "cabal.project" + writeFile fp (filterGhciProject src) + pure fp + remove fp = removeFile fp `catch` (\(_ :: IOException) -> pure ()) + +filterGhciProject :: String -> String +filterGhciProject src = unlines (go False (lines src)) + where + go _ [] = [] + go True (l:ls) + | startsTopLevel l = go False (l:ls) + | otherwise = go True ls + go False (l:ls) + | trim l == "source-repository-package" = go True ls + | "extra-packages:" `isPrefixOf` trim l = go False ls + | otherwise = l : go False ls + + startsTopLevel line = + case line of + [] -> False + (c:_) -> not (isSpace c) + +splitOutputs :: String -> Int -> [String] +splitOutputs out n = map snd (take n (splitMarkers out)) + where + splitMarkers s = + let ls = lines s + go _ [] acc = reverse acc + go cur (l:rest) acc + | "__CMD_" `isPrefixOf` l = + go "" rest ((l, cur) : acc) + | otherwise = go (cur ++ l ++ "\n") rest acc + in go "" ls [] + +parseQueryResult :: ((ConstructorName, (String, [String])), String) -> VarTypes +parseQueryResult ((ctor, (_cmd, vars)), out) = + let isErr = "error:" `isInfixOf` out + varTypes = if isErr + then parseBindings out + else parseSignature out vars + in case varTypes of + Nothing -> Map.empty + Just vt -> Map.singleton ctor vt + +parseSignature :: String -> [String] -> Maybe (Map.Map String String) +parseSignature out vars = do + sig <- findSigBlock out + let parts = parseSigTypes sig + let pairs = zip vars parts + pure $ Map.fromList pairs + +findSigBlock :: String -> Maybe String +findSigBlock out = + case break (isInfixOf "::") (lines out) of + (_, []) -> Nothing + (_, sigStart:rest) -> + let sigLines = sigStart : takeWhile isSigContinuation rest + in Just (unwords (map trim sigLines)) + +isSigContinuation :: String -> Bool +isSigContinuation l = + case l of + [] -> False + (c:_) -> + isSpace c + && let t = trim l + in not (null t) + && not ("ghci>" `isPrefixOf` t) + && not ("__CMD_" `isPrefixOf` t) + +parseSigTypes :: String -> [String] +parseSigTypes line = + case breakSub "::" line of + Nothing -> [] + Just (_, rhs0) -> + let rhs = dropWhile (== ' ') rhs0 + tailTy = last (splitOn "->" rhs) + in parseTupleTypes (trim tailTy) + +parseTupleTypes :: String -> [String] +parseTupleTypes s + | headMay s == Just '(' && lastMay s == Just ')' && ',' `elem` s = + splitTopLevelCommas (dropOuterDelims s) + | otherwise = [s] + +splitTopLevelCommas :: String -> [String] +splitTopLevelCommas = go (0 :: Int) "" [] + where + go :: Int -> String -> [String] -> String -> [String] + go _ cur acc [] = reverse (trim cur : acc) + go depth cur acc (c:cs) + | c == '(' = go (depth + 1) (cur ++ [c]) acc cs + | c == ')' = go (depth - 1) (cur ++ [c]) acc cs + | c == ',' && depth == 0 = go depth "" (trim cur : acc) cs + | otherwise = go depth (cur ++ [c]) acc cs + +-- Parse "x :: T" bindings (and constraints) emitted by GHCi on errors. +parseBindings :: String -> Maybe (Map.Map String String) +parseBindings out = + let constraints = parseConstraints out + bindings = mapMaybe parseBindingLine (lines out) + applyConstraints ty = foldl' (\t (v, rep) -> replaceToken v rep t) ty constraints + fixed = [ (name, applyConstraints ty) | (name, ty) <- bindings ] + in if null fixed then Nothing else Just (Map.fromList fixed) + +parseConstraints :: String -> [(String, String)] +parseConstraints out = mapMaybe parseConstraintLine (lines out) + where + parseConstraintLine l = + case breakSub "~" l of + Nothing -> Nothing + Just (lhs, rhs) -> + let v = lastWord lhs + r = headWord rhs + in if null v || null r then Nothing else Just (v, r) + +-- Parse a single binding line "x :: T". +parseBindingLine :: String -> Maybe (String, String) +parseBindingLine l = + case breakSub "::" l of + Nothing -> Nothing + Just (lhs, rhs) -> + let name = trim (lastWord lhs) + ty = trim (takeWhile (/= '(') rhs) + in if null name || null ty then Nothing else Just (name, ty) + +replaceToken :: String -> String -> String -> String +replaceToken tok rep s = unwords (map (\w -> if w == tok then rep else w) (words s)) + +headMay :: [a] -> Maybe a +headMay [] = Nothing +headMay (x:_) = Just x + +singleElement :: [a] -> Maybe a +singleElement [x] = Just x +singleElement _ = Nothing + +startsIndented :: String -> Bool +startsIndented = maybe False isSpace . headMay + +dropOuterDelims :: String -> String +dropOuterDelims [] = [] +dropOuterDelims [_] = [] +dropOuterDelims (_:xs) = + case reverse xs of + [] -> [] + (_:restRev) -> reverse restRev + +singletonOrTuple :: [String] -> String +singletonOrTuple [v] = v +singletonOrTuple vars = "(" ++ commaSep vars ++ ")" + +lastMay :: [a] -> Maybe a +lastMay [] = Nothing +lastMay xs = headMay (reverse xs) + +splitOn :: String -> String -> [String] +splitOn needle hay = map T.unpack (T.splitOn (T.pack needle) (T.pack hay)) + +trim :: String -> String +trim = T.unpack . T.strip . T.pack + +lastWord :: String -> String +lastWord s = case words s of + [] -> "" + xs -> last xs + +headWord :: String -> String +headWord s = case words s of + [] -> "" + (x:_) -> x + +-- Schema update + +type FieldVarMap = Map.Map ConstructorName (Map.Map DetailLevel (Map.Map String String)) + +updateSchemaForNamespaceWithWarning :: (String -> IO ()) + -> Config + -> FilePath + -> FilePath + -> Map.Map ConstructorName [NamespaceParts] + -> FieldVarMap + -> VarTypes + -> String + -> IO () +updateSchemaForNamespaceWithWarning emitWarning config msgOutDir typeOutDir nsMap fieldVarMap varTypes ns = do + let parts = splitDot ns + let ctor = + case fallbackCtorForNamespace parts of + Just c -> Just c + Nothing -> findCtor nsMap parts + let out = msgOutDir foldr () (last parts ++ ".schema.json") (init parts) + let histOutDir = "bench/trace-schemas/messages-hist" + let histOut = histOutDir foldr () (last parts ++ ".schema.json") (init parts) + exists <- doesFileExist out + schema <- if exists + then do + bs <- BL.readFile out + case A.decode bs of + Just v -> pure v + Nothing -> pure (baseSchema ns) + else pure (baseSchema ns) + schema' <- updateSchema config typeOutDir ctor fieldVarMap varTypes schema + -- If we couldn't infer any data properties, fall back to messages-hist. + schema'' <- mergeHistDataIfEmpty histOut schema' + unless (schemaHasMeaningfulContent schema'') $ + case ctor of + Nothing -> + emitWarning $ + "Warning: no source found for namespace: " <> ns + Just c + | Map.notMember c fieldVarMap && Map.notMember c varTypes -> + emitWarning $ + "Warning: namespace resolved to constructor without parsed source/GHCi data: " + <> ns <> " -> " <> c + _ -> pure () + createDirectoryIfMissing True (takeDirectory out) + BL.writeFile out (AP.encodePretty schema'') + +fallbackCtorForNamespace :: [String] -> Maybe ConstructorName +fallbackCtorForNamespace parts + | ["Net", "Handshake"] `isListPrefixOf` parts = Just diffusionHandshakeCtor + | ["BlockFetch", "Decision"] `isListPrefixOf` parts + , lastMay parts == Just "EmptyPeersFetch" = + Just listEmptyCtor + | ["Net", "ConnectionManager"] `isListPrefixOf` parts + , lastMay parts == Just "UnexpectedlyFalseAssertion" = + Just connectionManagerUnexpectedlyFalseAssertionCtor + | ["Net", "InboundGovernor"] `isListPrefixOf` parts + , lastMay parts == Just "UnexpectedlyFalseAssertion" = + Just inboundGovernorUnexpectedlyFalseAssertionCtor + | ["Net", "ConnectionManager"] `isListPrefixOf` parts + , lastMay parts == Just "State" = Just connectionManagerStateCtor + | ["Net", "Mux"] `isListPrefixOf` parts + , lastMay parts == Just "State" = Just muxStateCtor + | ["BlockFetch"] `isListPrefixOf` parts + , "Serialised" `elem` parts + , lastMay parts == Just "Block" = Just serialisedBlockFetchMsgBlockCtor + | otherwise = Nothing + +isListPrefixOf :: Eq a => [a] -> [a] -> Bool +isListPrefixOf xs ys = xs == take (length xs) ys + +normalizeNamespaceMap :: FilePath -> Map.Map ConstructorName [NamespaceParts] -> Map.Map ConstructorName [NamespaceParts] +normalizeNamespaceMap fp + | takeFileName fp == "Diffusion.hs" = + renameCtor "AnyMessageAndAgency" diffusionHandshakeCtor + | takeFileName fp == "P2P.hs" = + insertAliasFrom "TrUnexpectedlyFalseAssertion" connectionManagerUnexpectedlyFalseAssertionCtor + . insertAliasFrom "TrUnexpectedlyFalseAssertion" inboundGovernorUnexpectedlyFalseAssertionCtor + | otherwise = id + +normalizeFieldVarMap :: FilePath -> FieldVarMap -> FieldVarMap +normalizeFieldVarMap fp + | takeFileName fp == "Diffusion.hs" = + renameCtor "AnyMessageAndAgency" diffusionHandshakeCtor + | takeFileName fp == "P2P.hs" = + splitUnexpectedlyFalseAssertion + | takeFileName fp == "NodeToNode.hs" = + splitSerialisedBlockFetchMsgBlock + | otherwise = id + +normalizeVarTypesMap :: FilePath -> VarTypes -> VarTypes +normalizeVarTypesMap fp + | takeFileName fp == "Diffusion.hs" = + renameCtor "AnyMessageAndAgency" diffusionHandshakeCtor + | takeFileName fp == "P2P.hs" = + insertAliasFrom "TrUnexpectedlyFalseAssertion" connectionManagerUnexpectedlyFalseAssertionCtor + . insertAliasFrom "TrUnexpectedlyFalseAssertion" inboundGovernorUnexpectedlyFalseAssertionCtor + | takeFileName fp == "NodeToNode.hs" = + insertAliasFrom "MsgBlock" serialisedBlockFetchMsgBlockCtor + | otherwise = id + +renameCtor :: ConstructorName -> ConstructorName -> Map.Map ConstructorName a -> Map.Map ConstructorName a +renameCtor from to m = + case Map.lookup from m of + Just v -> Map.insert to v (Map.delete from m) + Nothing -> m + +insertAliasFrom :: ConstructorName -> ConstructorName -> Map.Map ConstructorName a -> Map.Map ConstructorName a +insertAliasFrom from to m = + case Map.lookup from m of + Just v -> Map.insert to v m + Nothing -> m + +splitSerialisedBlockFetchMsgBlock :: FieldVarMap -> FieldVarMap +splitSerialisedBlockFetchMsgBlock m = + case Map.lookup "MsgBlock" m of + Nothing -> m + Just byLevel -> + let serialisedKeys = Set.fromList ["agency", "bytes", "kind"] + regular = Map.map (Map.filterWithKey (\k _ -> k /= "bytes")) byLevel + serialised = Map.map (Map.filterWithKey (\k _ -> Set.member k serialisedKeys)) byLevel + in Map.insert serialisedBlockFetchMsgBlockCtor serialised (Map.insert "MsgBlock" regular m) + +splitUnexpectedlyFalseAssertion :: FieldVarMap -> FieldVarMap +splitUnexpectedlyFalseAssertion m = + case Map.lookup "TrUnexpectedlyFalseAssertion" m of + Nothing -> m + Just byLevel -> + let connectionManagerKeys = Set.fromList ["kind", "info"] + inboundGovernorKeys = Set.fromList ["kind", "remoteSt"] + connectionManager = + Map.map (Map.filterWithKey (\k _ -> Set.member k connectionManagerKeys)) byLevel + inboundGovernor = + Map.map (Map.filterWithKey (\k _ -> Set.member k inboundGovernorKeys)) byLevel + in Map.insert connectionManagerUnexpectedlyFalseAssertionCtor connectionManager + (Map.insert inboundGovernorUnexpectedlyFalseAssertionCtor inboundGovernor m) + +-- Merge "data" from messages-hist when we couldn't infer any properties. +mergeHistDataIfEmpty :: FilePath -> A.Value -> IO A.Value +mergeHistDataIfEmpty histOut v@(A.Object o) = do + let hasProps = hasDataProps o + if hasProps + then pure v + else do + histExists <- doesFileExist histOut + if not histExists + then pure v + else do + histValue <- A.decodeFileStrict' histOut + case histValue of + Just (A.Object ho) -> + case KM.lookup (K.fromString "data") ho of + Just d -> pure (A.Object (KM.insert (K.fromString "data") d o)) + Nothing -> pure v + _ -> pure v +mergeHistDataIfEmpty _ v = pure v + +schemaHasMeaningfulContent :: A.Value -> Bool +schemaHasMeaningfulContent (A.Object o) = + hasNonEmptyData o || hasNonEmptyVariants o + where + hasNonEmptyData obj = + case KM.lookup (K.fromString "data") obj of + Just (A.Object d) -> not (KM.null d) + _ -> False + + hasNonEmptyVariants obj = + case KM.lookup (K.fromString "variants") obj of + Just (A.Array arr) -> not (V.null arr) + _ -> False +schemaHasMeaningfulContent _ = False + +-- True if data.properties exists and is non-empty. +hasDataProps :: A.Object -> Bool +hasDataProps o = + case KM.lookup (K.fromString "data") o of + Just (A.Object d) -> + case KM.lookup (K.fromString "properties") d of + Just (A.Object props) -> not (null (KM.toList props)) + _ -> False + _ -> False + +baseSchema :: String -> A.Value +baseSchema ns = A.object ["ns" A..= ns, "data" A..= A.object []] + +updateSchema :: Config + -> FilePath + -> Maybe ConstructorName + -> FieldVarMap + -> VarTypes + -> A.Value + -> IO A.Value +updateSchema _ _ Nothing _ _ v = pure v +updateSchema config typeOutDir (Just ctor) fieldVarMap varTypes (A.Object o) = do + case KM.lookup (K.fromString "variants") o of + Just (A.Array arr) -> do + updated <- V.mapM (updateVariant config typeOutDir ctor fieldVarMap varTypes) arr + pure (A.Object (KM.insert (K.fromString "variants") (A.Array updated) o)) + _ -> do + updated <- updateData config typeOutDir ctor fieldVarMap varTypes "Minimal" o + pure (A.Object updated) +updateSchema _ _ _ _ _ v = pure v + +updateVariant :: Config + -> FilePath + -> ConstructorName + -> FieldVarMap + -> VarTypes + -> A.Value + -> IO A.Value +updateVariant config typeOutDir ctor fieldVarMap varTypes (A.Object o) = + case KM.lookup (K.fromString "detailLevel") o of + Just (A.String lvl) -> do + updated <- updateData config typeOutDir ctor fieldVarMap varTypes (T.unpack lvl) o + pure (A.Object updated) + _ -> pure (A.Object o) +updateVariant _ _ _ _ _ v = pure v + +-- Update or synthesize the "data" schema from forMachine mapping + type info. +updateData :: Config + -> FilePath + -> ConstructorName + -> FieldVarMap + -> VarTypes + -> DetailLevel + -> A.Object + -> IO A.Object +updateData config typeOutDir ctor fieldVarMap varTypes lvl o = + case KM.lookup (K.fromString "data") o of + Just (A.Object d) -> + case KM.lookup (K.fromString "properties") d of + Just (A.Object props) -> do + inferredProps <- inferredProperties typeOutDir ctor fieldVarMap varTypes lvl + let propsToUpdate = + if cfgPruneStaleProperties config + then KM.filterWithKey (\k _ -> KM.member k inferredProps) props + else props + updatedProps <- KM.traverseWithKey (updateProp typeOutDir ctor fieldVarMap varTypes lvl) propsToUpdate + let mergedProps = KM.union updatedProps inferredProps + let d' = KM.insert (K.fromString "properties") (A.Object mergedProps) d + let d'' = setRequiredFields ctor fieldVarMap varTypes lvl d' + pure (KM.insert (K.fromString "data") (A.Object d'') o) + _ -> do + d' <- buildDataFromFieldMap typeOutDir ctor fieldVarMap varTypes lvl d + let d'' = setRequiredFields ctor fieldVarMap varTypes lvl d' + pure (KM.insert (K.fromString "data") (A.Object d'') o) + _ -> do + d <- buildDataFromFieldMap typeOutDir ctor fieldVarMap varTypes lvl KM.empty + let d' = setRequiredFields ctor fieldVarMap varTypes lvl d + pure (KM.insert (K.fromString "data") (A.Object d') o) + +-- Build a data.schema from the key->var mapping (if available). +buildDataFromFieldMap :: FilePath + -> ConstructorName + -> FieldVarMap + -> VarTypes + -> DetailLevel + -> A.Object + -> IO A.Object +buildDataFromFieldMap typeOutDir ctor fieldVarMap varTypes lvl base = do + props <- inferredProperties typeOutDir ctor fieldVarMap varTypes lvl + if KM.null props + then pure base + else do + let base' = + KM.insert (K.fromString "type") (A.String "object") $ + KM.insert (K.fromString "additionalProperties") (A.Bool True) base + pure (KM.insert (K.fromString "properties") (A.Object props) base') + +inferredProperties :: FilePath + -> ConstructorName + -> FieldVarMap + -> VarTypes + -> DetailLevel + -> IO A.Object +inferredProperties typeOutDir ctor fieldVarMap varTypes lvl = + case Map.lookup ctor fieldVarMap >>= Map.lookup lvl of + Nothing -> pure KM.empty + Just m -> KM.fromList <$> mapM (buildProp typeOutDir ctor fieldVarMap varTypes) (Map.toList m) + +setRequiredFields :: ConstructorName + -> FieldVarMap + -> VarTypes + -> DetailLevel + -> A.Object + -> A.Object +setRequiredFields ctor fieldVarMap varTypes lvl o = + case requiredFieldNames ctor fieldVarMap varTypes lvl of + [] -> o + reqs -> KM.insert (K.fromString "required") (A.toJSON reqs) o + +requiredFieldNames :: ConstructorName + -> FieldVarMap + -> VarTypes + -> DetailLevel + -> [String] +requiredFieldNames ctor fieldVarMap varTypes lvl = + case Map.lookup ctor fieldVarMap >>= Map.lookup lvl of + Nothing -> [] + Just m -> + [ key + | (key, varName) <- Map.toList m + , isRequiredField varName + ] + where + isRequiredField v + | v `elem` [ literalStringVar, renderedStringVar, integerExprVar, numberExprVar + , booleanExprVar, objectExprVar, arrayExprVar, stringArrayExprVar ] = True + | otherwise = + case Map.lookup ctor varTypes >>= Map.lookup v of + Just ty -> not (isMaybe ty) + Nothing -> True + +buildProp :: FilePath + -> ConstructorName + -> FieldVarMap + -> VarTypes + -> (String, String) + -> IO (A.Key, A.Value) +buildProp typeOutDir ctor fieldVarMap varTypes (k, v) + | v `elem` [literalStringVar, renderedStringVar] = + pure (K.fromString k, A.object ["type" A..= ("string" :: String)]) + | v == integerExprVar = + pure (K.fromString k, A.object ["type" A..= ("integer" :: String)]) + | v == numberExprVar = + pure (K.fromString k, A.object ["type" A..= ("number" :: String)]) + | v == booleanExprVar = + pure (K.fromString k, A.object ["type" A..= ("boolean" :: String)]) + | v == objectExprVar = + pure (K.fromString k, A.object ["type" A..= ("object" :: String), "additionalProperties" A..= True]) + | v == arrayExprVar = + pure (K.fromString k, A.object ["type" A..= ("array" :: String)]) + | v == stringArrayExprVar = + pure (K.fromString k, A.object ["type" A..= ("array" :: String), "items" A..= A.object ["type" A..= ("string" :: String)]]) + | otherwise = + case Map.lookup ctor varTypes >>= Map.lookup v of + Nothing -> pure (K.fromString k, fallbackSchemaForUnknownBindingForCtor ctor k v) + Just ty -> do + schema <- typeToSchema typeOutDir fieldVarMap varTypes Set.empty ty + pure (K.fromString k, schema) + +updateProp :: FilePath + -> ConstructorName + -> FieldVarMap + -> VarTypes + -> DetailLevel + -> A.Key + -> A.Value + -> IO A.Value +updateProp typeOutDir ctor fieldVarMap varTypes lvl key old = + case Map.lookup ctor fieldVarMap >>= Map.lookup lvl >>= Map.lookup (T.unpack (K.toText key)) of + Nothing -> pure old + Just v -> snd <$> buildProp typeOutDir ctor fieldVarMap varTypes (T.unpack (K.toText key), v) + +-- Namespace matching uses suffix match, so full path or tail matches work. +splitDot :: String -> [String] +splitDot s = case break (== '.') s of + (a, []) -> [a] + (a, _:b) -> a : splitDot b + +findCtor :: Map.Map ConstructorName [NamespaceParts] -> [String] -> Maybe ConstructorName +findCtor nsMap parts = + case rankedMatches of + ((_, ctor):_) -> Just ctor + [] -> Nothing + where + rankedMatches = + sortOn (Down . fst) $ + [ (scoreMatch ctor nsParts, ctor) + | (ctor, nss) <- Map.toList nsMap + , nsParts <- nss + , nsParts `isListSuffixOf` parts + ] + + scoreMatch :: ConstructorName -> NamespaceParts -> (Int, Int, Int) + scoreMatch ctor nsParts = + ( length nsParts + , overlapScore ctor parts + , overlapScore ctor nsParts + ) + +isListSuffixOf :: Eq a => [a] -> [a] -> Bool +isListSuffixOf xs ys = xs == drop (length ys - length xs) ys + +overlapScore :: ConstructorName -> NamespaceParts -> Int +overlapScore ctor nsParts = + length $ + filter (`Set.member` ctorWords) nsWords + where + ctorWords = Set.fromList (splitCamelWords ctor) + nsWords = concatMap splitCamelWords nsParts + +splitCamelWords :: String -> [String] +splitCamelWords = + filter (not . null) + . map (map toLower) + . concatMap splitWord + . splitOnNonAlphaNum + where + splitOnNonAlphaNum [] = [] + splitOnNonAlphaNum xs = + let xs' = dropWhile (not . isAlphaNum) xs + in case span isAlphaNum xs' of + ("", []) -> [] + ("", rest) -> splitOnNonAlphaNum rest + (tok, rest) -> tok : splitOnNonAlphaNum rest + + splitWord [] = [] + splitWord (c:cs) = go [c] cs + + go cur [] = [reverse cur] + go cur (x:xs) + | isUpper x && any isLower cur = reverse cur : go [x] xs + | otherwise = go (x:cur) xs + +-- Type mapping + +typeToSchema :: FilePath -> FieldVarMap -> VarTypes -> Set.Set String -> String -> IO A.Value +typeToSchema typeOutDir fieldVarMap varTypes seen ty + | isList ty = do + item <- typeToSchema typeOutDir fieldVarMap varTypes seen (listElem ty) + pure (A.object ["type" A..= ("array" :: String), "items" A..= item]) + | isMaybe ty = do + item <- typeToSchema typeOutDir fieldVarMap varTypes seen (maybeElem ty) + pure (A.object ["anyOf" A..= [A.object ["type" A..= ("null" :: String)], item]]) + | baseTypeName ty `elem` ["Text","String","ByteString","ShortByteString","ShortText"] = pure (A.object ["type" A..= ("string" :: String)]) + | baseTypeName ty == "Bool" = pure (A.object ["type" A..= ("boolean" :: String)]) + | baseTypeName ty `elem` ["Int","Integer","Word","Word8","Word16","Word32","Word64","Natural","SlotNo","EpochNo","BlockNo"] = pure (A.object ["type" A..= ("integer" :: String)]) + | baseTypeName ty `elem` ["Double","Float","NominalDiffTime","DiffTime"] = pure (A.object ["type" A..= ("number" :: String)]) + | otherwise = do + let name = baseTypeName ty + case name of + (c:_) | isLower c -> pure (A.object []) + _ -> do + let ref = "types/" ++ name ++ ".schema.json" + let out = typeOutDir name ++ ".schema.json" + if Set.member name seen + then pure () + else ensureTypeSchema out name fieldVarMap varTypes (Set.insert name seen) + pure (A.object ["$ref" A..= ref]) + +isList :: String -> Bool +isList s = headMay s == Just '[' && lastMay s == Just ']' + +listElem :: String -> String +listElem s = trim (dropOuterDelims s) + +isMaybe :: String -> Bool +isMaybe s = "Maybe " `isPrefixOf` trim s + +maybeElem :: String -> String +maybeElem s = trim (drop (length ("Maybe " :: String)) (trim s)) + +baseTypeName :: String -> String +baseTypeName s = + let s' = trim s + s'' = case stripPrefix "forall " s' of + Just rest -> case break (== '.') rest of + (_vars, '.':r) -> trim r + _ -> s' + _ -> s' + tokens = filter (not . null) (tokenize s'') + in case filter (\case (c:_) -> isUpper c; _ -> False) tokens of + (x:_) -> x + [] -> s'' + +ensureTypeSchema :: FilePath -> String -> FieldVarMap -> VarTypes -> Set.Set String -> IO () +ensureTypeSchema out name fieldVarMap varTypes seen = do + createDirectoryIfMissing True (takeDirectory out) + schema <- namedTypeSchema fieldVarMap varTypes seen name + BL.writeFile out (AP.encodePretty schema) + +namedTypeSchema :: FieldVarMap -> VarTypes -> Set.Set String -> String -> IO A.Value +namedTypeSchema fieldVarMap varTypes seen name = do + structural <- structuralTypeSchema fieldVarMap varTypes seen name + pure $ + case structural of + A.Object o -> + A.Object $ + KM.insert (K.fromString "$schema") (A.String "https://json-schema.org/draft/2020-12/schema") $ + KM.insert (K.fromString "title") (A.String (T.pack name)) o + v -> v + +structuralTypeSchema :: FieldVarMap -> VarTypes -> Set.Set String -> String -> IO A.Value +structuralTypeSchema fieldVarMap varTypes seen name + | isNamedStringType name = pure (A.object ["type" A..= ("string" :: String)]) + | isNamedIntegerType name = pure (A.object ["type" A..= ("integer" :: String)]) + | isNamedNumberType name = pure (A.object ["type" A..= ("number" :: String)]) + | isNamedBooleanType name = pure (A.object ["type" A..= ("boolean" :: String)]) + | isNamedNonEmptyType name = + pure (A.object ["type" A..= ("array" :: String), "minItems" A..= (1 :: Int)]) + | isNamedWithOriginType name = + pure (A.object + [ "oneOf" A..= + [ A.object + [ "type" A..= ("object" :: String) + , "properties" A..= A.object + [ "tag" A..= A.object ["type" A..= ("string" :: String)] ] + , "required" A..= ["tag" :: String] + , "additionalProperties" A..= True + ] + , A.object ["type" A..= ("string" :: String)] + ] + ]) + | otherwise = + case Map.lookup name fieldVarMap of + Just byLevel | not (Map.null byLevel) -> do + props <- mergedPropsForType fieldVarMap varTypes seen name byLevel + pure (A.object + [ "type" A..= ("object" :: String) + , "additionalProperties" A..= True + , "properties" A..= A.Object props + ]) + _ -> + pure (A.object + [ "type" A..= ("object" :: String) + , "additionalProperties" A..= True + ]) + +mergedPropsForType + :: FieldVarMap + -> VarTypes + -> Set.Set String + -> String + -> Map.Map DetailLevel (Map.Map String String) + -> IO A.Object +mergedPropsForType fieldVarMap varTypes seen ctor byLevel = do + let fieldVars = + foldl' (Map.unionWith (++)) Map.empty + [ Map.map (:[]) lvlMap + | lvlMap <- Map.elems byLevel + ] + props <- mapM buildMergedProp (Map.toList fieldVars) + pure (KM.fromList props) + where + buildMergedProp (fieldName, vars) = do + schemas <- mapM (schemaForVar fieldName) vars + pure (K.fromString fieldName, mergeSchemas schemas) + + schemaForVar fieldName var + | var `elem` [literalStringVar, renderedStringVar] = + pure (A.object ["type" A..= ("string" :: String)]) + | var == integerExprVar = + pure (A.object ["type" A..= ("integer" :: String)]) + | var == numberExprVar = + pure (A.object ["type" A..= ("number" :: String)]) + | var == booleanExprVar = + pure (A.object ["type" A..= ("boolean" :: String)]) + | var == objectExprVar = + pure (A.object ["type" A..= ("object" :: String), "additionalProperties" A..= True]) + | var == arrayExprVar = + pure (A.object ["type" A..= ("array" :: String)]) + | var == stringArrayExprVar = + pure (A.object ["type" A..= ("array" :: String), "items" A..= A.object ["type" A..= ("string" :: String)]]) + | otherwise = + case Map.lookup ctor varTypes >>= Map.lookup var of + Nothing -> pure (fallbackSchemaForUnknownBindingForCtor ctor fieldName var) + Just ty -> typeToSchema "bench/trace-schemas/types" fieldVarMap varTypes seen ty + +fallbackSchemaForUnknownBindingForCtor :: ConstructorName -> String -> String -> A.Value +fallbackSchemaForUnknownBindingForCtor ctor key var + | ctor == "TracePickInboundPeers" + , lowerKey `elem` ["selected", "available"] = + A.object ["type" A..= ("array" :: String)] + | ctor == "FetchingNewLedgerState" + , lowerKey `elem` ["numberofledgerpeers", "numberofbigledgerpeers"] = + A.object ["type" A..= ("integer" :: String)] + | ctor `elem` ["TracePublicRootsResults", "TracePublicRootsFailure", "TraceBigLedgerPeersResults", "TraceBigLedgerPeersFailure"] + , lowerKey == "difftime" = + A.object ["type" A..= ("number" :: String)] + | otherwise = fallbackSchemaForUnknownBinding key var + where + lowerKey = map toLower key + +fallbackSchemaForUnknownBinding :: String -> String -> A.Value +fallbackSchemaForUnknownBinding key var + | lowerKey == "port" || lowerVar == "port" || lowerVar == "portno" = + A.object ["type" A..= ("integer" :: String)] + | lowerKey `elem` peerSelectionCounterKeys = + A.object ["type" A..= ("integer" :: String)] + | otherwise = + A.object ["type" A..= ("string" :: String)] + where + lowerKey = map toLower key + lowerVar = map toLower var + peerSelectionCounterKeys = + [ "targetknown" + , "actualknown" + , "targetestablished" + , "actualestablished" + , "targetactive" + , "actualactive" + ] + +mergeSchemas :: [A.Value] -> A.Value +mergeSchemas [] = A.object [] +mergeSchemas [x] = x +mergeSchemas xs = + let unique = dedupeValues xs + in fromMaybe (A.object ["anyOf" A..= unique]) (singleElement unique) + +dedupeValues :: [A.Value] -> [A.Value] +dedupeValues = reverse . foldl' step [] + where + step acc v = + let key = BL8.unpack (A.encode v) + in if any (\existing -> BL8.unpack (A.encode existing) == key) acc + then acc + else v : acc + +isNamedStringType, isNamedIntegerType, isNamedNumberType, isNamedBooleanType, isNamedNonEmptyType, isNamedWithOriginType :: String -> Bool +isNamedStringType name = name `elem` ["Text", "String", "ByteString", "ShortByteString", "ShortText", "HeaderHash"] +isNamedIntegerType name = name `elem` ["Int", "Integer", "Word", "Word8", "Word16", "Word32", "Word64", "Natural", "SlotNo", "EpochNo", "BlockNo"] +isNamedNumberType name = name `elem` ["Double", "Float", "NominalDiffTime", "DiffTime"] +isNamedBooleanType name = name == "Bool" +isNamedNonEmptyType name = name == "NonEmpty" || ".NonEmpty" `isSuffixOf` name +isNamedWithOriginType name = name == "WithOrigin" || ".WithOrigin" `isSuffixOf` name diff --git a/bench/trace-schemas/scripts/schema-gen/README.md b/bench/trace-schemas/scripts/schema-gen/README.md new file mode 100644 index 00000000000..1e20cd28655 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/README.md @@ -0,0 +1,99 @@ +# GhciSchemaGen overview + +`make trace-schemas-regenerate` + +or the step-by-step commands: + +`GHC_ENVIRONMENT=- nix develop -c cabal run cardano-node -- trace-documentation --config configuration/cardano/mainnet-config.yaml --output-namespace-list bench/trace-schemas/newNamespaces.txt --output-file bench/trace-schemas/trace-documentation.md` + +`nix run .#schema-gen` + +`nix run .#apply-schema-overrides -- --verbose` + +`nix run .#validate-trace-schemas` + +`nix run .#validate-trace-log -- --log-file run/.../stdout` + +Additional checks: + +`make trace-schemas-overrides-check` + +`make trace-schemas-overrides-coverage RANGE=origin/master...HEAD` + +`make trace-schemas-validate` + +## What it does + +- Generates JSON schemas for trace messages in `bench/trace-schemas/messages` and type schemas in `bench/trace-schemas/types`. +- Uses the trace-documentation command to generate `bench/trace-schemas/newNamespaces.txt` from `MetaTrace` namespaces. +- Parses `namespaceFor` and `forMachine` clauses in source files, then asks `cabal repl` (GHCi) for types of variables used in those `forMachine` patterns. + +## High-level flow + +1. **Find relevant Haskell files** + - Scans `cardano-node/src`, `cardano-submit-api/src`, `cardano-tracer/src`, `trace-forward/src`, `trace-resources/src`, and several tracing-related directories in `ouroboros-network`, `ouroboros-consensus`, and `hermod-tracing`. + - Warns when any configured source directory is missing, instead of silently ignoring it. + - Keeps only `.hs` files that contain `forMachine` or `namespaceFor`. + +2. **Build namespace mapping** + - Parses `namespaceFor` clauses to map a constructor (e.g. `ReplayBlockStats`) to namespace parts (e.g. `["LedgerReplay"]`). + - This tells it which constructor corresponds to each namespace in `bench/trace-schemas/newNamespaces.txt`. + +3. **Parse `forMachine`** + - Extracts: + - The constructor pattern in each clause. + - The JSON keys from lines like `"foo" .= ...`. + - Which pattern variable supplies each key. + - Literal string RHS like `"kind" .= String "X"` are treated as string fields. + +4. **Ask GHCi for types** + - For each file, it runs GHCi and issues `:t` queries for patterns. + - Extracts variable types from the returned type signatures or error output. + - This becomes a map `constructor -> variable -> type`. + +5. **Build/update schemas** + - For each namespace in `newNamespaces.txt`: + - Finds the matching constructor via the namespace map. + - Builds or updates the `data.properties` schema using: + - key -> variable mapping from `forMachine` + - variable types from GHCi + - If `data.properties` is still empty, it optionally pulls `data` from `bench/trace-schemas/messages-hist`. + +## Key heuristics + +- Namespace matching uses suffix match so `Namespace [] ["LedgerReplay"]` can match `ChainDB.ReplayBlock.LedgerReplay`. +- If a field uses a literal string (`String "..."`), it is treated as `type: string`. +- If `data.properties` does not exist, it synthesizes an object schema and fills properties from `forMachine`. + +## Where to look in code + +- Entry point and flow: `main` +- Namespace mapping: `parseNamespaceMap`, `findCtor` +- forMachine parsing: `parseForMachineClauses`, `parseFieldVarMap`, `parseFieldLine` +- GHCi type extraction: `ghciTypesForFile`, `runGhci` +- Schema update: `updateSchemaForNamespace`, `updateData`, `buildDataFromFieldMap` + +## Validation + +- `ValidateTraceSchemas.hs` checks `meta.schema.json` with `check-jsonschema`, then validates every file in `bench/trace-schemas/messages` against that meta-schema. +- The Haskell script controls discovery and execution; the actual JSON Schema validation is delegated to `check-jsonschema` via `nix run nixpkgs#check-jsonschema`. +- Run it via the packaged flake executable: `nix run .#validate-trace-schemas`. +- `ValidateTraceLog.hs` validates a real cardano-node log file: it skips the non-JSON preamble, validates the common envelope against `TraceMessage.schema.json`, validates known namespaces against the matching schema in `bench/trace-schemas/messages`, and reports namespaces that do not have a corresponding message schema. + +## Packaging and tests + +- The scripts are packaged in `bench/trace-schemas/scripts/schema-gen/trace-schema-gen.cabal` as executables, which is why they can be invoked with `nix run .#...`. +- The smaller helper scripts also have a package test suite: + - `nix develop -c cabal test trace-schema-gen-test` + +## Human changes that survive regeneration + +- Treat `bench/trace-schemas/messages` and `bench/trace-schemas/types` as generated outputs. +- Put manual edits in sidecar override patches under `bench/trace-schemas/overrides`. +- Apply overrides with `nix run .#apply-schema-overrides -- --verbose` after every generation. +- Enforce in CI with: + - `make trace-schemas-regenerate` + - `make trace-schemas-overrides-check` + - `make trace-schemas-overrides-coverage RANGE=origin/master...HEAD` + +See `bench/trace-schemas/overrides/README.md` for override format and file layout. diff --git a/bench/trace-schemas/scripts/schema-gen/RegenerateTraceSchemas.sh b/bench/trace-schemas/scripts/schema-gen/RegenerateTraceSchemas.sh new file mode 100644 index 00000000000..c23b28493f6 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/RegenerateTraceSchemas.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +set -euo pipefail + +ROOT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")/../../../.." && pwd)" +cd "$ROOT_DIR" + +echo "[trace-schemas] Generating namespace list and documentation..." +GHC_ENVIRONMENT=- nix develop -c cabal run cardano-node -- \ + trace-documentation \ + --config configuration/cardano/mainnet-config.yaml \ + --output-namespace-list bench/trace-schemas/newNamespaces.txt \ + --output-file bench/trace-schemas/trace-documentation.md + +echo "[trace-schemas] Generating schemas..." +nix run .#schema-gen + +echo "[trace-schemas] Applying human overrides..." +nix run .#apply-schema-overrides -- --verbose + +echo "[trace-schemas] Validating generated schemas..." +nix run .#validate-trace-schemas + +echo "[trace-schemas] Done." diff --git a/bench/trace-schemas/scripts/schema-gen/ValidateTraceLog.hs b/bench/trace-schemas/scripts/schema-gen/ValidateTraceLog.hs new file mode 100644 index 00000000000..f1c8e358474 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/ValidateTraceLog.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Exception (bracket) +import Control.Monad (forM, forM_, unless, when) +import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as Map +import qualified Data.List as List +import Data.List (isSuffixOf, sortOn) +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Text as T +import Data.Word (Word8) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , listDirectory + , removePathForcibly + ) +import System.Environment (getArgs) +import System.Exit (ExitCode (..), exitFailure, exitSuccess) +import System.FilePath ((), takeBaseName) +import System.Process (proc, readCreateProcessWithExitCode, readProcess) + +defaultTraceSchema :: FilePath +defaultTraceSchema = "bench/trace-schemas/TraceMessage.schema.json" + +defaultMessagesDir :: FilePath +defaultMessagesDir = "bench/trace-schemas/messages" + +data Config = Config + { cfgLogFile :: FilePath + , cfgTraceSchema :: FilePath + , cfgMessagesDir :: FilePath + } + +data LogEntry = LogEntry + { leLineNo :: Int + , leNamespace :: Maybe String + , leInstancePath :: FilePath + } + +data ExtractedLog = ExtractedLog + { elSkippedPreamble :: Int + , elEntries :: [LogEntry] + , elMalformedLines :: [Int] + } + +defaultConfig :: Config +defaultConfig = + Config + { cfgLogFile = "" + , cfgTraceSchema = defaultTraceSchema + , cfgMessagesDir = defaultMessagesDir + } + +main :: IO () +main = do + config <- parseArgs defaultConfig =<< getArgs + checkInputs config + namespaceSchemas <- loadNamespaceSchemas (cfgMessagesDir config) + + withTempDir "cardano-trace-log-validate" $ \tempDir -> do + extracted <- extractLogEntries (cfgLogFile config) tempDir + let entries = elEntries extracted + + when (null entries) $ do + putStrLn "No JSON trace messages found in the log file." + exitFailure + + putStrLn $ + "Skipped " + <> show (elSkippedPreamble extracted) + <> " non-log line(s) before the first JSON trace message." + + unless (null (elMalformedLines extracted)) $ + putStrLn $ + "Malformed post-preamble line(s): " + <> commaList (map show (elMalformedLines extracted)) + + envelopeOk <- + validateBatches + "Validating common trace envelope..." + (validatorArgs ["--schemafile", cfgTraceSchema config]) + (map leInstancePath entries) + + let (knownEntries, unknownEntries) = partitionKnown namespaceSchemas entries + namespaceOk <- validateKnownNamespaces knownEntries + unknownOk <- reportUnknownNamespaces unknownEntries + + let overallOk = + envelopeOk + && namespaceOk + && unknownOk + && null (elMalformedLines extracted) + + if overallOk + then do + putStrLn $ + "Validated " + <> show (length entries) + <> " trace message(s) from " + <> cfgLogFile config + exitSuccess + else exitFailure + +parseArgs :: Config -> [String] -> IO Config +parseArgs = go + where + go cfg [] = + if null (cfgLogFile cfg) + then do + putStrLn "Missing required argument: --log-file PATH" + printHelp + exitFailure + else pure cfg + go cfg ("--log-file" : path : rest) = go cfg {cfgLogFile = path} rest + go cfg ("--trace-schema" : path : rest) = go cfg {cfgTraceSchema = path} rest + go cfg ("--messages-dir" : path : rest) = go cfg {cfgMessagesDir = path} rest + go _ ["--help"] = printHelp >> exitSuccess + go _ ["-h"] = printHelp >> exitSuccess + go _ unknown = do + putStrLn $ "Unrecognized arguments: " <> unwords unknown + printHelp + exitFailure + +printHelp :: IO () +printHelp = + putStrLn $ + unlines + [ "Usage: runghc -package-env - bench/trace-schemas/scripts/schema-gen/ValidateTraceLog.hs --log-file PATH [options]" + , "" + , "Options:" + , " --log-file PATH Path to a cardano-node stdout/stderr log file." + , " --trace-schema PATH Path to TraceMessage.schema.json." + , " --messages-dir PATH Directory containing namespace message schemas." + ] + +checkInputs :: Config -> IO () +checkInputs config = do + logExists <- doesFileExist (cfgLogFile config) + unless logExists $ do + putStrLn $ "Log file not found: " <> cfgLogFile config + exitFailure + + traceSchemaExists <- doesFileExist (cfgTraceSchema config) + unless traceSchemaExists $ do + putStrLn $ "Trace schema not found: " <> cfgTraceSchema config + exitFailure + + messagesDirExists <- doesDirectoryExist (cfgMessagesDir config) + unless messagesDirExists $ do + putStrLn $ "Messages directory not found: " <> cfgMessagesDir config + exitFailure + +loadNamespaceSchemas :: FilePath -> IO (Map.Map String FilePath) +loadNamespaceSchemas root = do + schemaFiles <- listJsonFilesRecursive root + pairs <- fmap concat $ forM schemaFiles $ \path -> do + bytes <- BL.readFile path + case A.eitherDecode bytes :: Either String A.Value of + Left err -> do + putStrLn $ "Failed to parse schema file " <> path <> ": " <> err + exitFailure + Right (A.Object obj) -> + case KM.lookup "ns" obj of + Just (A.String ns) -> pure [(T.unpack ns, path)] + _ -> pure [] + Right _ -> pure [] + + let grouped = Map.fromListWith (++) [(ns, [path]) | (ns, path) <- pairs] + let duplicates = Map.toList (Map.filter ((> 1) . length) grouped) + unless (null duplicates) $ do + putStrLn "Duplicate namespaces found in message schemas:" + forM_ duplicates $ \(ns, paths) -> + putStrLn $ " " <> ns <> " -> " <> commaList paths + exitFailure + + pure (Map.mapMaybe listToMaybe grouped) + +extractLogEntries :: FilePath -> FilePath -> IO ExtractedLog +extractLogEntries logPath tempDir = do + bytes <- BS.readFile logPath + go False 1 (BS8.lines bytes) 0 [] [] + where + go _ _ [] skipped entries malformed = + pure + ExtractedLog + { elSkippedPreamble = skipped + , elEntries = reverse entries + , elMalformedLines = reverse malformed + } + go started lineNo (line : rest) skipped entries malformed = + case decodeLogLine line of + Just value -> do + instancePath <- writeInstance tempDir lineNo value + let entry = + LogEntry + { leLineNo = lineNo + , leNamespace = extractNamespace value + , leInstancePath = instancePath + } + go True (lineNo + 1) rest skipped (entry : entries) malformed + Nothing + | not started -> go False (lineNo + 1) rest (skipped + 1) entries malformed + | BS.all isIgnorableWhitespace line -> go True (lineNo + 1) rest skipped entries malformed + | otherwise -> go True (lineNo + 1) rest skipped entries (lineNo : malformed) + +decodeLogLine :: BS.ByteString -> Maybe A.Value +decodeLogLine line = + case A.decodeStrict' line of + Just value@(A.Object _) -> Just value + _ -> Nothing + +extractNamespace :: A.Value -> Maybe String +extractNamespace (A.Object obj) = + case KM.lookup "ns" obj of + Just (A.String ns) -> Just (T.unpack ns) + _ -> Nothing +extractNamespace _ = Nothing + +writeInstance :: FilePath -> Int -> A.Value -> IO FilePath +writeInstance tempDir lineNo value = do + let path = tempDir ("line-" <> padLineNo lineNo <> ".json") + BL.writeFile path (A.encode value) + pure path + +padLineNo :: Int -> String +padLineNo n = + let s = show n + width = 8 + in replicate (max 0 (width - length s)) '0' <> s + +partitionKnown :: + Map.Map String FilePath -> + [LogEntry] -> + (Map.Map FilePath [LogEntry], [LogEntry]) +partitionKnown namespaceSchemas = + List.foldl' step (Map.empty, []) + where + step (known, unknown) entry = + case leNamespace entry >>= (`Map.lookup` namespaceSchemas) of + Just schemaPath -> + (Map.insertWith (++) schemaPath [entry] known, unknown) + Nothing -> (known, entry : unknown) + +validateKnownNamespaces :: Map.Map FilePath [LogEntry] -> IO Bool +validateKnownNamespaces groups = do + results <- + forM (sortOn fst (Map.toList groups)) $ \(schemaPath, groupEntries) -> do + let namespaceLabel = fromMaybe (takeBaseName schemaPath) (leNamespace =<< safeHead groupEntries) + let header = + "Validating namespace " + <> namespaceLabel + <> " (" <> show (length groupEntries) <> " message(s))..." + validateBatches header (validatorArgs ["--schemafile", schemaPath]) (map leInstancePath groupEntries) + pure (and results) + +reportUnknownNamespaces :: [LogEntry] -> IO Bool +reportUnknownNamespaces [] = pure True +reportUnknownNamespaces entries = do + putStrLn "Namespaces not found in message schemas:" + let grouped = + Map.fromListWith (++) + [ (renderNamespace (leNamespace entry), [leLineNo entry]) + | entry <- entries + ] + forM_ (sortOn fst (Map.toList grouped)) $ \(ns, lineNos) -> + putStrLn $ + " " + <> ns + <> " at line(s) " + <> commaList (map show (sortOn id lineNos)) + pure False + +renderNamespace :: Maybe String -> String +renderNamespace (Just ns) = ns +renderNamespace Nothing = "" + +validateBatches :: String -> [String] -> [FilePath] -> IO Bool +validateBatches _ _ [] = pure True +validateBatches header baseArgs files = do + putStrLn header + let batches = chunksOf 200 files + totalBatches = length batches + results <- + forM (zip [1 :: Int ..] batches) $ \(batchNo, batch) -> do + putStrLn $ + " validating batch " + <> show batchNo + <> " of " + <> show totalBatches + <> " (" + <> show (length batch) + <> " message(s))..." + runValidator (baseArgs <> batch) + pure (and results) + +runValidator :: [String] -> IO Bool +runValidator args = do + (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode (proc "nix" args) "" + unless (null stdoutText) (putStr stdoutText) + unless (null stderrText) (putStr stderrText) + pure (exitCode == ExitSuccess) + +validatorArgs :: [String] -> [String] +validatorArgs args = + [ "run" + , "nixpkgs#check-jsonschema" + , "--" + ] + <> args + +listJsonFilesRecursive :: FilePath -> IO [FilePath] +listJsonFilesRecursive root = do + entries <- listDirectory root + fmap concat $ + forM entries $ \name -> do + let path = root name + isDir <- doesDirectoryExist path + if isDir + then listJsonFilesRecursive path + else pure [path | ".json" `isSuffixOf` path] + +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf n xs = + let (prefix, suffix) = splitAt n xs + in prefix : chunksOf n suffix + +commaList :: [String] -> String +commaList = foldr join "" + where + join item "" = item + join item acc = item <> ", " <> acc + +isIgnorableWhitespace :: Word8 -> Bool +isIgnorableWhitespace c = c == 32 || c == 9 || c == 13 + +withTempDir :: String -> (FilePath -> IO a) -> IO a +withTempDir prefix action = do + tmp <- trimTrailingNewline <$> readProcess "mktemp" ["-d", "/tmp/" <> prefix <> ".XXXXXX"] "" + createDirectoryIfMissing True tmp + bracket (pure tmp) removePathForcibly action + +trimTrailingNewline :: String -> String +trimTrailingNewline = reverse . dropWhile (== '\n') . reverse + +safeHead :: [a] -> Maybe a +safeHead (x : _) = Just x +safeHead [] = Nothing diff --git a/bench/trace-schemas/scripts/schema-gen/ValidateTraceSchemas.hs b/bench/trace-schemas/scripts/schema-gen/ValidateTraceSchemas.hs new file mode 100644 index 00000000000..7e13c3a4c4a --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/ValidateTraceSchemas.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified TraceSchemaGen.ValidateTraceSchemas as Validate + +main :: IO () +main = Validate.main diff --git a/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/ApplySchemaOverrides.hs b/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/ApplySchemaOverrides.hs new file mode 100644 index 00000000000..8988e69c68b --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/ApplySchemaOverrides.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TraceSchemaGen.ApplySchemaOverrides + ( Config (..) + , defaultConfig + , defaultRoot + , findDestructiveOps + , listOverrideFiles + , main + , mergePatch + , normalizePatch + , overrideRelToTarget + , processOverride + , readJsonFile + , stripPrefixPath + ) where + +import qualified Data.Aeson as A +import qualified Data.Aeson.Encode.Pretty as AP +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy as BL +import Control.Monad (forM, unless, when) +import Data.List (isSuffixOf, sort) +import Data.Maybe (fromMaybe) +import Options.Applicative + ( Parser + , ParserInfo + , execParser + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , progDesc + , showDefault + , strOption + , switch + , value + , (<**>) + ) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , listDirectory + ) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath + ( () + , joinPath + , replaceFileName + , splitDirectories + , takeDirectory + , takeFileName + ) + +defaultRoot :: FilePath +defaultRoot = "bench/trace-schemas" + +data Config = Config + { cfgRoot :: FilePath + , cfgCheck :: Bool + , cfgVerbose :: Bool + , cfgAllowDestructive :: Bool + } + deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = + Config + { cfgRoot = defaultRoot + , cfgCheck = False + , cfgVerbose = False + , cfgAllowDestructive = False + } + +main :: IO () +main = do + config <- execParser parserInfo + let overridesRoot = cfgRoot config "overrides" + overridesExists <- doesDirectoryExist overridesRoot + if not overridesExists + then do + when (cfgVerbose config) $ + putStrLn $ "No overrides directory at " <> overridesRoot + exitSuccess + else do + overrideFiles <- sort <$> listOverrideFiles overridesRoot + results <- forM overrideFiles (processOverride config) + let changedTargets = [target | (target, True) <- results] + when (cfgCheck config && not (null changedTargets)) $ do + putStrLn "Schema overrides are not applied (or generated files were edited directly):" + mapM_ (\fp -> putStrLn $ " " <> fp) changedTargets + exitFailure + when (cfgVerbose config) $ do + putStrLn $ "Processed " <> show (length overrideFiles) <> " override file(s)." + putStrLn $ "Updated " <> show (length changedTargets) <> " target schema file(s)." + exitSuccess + +configParser :: Parser Config +configParser = + Config + <$> strOption + ( long "root" + <> metavar "PATH" + <> value defaultRoot + <> showDefault + <> help "trace-schemas root path" + ) + <*> switch + ( long "check" + <> help "Dry-run; fail if any target file would change" + ) + <*> switch + ( long "verbose" + <> help "Print each override mapping" + ) + <*> switch + ( long "allow-destructive" + <> help "Allow overrides that delete or replace existing fields" + ) + +parserInfo :: ParserInfo Config +parserInfo = + info + (configParser <**> helper) + ( fullDesc + <> progDesc "Apply schema override sidecars to generated trace schemas" + <> header "apply-schema-overrides" + ) + +listOverrideFiles :: FilePath -> IO [FilePath] +listOverrideFiles root = do + entries <- listDirectory root + fmap concat $ + forM entries $ \name -> do + let path = root name + isDir <- doesDirectoryExist path + if isDir + then listOverrideFiles path + else pure [path | ".override.json" `isSuffixOf` name] + +processOverride :: Config -> FilePath -> IO (FilePath, Bool) +processOverride config overrideFile = do + let overridesRoot = cfgRoot config "overrides" + rel <- stripPrefixPath overridesRoot overrideFile + targetRel <- overrideRelToTarget rel + let targetFile = cfgRoot config targetRel + + targetExists <- doesFileExist targetFile + unless targetExists $ + failWith $ + "Override target does not exist: " <> targetFile + <> " (from " <> overrideFile <> ")" + + targetValue <- readJsonFile targetFile + overrideValue <- readJsonFile overrideFile + patchValue <- normalizePatch overrideFile overrideValue + + unless (cfgAllowDestructive config) $ do + let destructiveOps = findDestructiveOps targetValue patchValue + unless (null destructiveOps) $ + failWith $ + "Override " <> overrideFile <> " contains destructive operations:\n" + <> unlines (map (" " <>) destructiveOps) + <> "Pass --allow-destructive to permit destructive overrides." + + let mergedValue = mergePatch targetValue patchValue + let changed = mergedValue /= targetValue + + when (cfgVerbose config) $ + putStrLn $ overrideFile <> " -> " <> targetFile + + when (changed && not (cfgCheck config)) $ do + createDirectoryIfMissing True (takeDirectory targetFile) + BL.writeFile targetFile (AP.encodePretty mergedValue) + + pure (targetFile, changed) + +readJsonFile :: FilePath -> IO A.Value +readJsonFile fp = do + result <- A.eitherDecodeFileStrict' fp + case result of + Left err -> failWith $ "Invalid JSON in " <> fp <> ": " <> err + Right v -> pure v + +normalizePatch :: FilePath -> A.Value -> IO A.Value +normalizePatch source v@(A.Object o) = + case KM.lookup (K.fromString "patch") o of + Nothing -> pure v + Just patch@(A.Object _) -> pure patch + Just _ -> + failWith $ + "Override \"patch\" must be an object in " <> source +normalizePatch source _ = + failWith $ "Override must be a JSON object: " <> source + +findDestructiveOps :: A.Value -> A.Value -> [String] +findDestructiveOps target patch = goObj "" targetObj patchObj + where + targetObj = case target of { A.Object o -> o; _ -> KM.empty } + patchObj = case patch of { A.Object o -> o; _ -> KM.empty } + + goObj path tObj pObj = concatMap (checkKey path tObj) (KM.toList pObj) + + checkKey path tObj (k, pv) = + let kStr = K.toString k + keyPath = if null path then kStr else path <> "." <> kStr + in case (KM.lookup k tObj, pv) of + (Nothing, _) -> [] + (Just _, A.Null) -> [keyPath <> ": field deletion"] + (Just (A.Object tv), A.Object pv') -> goObj keyPath tv pv' + (Just _, _) -> [keyPath <> ": field replacement"] + +mergePatch :: A.Value -> A.Value -> A.Value +mergePatch _ A.Null = A.Null +mergePatch _ patch@(A.Bool _) = patch +mergePatch _ patch@(A.String _) = patch +mergePatch _ patch@(A.Number _) = patch +mergePatch _ patch@(A.Array _) = patch +mergePatch target (A.Object patchObj) = + let targetObj = + case target of + A.Object o -> o + _ -> KM.empty + in A.Object (mergeObject targetObj patchObj) + +mergeObject :: A.Object -> A.Object -> A.Object +mergeObject = KM.foldrWithKey step + where + step key patchValue acc = + case patchValue of + A.Null -> KM.delete key acc + A.Object _ -> + let existing = fromMaybe A.Null (KM.lookup key acc) + merged = mergePatch existing patchValue + in KM.insert key merged acc + _ -> KM.insert key patchValue acc + +stripPrefixPath :: FilePath -> FilePath -> IO FilePath +stripPrefixPath prefix full = + case stripPrefixList (splitDirectories prefix) (splitDirectories full) of + Just suffix -> pure (joinPath suffix) + Nothing -> + failWith $ + "Path " <> full <> " is not under " <> prefix + +overrideRelToTarget :: FilePath -> IO FilePath +overrideRelToTarget rel = do + let name = takeFileName rel + let suffix = ".override.json" :: String + unless (suffix `isSuffixOf` name) $ + failWith $ "Override must end with .override.json: " <> rel + let targetName = take (length name - length suffix) name <> ".json" + pure (replaceFileName rel targetName) + +stripPrefixList :: Eq a => [a] -> [a] -> Maybe [a] +stripPrefixList [] ys = Just ys +stripPrefixList _ [] = Nothing +stripPrefixList (x : xs) (y : ys) + | x == y = stripPrefixList xs ys + | otherwise = Nothing + +failWith :: String -> IO a +failWith msg = putStrLn ("ERROR: " <> msg) >> exitFailure diff --git a/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/CheckOverrideCoverage.hs b/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/CheckOverrideCoverage.hs new file mode 100644 index 00000000000..1c380a54338 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/CheckOverrideCoverage.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TraceSchemaGen.CheckOverrideCoverage + ( Config (..) + , defaultConfig + , generatedRoots + , generatedToOverride + , isGeneratedJson + , listChangedPaths + , main + , overridesRoot + ) where + +import Control.Monad (unless, when) +import Data.List (isPrefixOf, isSuffixOf, sort, stripPrefix) +import Options.Applicative + ( Parser + , ParserInfo + , execParser + , fullDesc + , help + , helper + , info + , long + , metavar + , optional + , progDesc + , strOption + , (<**>) + ) +import qualified Data.Set as Set +import System.Exit (ExitCode (..), exitFailure, exitSuccess) +import System.FilePath (dropExtension) +import System.Process (proc, readCreateProcessWithExitCode) + +generatedRoots :: [FilePath] +generatedRoots = + [ "bench/trace-schemas/messages" + , "bench/trace-schemas/types" + ] + +overridesRoot :: FilePath +overridesRoot = "bench/trace-schemas/overrides" + +newtype Config = Config + { cfgRange :: Maybe String + } + deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = Config {cfgRange = Nothing} + +main :: IO () +main = do + config <- execParser parserInfo + generatedChanged <- listChangedPaths config generatedRoots + overrideChanged <- Set.fromList <$> listChangedPaths config [overridesRoot] + + let generatedChangedSet = Set.fromList (filter isGeneratedJson generatedChanged) + let requiredOverrideFiles = Set.map generatedToOverride generatedChangedSet + let missing = sort (Set.toList (Set.difference requiredOverrideFiles overrideChanged)) + + when (null generatedChangedSet) $ do + putStrLn "No generated trace-schema files changed." + exitSuccess + + unless (null missing) $ do + putStrLn "Generated schema files changed without matching override sidecar updates:" + mapM_ (\fp -> putStrLn $ " " <> fp) missing + putStrLn "" + putStrLn "Update corresponding files under bench/trace-schemas/overrides/." + exitFailure + + putStrLn "Override coverage check passed." + exitSuccess + +configParser :: Parser Config +configParser = + Config + <$> optional + ( strOption + ( long "range" + <> metavar "GIT_RANGE" + <> help "Diff range to inspect, e.g. origin/master...HEAD" + ) + ) + +parserInfo :: ParserInfo Config +parserInfo = + info + (configParser <**> helper) + ( fullDesc + <> progDesc "Check that changed generated schemas have matching override updates" + ) + +listChangedPaths :: Config -> [FilePath] -> IO [FilePath] +listChangedPaths config paths = do + let baseArgs = + case cfgRange config of + Just r -> ["diff", "--name-only", r, "--"] + Nothing -> ["diff", "--name-only", "--"] + args = baseArgs <> paths + (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode (proc "git" args) "" + case exitCode of + ExitSuccess -> pure (filter (not . null) (lines stdoutText)) + ExitFailure _ -> do + unless (null stdoutText) (putStr stdoutText) + unless (null stderrText) (putStr stderrText) + exitFailure + +isGeneratedJson :: FilePath -> Bool +isGeneratedJson path = + any (`isPrefixOf` path) generatedRoots + && ".schema.json" `isSuffixOf` path + +generatedToOverride :: FilePath -> FilePath +generatedToOverride generatedPath = + case stripPrefix "bench/trace-schemas/" generatedPath of + Just rel -> + let withoutSuffix = dropExtension rel + in overridesRoot <> "/" <> withoutSuffix <> ".override.json" + Nothing -> generatedPath diff --git a/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/ValidateTraceSchemas.hs b/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/ValidateTraceSchemas.hs new file mode 100644 index 00000000000..720c8e097d8 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/src/TraceSchemaGen/ValidateTraceSchemas.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TraceSchemaGen.ValidateTraceSchemas + ( Config (..) + , checkInputs + , defaultConfig + , defaultMessagesDir + , defaultMetaSchema + , listJsonFilesRecursive + , main + , parseArgs + , runValidator + , validatorArgs + ) where + +import Control.Monad (unless, when) +import Data.List (isSuffixOf) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , listDirectory + ) +import System.Environment (getArgs) +import System.Exit (ExitCode (..), exitFailure, exitSuccess) +import System.FilePath (()) +import System.Process (proc, readCreateProcessWithExitCode) + +defaultMetaSchema :: FilePath +defaultMetaSchema = "bench/trace-schemas/meta.schema.json" + +defaultMessagesDir :: FilePath +defaultMessagesDir = "bench/trace-schemas/messages" + +data Config = Config + { cfgMetaSchema :: FilePath + , cfgMessagesDir :: FilePath + } + deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = + Config + { cfgMetaSchema = defaultMetaSchema + , cfgMessagesDir = defaultMessagesDir + } + +main :: IO () +main = do + config <- parseArgs defaultConfig =<< getArgs + checkInputs config + schemaFiles <- listJsonFilesRecursive (cfgMessagesDir config) + when (null schemaFiles) $ do + putStrLn $ "No schema files found under " <> cfgMessagesDir config + exitFailure + + runValidator "Validating meta schema..." (validatorArgs ["--check-metaschema", cfgMetaSchema config]) + runValidator + ("Validating " <> show (length schemaFiles) <> " trace schema files...") + (validatorArgs (["--schemafile", cfgMetaSchema config] <> schemaFiles)) + + putStrLn $ + "Validated " + <> show (length schemaFiles) + <> " trace schema file(s) against " + <> cfgMetaSchema config + exitSuccess + +parseArgs :: Config -> [String] -> IO Config +parseArgs = go + where + go cfg [] = pure cfg + go cfg ("--meta-schema" : path : rest) = go cfg {cfgMetaSchema = path} rest + go cfg ("--messages-dir" : path : rest) = go cfg {cfgMessagesDir = path} rest + go _ ["--help"] = printHelp >> exitSuccess + go _ ["-h"] = printHelp >> exitSuccess + go _ unknown = do + putStrLn $ "Unrecognized arguments: " <> unwords unknown + printHelp + exitFailure + +printHelp :: IO () +printHelp = + putStrLn $ + unlines + [ "Usage: runghc bench/trace-schemas/scripts/schema-gen/ValidateTraceSchemas.hs [options]" + , "" + , "Options:" + , " --meta-schema PATH Path to the meta schema." + , " --messages-dir PATH Directory containing trace schema files." + ] + +checkInputs :: Config -> IO () +checkInputs config = do + metaExists <- doesFileExist (cfgMetaSchema config) + unless metaExists $ do + putStrLn $ "Meta schema not found: " <> cfgMetaSchema config + exitFailure + + messagesExists <- doesDirectoryExist (cfgMessagesDir config) + unless messagesExists $ do + putStrLn $ "Messages directory not found: " <> cfgMessagesDir config + exitFailure + +listJsonFilesRecursive :: FilePath -> IO [FilePath] +listJsonFilesRecursive root = do + entries <- listDirectory root + paths <- mapM descend entries + pure (concat paths) + where + descend name = do + let path = root name + isDir <- doesDirectoryExist path + if isDir + then listJsonFilesRecursive path + else pure [path | ".json" `isSuffixOf` path] + +validatorArgs :: [String] -> [String] +validatorArgs args = + [ "run" + , "nixpkgs#check-jsonschema" + , "--" + ] + <> args + +runValidator :: String -> [String] -> IO () +runValidator message args = do + putStrLn message + (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode (proc "nix" args) "" + case exitCode of + ExitSuccess -> do + unless (null stdoutText) (putStr stdoutText) + unless (null stderrText) (putStr stderrText) + ExitFailure _ -> do + unless (null stdoutText) (putStr stdoutText) + unless (null stderrText) (putStr stderrText) + exitFailure diff --git a/bench/trace-schemas/scripts/schema-gen/test/Main.hs b/bench/trace-schemas/scripts/schema-gen/test/Main.hs new file mode 100644 index 00000000000..ac705798803 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/test/Main.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BL +import qualified TraceSchemaGen.ApplySchemaOverrides as Apply +import qualified TraceSchemaGen.CheckOverrideCoverage as Coverage +import qualified TraceSchemaGen.ValidateTraceSchemas as Validate +import Control.Exception (catch) +import Data.List (sort) +import System.Directory (createDirectoryIfMissing) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "trace-schema-gen" + [ applySchemaOverridesTests + , checkOverrideCoverageTests + , validateTraceSchemasTests + ] + +applySchemaOverridesTests :: TestTree +applySchemaOverridesTests = + testGroup "ApplySchemaOverrides" + [ testCase "overrideRelToTarget maps nested override file" $ do + actual <- Apply.overrideRelToTarget "messages/Foo/Bar.schema.override.json" + actual @?= "messages/Foo/Bar.schema.json" + , testCase "findDestructiveOps reports replacement and deletion" $ do + let target = A.object ["keep" A..= ("x" :: String), "nested" A..= A.object ["gone" A..= (1 :: Int)]] + let patch = A.object ["keep" A..= (2 :: Int), "nested" A..= A.object ["gone" A..= A.Null]] + Apply.findDestructiveOps target patch + @?= ["keep: field replacement", "nested.gone: field deletion"] + , testCase "processOverride applies additive patch in temp tree" $ + withSystemTempDirectory "trace-schema-gen" $ \root -> do + let target = root "messages" "Example.schema.json" + let override = root "overrides" "messages" "Example.schema.override.json" + createDirectoryIfMissing True (root "messages") + createDirectoryIfMissing True (root "overrides" "messages") + BL.writeFile target (A.encode (A.object ["existing" A..= ("value" :: String)])) + BL.writeFile override (A.encode (A.object ["patch" A..= A.object ["added" A..= (1 :: Int)]])) + + let cfg = Apply.defaultConfig {Apply.cfgRoot = root} + (writtenTarget, changed) <- Apply.processOverride cfg override + + writtenTarget @?= target + assertBool "expected target to change" changed + + decoded <- A.eitherDecodeFileStrict' target + decoded @?= Right (A.object ["existing" A..= ("value" :: String), "added" A..= (1 :: Int)]) + , testCase "processOverride rejects destructive patch by default" $ + withSystemTempDirectory "trace-schema-gen" $ \root -> do + let target = root "messages" "Example.schema.json" + let override = root "overrides" "messages" "Example.schema.override.json" + createDirectoryIfMissing True (root "messages") + createDirectoryIfMissing True (root "overrides" "messages") + BL.writeFile target (A.encode (A.object ["existing" A..= ("value" :: String)])) + BL.writeFile override (A.encode (A.object ["patch" A..= A.object ["existing" A..= (1 :: Int)]])) + + let cfg = Apply.defaultConfig {Apply.cfgRoot = root} + result <- catch (Apply.processOverride cfg override >> pure Nothing) exitCodeToMaybe + assertBool "expected processOverride to exit with failure" $ + case result of + Just (ExitFailure _) -> True + _ -> False + ] + +checkOverrideCoverageTests :: TestTree +checkOverrideCoverageTests = + testGroup "CheckOverrideCoverage" + [ testCase "isGeneratedJson matches schema outputs only" $ do + assertBool "messages schema should match" $ + Coverage.isGeneratedJson "bench/trace-schemas/messages/Foo.schema.json" + assertBool "types schema should match" $ + Coverage.isGeneratedJson "bench/trace-schemas/types/Foo.schema.json" + assertBool "override file should not match" $ + not (Coverage.isGeneratedJson "bench/trace-schemas/overrides/messages/Foo.schema.override.json") + , testCase "generatedToOverride maps generated schema path" $ do + Coverage.generatedToOverride "bench/trace-schemas/messages/Foo.schema.json" + @?= "bench/trace-schemas/overrides/messages/Foo.schema.override.json" + ] + +validateTraceSchemasTests :: TestTree +validateTraceSchemasTests = + testGroup "ValidateTraceSchemas" + [ testCase "listJsonFilesRecursive finds nested json files only" $ + withSystemTempDirectory "trace-schema-gen" $ \root -> do + let nested = root "nested" + createDirectoryIfMissing True nested + writeFile (root "one.json") "{}" + writeFile (nested "two.json") "{}" + writeFile (nested "skip.txt") "nope" + + files <- sort <$> Validate.listJsonFilesRecursive root + files @?= sort [root "one.json", nested "two.json"] + , testCase "validatorArgs prepend nix check-jsonschema invocation" $ do + Validate.validatorArgs ["--schemafile", "meta.schema.json", "msg.schema.json"] + @?= ["run", "nixpkgs#check-jsonschema", "--", "--schemafile", "meta.schema.json", "msg.schema.json"] + , testCase "checkInputs accepts existing files and directories" $ + withSystemTempDirectory "trace-schema-gen" $ \root -> do + let meta = root "meta.schema.json" + let messages = root "messages" + writeFile meta "{}" + createDirectoryIfMissing True messages + Validate.checkInputs Validate.defaultConfig + { Validate.cfgMetaSchema = meta + , Validate.cfgMessagesDir = messages + } + , testCase "checkInputs fails on missing inputs" $ + withSystemTempDirectory "trace-schema-gen" $ \root -> do + let cfg = + Validate.defaultConfig + { Validate.cfgMetaSchema = root "missing.schema.json" + , Validate.cfgMessagesDir = root "missing-dir" + } + result <- catch (Validate.checkInputs cfg >> pure Nothing) exitCodeToMaybe + assertBool "expected checkInputs to exit with failure" $ + case result of + Just (ExitFailure _) -> True + _ -> False + ] + +exitCodeToMaybe :: ExitCode -> IO (Maybe ExitCode) +exitCodeToMaybe code = pure (Just code) diff --git a/bench/trace-schemas/scripts/schema-gen/trace-schema-gen.cabal b/bench/trace-schemas/scripts/schema-gen/trace-schema-gen.cabal new file mode 100644 index 00000000000..f10f32355d3 --- /dev/null +++ b/bench/trace-schemas/scripts/schema-gen/trace-schema-gen.cabal @@ -0,0 +1,106 @@ +cabal-version: 3.0 + +name: trace-schema-gen +version: 0.1.0.0 +synopsis: Scripts for generating and validating cardano-node trace JSON schemas +category: Cardano, Tracing +copyright: 2024-2026 Input Output Global Inc (IOG), 2024-2026 Intersect. +author: IOHK +maintainer: operations@iohk.io +license: Apache-2.0 +build-type: Simple + +common common + default-language: Haskell2010 + ghc-options: + -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wcompat + build-depends: + base >= 4.14 && < 5, + +library + import: common + hs-source-dirs: src + exposed-modules: + TraceSchemaGen.ApplySchemaOverrides + TraceSchemaGen.CheckOverrideCoverage + TraceSchemaGen.ValidateTraceSchemas + build-depends: + aeson, + aeson-pretty, + bytestring, + containers, + directory, + filepath, + optparse-applicative, + process, + text, + vector, + +executable schema-gen + import: common + main-is: GhciSchemaGen.hs + hs-source-dirs: . + build-depends: + aeson, + aeson-pretty, + bytestring, + containers, + directory, + filepath, + process, + text, + vector, + +executable apply-schema-overrides + import: common + main-is: ApplySchemaOverrides.hs + hs-source-dirs: . + build-depends: + trace-schema-gen, + +executable validate-trace-schemas + import: common + main-is: ValidateTraceSchemas.hs + hs-source-dirs: . + build-depends: + trace-schema-gen, + +executable validate-trace-log + import: common + main-is: ValidateTraceLog.hs + hs-source-dirs: . + build-depends: + aeson, + bytestring, + containers, + directory, + filepath, + process, + text, + +executable check-override-coverage + import: common + main-is: CheckOverrideCoverage.hs + hs-source-dirs: . + build-depends: + trace-schema-gen, + +test-suite trace-schema-gen-test + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + aeson, + bytestring, + directory, + filepath, + tasty, + tasty-hunit, + temporary, + text, + trace-schema-gen, diff --git a/cabal.project b/cabal.project index 33c782f5396..bb4734fc3db 100644 --- a/cabal.project +++ b/cabal.project @@ -46,6 +46,7 @@ packages: bench/tx-generator bench/cardano-recon-framework bench/cardano-timeseries-io + bench/trace-schemas/scripts/schema-gen trace-resources trace-forward @@ -108,3 +109,5 @@ if impl(ghc >= 9.12) proto-lens-tests-dep proto-lens-tests proto-lens + + diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index 311a5da279c..c8478b5d8d6 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -20,18 +20,19 @@ module Cardano.Node.Tracing.Documentation , docTracersFirstPhase ) where +import Ouroboros.Network.Tracing.TxSubmission.Inbound () +import Ouroboros.Network.Tracing.TxSubmission.Outbound () +import Ouroboros.Network.Tracing.PeerSelection () +import Cardano.Network.Tracing.PeerSelection () +import Cardano.Network.Tracing.PeerSelectionCounters () import Cardano.Git.Rev (gitRev) import Cardano.Logging as Logging import Cardano.Logging.Resources import Cardano.Logging.Resources.Types () -import Cardano.Network.NodeToNode (RemoteAddress) -import qualified Cardano.Network.NodeToNode as NtN import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano.PublicRootPeers import qualified Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano import qualified Cardano.Network.PeerSelection.Governor.Types as Cardano import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) -import Cardano.Network.Tracing.PeerSelection () -import Cardano.Network.Tracing.PeerSelectionCounters () import Cardano.Node.Handlers.Shutdown (ShutdownTrace) import Cardano.Node.Startup import Cardano.Node.Tracing.DefaultTraceConfig (defaultCardanoConfig) @@ -85,6 +86,8 @@ import Ouroboros.Network.Driver.Simple (TraceSendRecv) import qualified Ouroboros.Network.Driver.Stateful as Stateful (TraceSendRecv) import qualified Ouroboros.Network.InboundGovernor as InboundGovernor import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) +import Cardano.Network.NodeToNode (RemoteAddress) +import qualified Cardano.Network.NodeToNode as NtN import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), PeerSelectionCounters, TracePeerSelection) import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers) @@ -104,12 +107,11 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) import qualified Ouroboros.Network.Server as Server (Trace (..)) import Ouroboros.Network.Snocket (LocalAddress (..)) -import Ouroboros.Network.Tracing () -import Ouroboros.Network.Tracing.PeerSelection () -import Ouroboros.Network.Tracing.TxSubmission.Inbound () -import Ouroboros.Network.Tracing.TxSubmission.Outbound () import Ouroboros.Network.TxSubmission.Inbound.V2 (TraceTxSubmissionInbound) import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound) +import Ouroboros.Network.Tracing () +import Network.Mux.Tracing () +import qualified Network.Mux as Mux import Control.Monad (forM_) import Data.Aeson.Types (ToJSON) @@ -118,8 +120,6 @@ import Data.Text (pack) import qualified Data.Text.IO as T import Data.Time (getZonedTime) import Data.Version (showVersion) -import qualified Network.Mux as Mux -import Network.Mux.Tracing () import qualified Network.Socket as Socket import qualified Options.Applicative as Opt import System.IO @@ -129,9 +129,10 @@ import Paths_cardano_node (version) data TraceDocumentationCmd = TraceDocumentationCmd - { tdcConfigFile :: FilePath - , tdcOutput :: FilePath - , tdMetricsHelp :: Maybe FilePath + { tdcConfigFile :: FilePath + , tdcOutput :: FilePath + , tdMetricsHelp :: Maybe FilePath + , tdNamespaceList :: Maybe FilePath } parseTraceDocumentationCmd :: Opt.Parser TraceDocumentationCmd @@ -160,6 +161,12 @@ parseTraceDocumentationCmd = <> Opt.help "Metrics helptext file for cardano-tracer (JSON)" ) ) + <*> Opt.optional (Opt.strOption + ( Opt.long "output-namespace-list" + <> Opt.metavar "FILE" + <> Opt.help "Namespace list file (text)" + ) + ) Opt.<**> Opt.helper) $ mconcat [ Opt.progDesc "Generate the trace documentation" ] ] @@ -172,7 +179,7 @@ runTraceDocumentationCmd :: TraceDocumentationCmd -> IO () runTraceDocumentationCmd TraceDocumentationCmd{..} = do - docTracers tdcConfigFile tdcOutput tdMetricsHelp + docTracers tdcConfigFile tdcOutput tdMetricsHelp tdNamespaceList -- Have to repeat the construction of the tracers here, -- as the tracers are behind old tracer interface after construction in mkDispatchTracers. @@ -181,10 +188,11 @@ docTracers :: FilePath -> FilePath -> Maybe FilePath + -> Maybe FilePath -> IO () -docTracers configFileName outputFileName mbMetricsHelpFilename = do +docTracers configFileName outputFileName mbMetricsHelpFilename mbNamespaceList = do (bl, trConfig) <- docTracersFirstPhase (Just configFileName) - docTracersSecondPhase outputFileName mbMetricsHelpFilename trConfig bl + docTracersSecondPhase outputFileName mbMetricsHelpFilename mbNamespaceList trConfig bl -- Have to repeat the construction of the tracers here, @@ -773,10 +781,11 @@ docTracersFirstPhase condConfigFileName = do docTracersSecondPhase :: FilePath -> Maybe FilePath + -> Maybe FilePath -> TraceConfig -> DocTracer -> IO () -docTracersSecondPhase outputFileName mbMetricsHelpFilename trConfig bl = do +docTracersSecondPhase outputFileName mbMetricsHelpFilename mbNamespaceList trConfig bl = do let text = docuResultsToText bl trConfig time <- getZonedTime let stamp = "Generated at " @@ -788,6 +797,8 @@ docTracersSecondPhase outputFileName mbMetricsHelpFilename trConfig bl = do doWrite outputFileName (text <> stamp) forM_ mbMetricsHelpFilename $ \f -> doWrite f (docuResultsToMetricsHelptext bl) + forM_ mbNamespaceList $ \f -> + doWrite f (docuResultsToNamespaces bl) where doWrite outfile text = withFile outfile WriteMode $ \handle ->