Coverage.hs

{-# OPTIONS_GHC -Werror=incomplete-patterns #-}

-- | Reporting-only structural coverage over the checked mapped-type graph.
--
-- The report intentionally has no aggregate percentage. Private persisted event
-- payloads and mapped register cache boundaries have different authorities, and
-- queue/public-contract payloads are not represented by this graph at all.
module Keiro.Dsl.Coverage
  ( CoverageSurface (..),
    CoverageMode (..),
    CoverageRoot (..),
    StructuralBoundary (..),
    OpaqueBoundary (..),
    JsonBoundary (..),
    SnapshotBoundary (..),
    UnsupportedSurface (..),
    CoverageCounts (..),
    CoverageSummary (..),
    CoverageFinding (..),
    CoveragePrevious (..),
    CoverageDelta (..),
    CoverageReport (..),
    coverageReport,
    coverageDiffReport,
    failOnOpaque,
    failOnOpaqueIncrease,
    coverageSucceeded,
    renderCoverageSummary,
    renderCoverageFinding,
    writeCoverageReport,
  )
where

import Data.Aeson (ToJSON (..), object, (.=))
import Data.Aeson qualified as Aeson
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Dsl.Grammar
import Keiro.Dsl.TypeGraph
import Keiro.Dsl.Validate (DiagnosticCode (..), Severity (..))
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)

data CoverageSurface = PrivateEventPayload | SnapshotRegister
  deriving stock (Eq, Ord, Show)

data CoverageMode = StructuralCoverage | OpaqueCoverage
  deriving stock (Eq, Ord, Show)

data CoverageRoot = CoverageRoot
  { rootSurface :: !CoverageSurface,
    rootPath :: !Text,
    rootMappedType :: !Text,
    rootMode :: !CoverageMode,
    rootCanonicalType :: !(Maybe Text),
    rootCodecIdentity :: !(Maybe Text),
    rootCodecVersion :: !(Maybe Text),
    rootWireFingerprint :: !Text
  }
  deriving stock (Eq, Ord, Show)

data StructuralBoundary = StructuralBoundary
  { structuralRoot :: !Text,
    structuralPath :: !Text,
    structuralMappedType :: !Text,
    structuralCanonicalType :: !Text,
    structuralWireFingerprint :: !Text
  }
  deriving stock (Eq, Ord, Show)

data OpaqueBoundary = OpaqueBoundary
  { opaqueRoot :: !Text,
    opaquePath :: !Text,
    opaqueMappedType :: !Text,
    opaqueCodecIdentity :: !Text,
    opaqueCodecVersion :: !Text
  }
  deriving stock (Eq, Ord, Show)

data JsonBoundary = JsonBoundary
  { jsonRoot :: !Text,
    jsonPath :: !Text
  }
  deriving stock (Eq, Ord, Show)

data SnapshotBoundary = SnapshotBoundary
  { snapshotRoot :: !Text,
    snapshotAggregate :: !Text,
    snapshotRegister :: !Text,
    snapshotMappedType :: !Text,
    snapshotMode :: !CoverageMode,
    snapshotEncoding :: !Text,
    snapshotInvalidation :: !Text,
    snapshotWireFingerprint :: !Text,
    snapshotEnabled :: !Bool
  }
  deriving stock (Eq, Ord, Show)

data UnsupportedSurface = UnsupportedSurface
  { unsupportedSurface :: !Text,
    unsupportedSupport :: !Text,
    unsupportedReason :: !Text
  }
  deriving stock (Eq, Ord, Show)

data CoverageCounts = CoverageCounts
  { totalRoots :: !Int,
    structuralRoots :: !Int,
    opaqueRoots :: !Int,
    jsonBoundaries :: !Int
  }
  deriving stock (Eq, Show)

data CoverageSummary = CoverageSummary
  { privateEventPayloads :: !CoverageCounts,
    snapshotRegisters :: !CoverageCounts
  }
  deriving stock (Eq, Show)

data CoverageFinding = CoverageFinding
  { findingSeverity :: !Severity,
    findingCode :: !DiagnosticCode,
    findingRoots :: ![Text],
    findingMessage :: !Text
  }
  deriving stock (Eq, Show)

data CoveragePrevious = CoveragePrevious
  { previousReference :: !Text,
    previousSummary :: !CoverageSummary,
    previousOpaqueBoundaries :: ![OpaqueBoundary]
  }
  deriving stock (Eq, Show)

data CoverageDelta = CoverageDelta
  { privateEventRootDelta :: !Int,
    snapshotRegisterRootDelta :: !Int,
    opaqueBoundaryDelta :: !Int,
    addedOpaqueBoundaries :: ![OpaqueBoundary],
    removedOpaqueBoundaries :: ![OpaqueBoundary]
  }
  deriving stock (Eq, Show)

data CoverageReport = CoverageReport
  { coverageSpec :: !FilePath,
    coverageRoots :: ![CoverageRoot],
    coverageStructuralBoundaries :: ![StructuralBoundary],
    coverageOpaqueBoundaries :: ![OpaqueBoundary],
    coverageJsonBoundaries :: ![JsonBoundary],
    coverageSnapshotBoundaries :: ![SnapshotBoundary],
    coverageUnsupportedSurfaces :: ![UnsupportedSurface],
    coverageSummary :: !CoverageSummary,
    coverageFindings :: ![CoverageFinding],
    coveragePrevious :: !(Maybe CoveragePrevious),
    coverageDelta :: !(Maybe CoverageDelta)
  }
  deriving stock (Eq, Show)

coverageReport :: FilePath -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport
coverageReport specPath spec = do
  graph <- resolveTypeGraph spec
  let roots = sortOn rootPath (map (coverageRoot graph) (persistedSites graph))
      structural = structuralBoundaryInventory graph
      opaque = opaqueBoundaryInventory graph
      json = jsonBoundaryInventory graph
      snapshots = snapshotBoundaryInventory spec graph
      summary = summarize roots json
      findings = opaqueSurfaceFindings opaque
  pure
    CoverageReport
      { coverageSpec = specPath,
        coverageRoots = roots,
        coverageStructuralBoundaries = structural,
        coverageOpaqueBoundaries = opaque,
        coverageJsonBoundaries = json,
        coverageSnapshotBoundaries = snapshots,
        coverageUnsupportedSurfaces = unsupportedInventory,
        coverageSummary = summary,
        coverageFindings = findings,
        coveragePrevious = Nothing,
        coverageDelta = Nothing
      }

coverageDiffReport :: FilePath -> Text -> Spec -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport
coverageDiffReport specPath reference oldSpec newSpec = do
  oldReport <- coverageReport (T.unpack reference <> ":" <> specPath) oldSpec
  newReport <- coverageReport specPath newSpec
  let oldOpaque = Set.fromList (coverageOpaqueBoundaries oldReport)
      newOpaque = Set.fromList (coverageOpaqueBoundaries newReport)
      added = Set.toAscList (newOpaque `Set.difference` oldOpaque)
      removed = Set.toAscList (oldOpaque `Set.difference` newOpaque)
      oldSummary = coverageSummary oldReport
      newSummary = coverageSummary newReport
      delta =
        CoverageDelta
          { privateEventRootDelta = totalRoots (privateEventPayloads newSummary) - totalRoots (privateEventPayloads oldSummary),
            snapshotRegisterRootDelta = totalRoots (snapshotRegisters newSummary) - totalRoots (snapshotRegisters oldSummary),
            opaqueBoundaryDelta = length added - length removed,
            addedOpaqueBoundaries = added,
            removedOpaqueBoundaries = removed
          }
      addedFindings =
        [ CoverageFinding
            { findingSeverity = Warning,
              findingCode = CoverageOpaqueBoundaryAdded,
              findingRoots = [opaqueRoot boundary],
              findingMessage = "opaque boundary added at " <> opaquePath boundary
            }
        | boundary <- added
        ]
  pure
    newReport
      { coverageFindings = coverageFindings newReport <> addedFindings,
        coveragePrevious =
          Just
            CoveragePrevious
              { previousReference = reference,
                previousSummary = oldSummary,
                previousOpaqueBoundaries = coverageOpaqueBoundaries oldReport
              },
        coverageDelta = Just delta
      }

failOnOpaque :: CoverageReport -> CoverageReport
failOnOpaque report
  | null boundaries = report
  | otherwise = report {coverageFindings = coverageFindings report <> [gateFinding "opaque persisted boundaries are forbidden by --fail-on-opaque" boundaries]}
  where
    boundaries = coverageOpaqueBoundaries report

failOnOpaqueIncrease :: CoverageReport -> CoverageReport
failOnOpaqueIncrease report = case coverageDelta report of
  Just delta
    | not (null (addedOpaqueBoundaries delta)) ->
        report
          { coverageFindings =
              coverageFindings report
                <> [gateFinding "new opaque persisted boundaries are forbidden by --fail-on-opaque-increase" (addedOpaqueBoundaries delta)]
          }
  _ -> report

coverageSucceeded :: CoverageReport -> Bool
coverageSucceeded = all ((/= Error) . findingSeverity) . coverageFindings

renderCoverageSummary :: CoverageReport -> Text
renderCoverageSummary report =
  T.unlines
    [ "structural/opaque boundaries (reporting only):",
      "  private-event-payloads: " <> renderCounts (privateEventPayloads summary),
      "  snapshot-registers: " <> renderCounts (snapshotRegisters summary) <> "; encoding=consumer-json-cache; invalidation=tracked",
      "  queue-payloads: unsupported",
      "  public-contracts: not-applicable (separately owned grammar)"
    ]
  where
    summary = coverageSummary report
    renderCounts counts =
      T.pack (show (totalRoots counts))
        <> " mapped roots ("
        <> T.pack (show (structuralRoots counts))
        <> " structural, "
        <> T.pack (show (opaqueRoots counts))
        <> " opaque, "
        <> T.pack (show (jsonBoundaries counts))
        <> " Json boundaries)"

renderCoverageFinding :: FilePath -> CoverageFinding -> Text
renderCoverageFinding specPath finding =
  T.pack specPath
    <> ":0: "
    <> severityText (findingSeverity finding)
    <> "["
    <> T.pack (show (findingCode finding))
    <> "]: "
    <> findingMessage finding
    <> rootsSuffix
  where
    severityText Error = "error"
    severityText Warning = "warning"
    rootsSuffix = case findingRoots finding of
      [] -> ""
      roots -> " (roots: " <> T.intercalate ", " roots <> ")"

writeCoverageReport :: FilePath -> CoverageReport -> IO ()
writeCoverageReport path report = do
  createDirectoryIfMissing True (takeDirectory path)
  Aeson.encodeFile path report

persistedSites :: TypeGraph -> [UseSite]
persistedSites = filter isPersisted . tgUseSites
  where
    isPersisted RootEventField {} = True
    isPersisted RootRegister {} = True
    isPersisted RootCommandField {} = False

coverageRoot :: TypeGraph -> UseSite -> CoverageRoot
coverageRoot graph site =
  let key = useSiteKey site
      path = renderUsePath (UsePath site [])
      fingerprint = wireFingerprint graph (unMappedKey key)
   in case Map.lookup key (tgDeclarations graph) of
        Just (ResolvedStructural declaration _) ->
          CoverageRoot
            { rootSurface = useSiteSurface site,
              rootPath = path,
              rootMappedType = unMappedKey key,
              rootMode = StructuralCoverage,
              rootCanonicalType = Just (unCanonicalTypeId (sdCanonical declaration)),
              rootCodecIdentity = Nothing,
              rootCodecVersion = Nothing,
              rootWireFingerprint = fingerprint
            }
        Just (ResolvedOpaque declaration) ->
          CoverageRoot
            { rootSurface = useSiteSurface site,
              rootPath = path,
              rootMappedType = unMappedKey key,
              rootMode = OpaqueCoverage,
              rootCanonicalType = Nothing,
              rootCodecIdentity = Just (unCodecIdentity (odCodecIdentity declaration)),
              rootCodecVersion = Just (unCodecVersion (odCodecVersion declaration)),
              rootWireFingerprint = fingerprint
            }
        Nothing -> error "coverageRoot: resolved use-site key missing from graph"

structuralBoundaryInventory :: TypeGraph -> [StructuralBoundary]
structuralBoundaryInventory graph =
  sortOn
    structuralPath
    [ StructuralBoundary
        { structuralRoot = rootText (upRoot path),
          structuralPath = renderUsePath path,
          structuralMappedType = sdName declaration,
          structuralCanonicalType = unCanonicalTypeId (sdCanonical declaration),
          structuralWireFingerprint = wireFingerprint graph (sdName declaration)
        }
    | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph),
      path <- usePaths graph (sdName declaration),
      isEventSite (upRoot path)
    ]

opaqueBoundaryInventory :: TypeGraph -> [OpaqueBoundary]
opaqueBoundaryInventory graph =
  sortOn
    opaquePath
    [ OpaqueBoundary
        { opaqueRoot = rootText (upRoot path),
          opaquePath = renderUsePath path,
          opaqueMappedType = odName declaration,
          opaqueCodecIdentity = unCodecIdentity (odCodecIdentity declaration),
          opaqueCodecVersion = unCodecVersion (odCodecVersion declaration)
        }
    | ResolvedOpaque declaration <- Map.elems (tgDeclarations graph),
      path <- usePaths graph (odName declaration),
      isEventSite (upRoot path)
    ]

jsonBoundaryInventory :: TypeGraph -> [JsonBoundary]
jsonBoundaryInventory graph =
  sortOn
    jsonPath
    [ JsonBoundary
        { jsonRoot = rootText site,
          jsonPath = renderUsePath (UsePath site segments)
        }
    | site <- persistedSites graph,
      isEventSite site,
      segments <- jsonPathsFromDecl graph Set.empty (useSiteKey site)
    ]

snapshotBoundaryInventory :: Spec -> TypeGraph -> [SnapshotBoundary]
snapshotBoundaryInventory spec graph =
  sortOn
    snapshotRoot
    [ SnapshotBoundary
        { snapshotRoot = renderUsePath (UsePath site []),
          snapshotAggregate = aggregate,
          snapshotRegister = register,
          snapshotMappedType = unMappedKey key,
          snapshotMode = declarationMode declaration,
          snapshotEncoding = "consumer-json-cache",
          snapshotInvalidation = "tracked-by-mapped-wire-fingerprint",
          snapshotWireFingerprint = wireFingerprint graph (unMappedKey key),
          snapshotEnabled = aggregateHasSnapshot aggregate
        }
    | site@(RootRegister aggregate register key) <- persistedSites graph,
      Just declaration <- [Map.lookup key (tgDeclarations graph)]
    ]
  where
    aggregateHasSnapshot name =
      any
        (\case NAggregate aggregate -> aggName aggregate == name && maybe False (const True) (aggSnapshot aggregate); _ -> False)
        (specNodes spec)

jsonPathsFromDecl :: TypeGraph -> Set.Set MappedKey -> MappedKey -> [[PathSeg]]
jsonPathsFromDecl graph visited key
  | key `Set.member` visited = []
  | otherwise = case Map.lookup key (tgDeclarations graph) of
      Nothing -> []
      Just declaration ->
        foldMappedDecl
          MappedDeclAlgebra
            { onStructuralDecl = \_ shape -> jsonPathsFromShape graph (Set.insert key visited) shape,
              onOpaqueDecl = const []
            }
          declaration

jsonPathsFromShape :: TypeGraph -> Set.Set MappedKey -> ResolvedMappedShape -> [[PathSeg]]
jsonPathsFromShape graph visited =
  foldMappedShape
    MappedShapeAlgebra
      { onRecord = \_ _ fields ->
          concat
            [ map (SegField (rwfHaskell field) (rwfKey field) :) (jsonPathsFromExpr graph visited (rwfType field))
            | field <- fields
            ],
        onEnum = const [],
        onUnion = \_ arms ->
          concat
            [ map (SegArm (rwaCtor arm) (rwaTag arm) :) (maybe [] (jsonPathsFromExpr graph visited) (rwaPayload arm))
            | arm <- arms
            ]
      }

jsonPathsFromExpr :: TypeGraph -> Set.Set MappedKey -> ResolvedTypeExpr -> [[PathSeg]]
jsonPathsFromExpr graph visited =
  foldTypeExpr
    TypeExprAlgebra
      { onText = [],
        onInt = [],
        onInteger = [],
        onBool = [],
        onNatural = [],
        onTime = [],
        onJson = [[]],
        onOptional = map (SegOptional :),
        onList = map (SegElem :),
        onMap = map (SegMapValue :),
        onRef = \key -> map (SegDecl (unMappedKey key) :) (jsonPathsFromDecl graph visited key)
      }

summarize :: [CoverageRoot] -> [JsonBoundary] -> CoverageSummary
summarize roots json =
  CoverageSummary
    { privateEventPayloads = countsFor PrivateEventPayload,
      snapshotRegisters = countsFor SnapshotRegister
    }
  where
    countsFor surface =
      let matching = filter ((== surface) . rootSurface) roots
          jsonCount = case surface of
            PrivateEventPayload -> length json
            SnapshotRegister -> 0
       in CoverageCounts
            { totalRoots = length matching,
              structuralRoots = length (filter ((== StructuralCoverage) . rootMode) matching),
              opaqueRoots = length (filter ((== OpaqueCoverage) . rootMode) matching),
              jsonBoundaries = jsonCount
            }

opaqueSurfaceFindings :: [OpaqueBoundary] -> [CoverageFinding]
opaqueSurfaceFindings boundaries =
  [ CoverageFinding
      { findingSeverity = Warning,
        findingCode = CoverageOpaqueSurface,
        findingRoots = [root],
        findingMessage = "persisted private-event root contains opaque mapped boundaries"
      }
  | root <- Set.toAscList (Set.fromList (map opaqueRoot boundaries))
  ]

gateFinding :: Text -> [OpaqueBoundary] -> CoverageFinding
gateFinding message boundaries =
  CoverageFinding
    { findingSeverity = Error,
      findingCode = CoverageOpaqueGateExceeded,
      findingRoots = Set.toAscList (Set.fromList (map opaqueRoot boundaries)),
      findingMessage = message
    }

unsupportedInventory :: [UnsupportedSurface]
unsupportedInventory =
  [ UnsupportedSurface
      { unsupportedSurface = "queue-payloads",
        unsupportedSupport = "unsupported",
        unsupportedReason = "queue payloads are not roots in the mapped-type graph"
      },
    UnsupportedSurface
      { unsupportedSurface = "public-contracts",
        unsupportedSupport = "not-applicable",
        unsupportedReason = "public contracts have a separately owned grammar and compatibility surface"
      }
  ]

useSiteKey :: UseSite -> MappedKey
useSiteKey (RootCommandField _ _ _ key) = key
useSiteKey (RootEventField _ _ _ key) = key
useSiteKey (RootRegister _ _ key) = key

useSiteSurface :: UseSite -> CoverageSurface
useSiteSurface RootEventField {} = PrivateEventPayload
useSiteSurface RootRegister {} = SnapshotRegister
useSiteSurface RootCommandField {} = error "command fields are not persisted coverage roots"

isEventSite :: UseSite -> Bool
isEventSite RootEventField {} = True
isEventSite RootRegister {} = False
isEventSite RootCommandField {} = False

rootText :: UseSite -> Text
rootText site = renderUsePath (UsePath site [])

declarationMode :: ResolvedMappedDecl -> CoverageMode
declarationMode =
  foldMappedDecl
    MappedDeclAlgebra
      { onStructuralDecl = \_ _ -> StructuralCoverage,
        onOpaqueDecl = const OpaqueCoverage
      }

instance ToJSON CoverageSurface where
  toJSON PrivateEventPayload = toJSON ("private-event-payload" :: Text)
  toJSON SnapshotRegister = toJSON ("snapshot-register" :: Text)

instance ToJSON CoverageMode where
  toJSON StructuralCoverage = toJSON ("structural" :: Text)
  toJSON OpaqueCoverage = toJSON ("opaque" :: Text)

instance ToJSON CoverageRoot where
  toJSON root =
    object
      [ "surface" .= rootSurface root,
        "path" .= rootPath root,
        "mappedType" .= rootMappedType root,
        "mode" .= rootMode root,
        "canonicalType" .= rootCanonicalType root,
        "codecIdentity" .= rootCodecIdentity root,
        "codecVersion" .= rootCodecVersion root,
        "wireFingerprint" .= rootWireFingerprint root
      ]

instance ToJSON StructuralBoundary where
  toJSON boundary =
    object
      [ "root" .= structuralRoot boundary,
        "path" .= structuralPath boundary,
        "mappedType" .= structuralMappedType boundary,
        "canonicalType" .= structuralCanonicalType boundary,
        "wireFingerprint" .= structuralWireFingerprint boundary
      ]

instance ToJSON OpaqueBoundary where
  toJSON boundary =
    object
      [ "root" .= opaqueRoot boundary,
        "path" .= opaquePath boundary,
        "mappedType" .= opaqueMappedType boundary,
        "codecIdentity" .= opaqueCodecIdentity boundary,
        "codecVersion" .= opaqueCodecVersion boundary
      ]

instance ToJSON JsonBoundary where
  toJSON boundary = object ["root" .= jsonRoot boundary, "path" .= jsonPath boundary]

instance ToJSON SnapshotBoundary where
  toJSON boundary =
    object
      [ "root" .= snapshotRoot boundary,
        "aggregate" .= snapshotAggregate boundary,
        "register" .= snapshotRegister boundary,
        "mappedType" .= snapshotMappedType boundary,
        "mode" .= snapshotMode boundary,
        "snapshotEncoding" .= snapshotEncoding boundary,
        "invalidation" .= snapshotInvalidation boundary,
        "wireFingerprint" .= snapshotWireFingerprint boundary,
        "snapshotEnabled" .= snapshotEnabled boundary
      ]

instance ToJSON UnsupportedSurface where
  toJSON surface =
    object
      [ "surface" .= unsupportedSurface surface,
        "support" .= unsupportedSupport surface,
        "reason" .= unsupportedReason surface
      ]

instance ToJSON CoverageCounts where
  toJSON counts =
    object
      [ "totalRoots" .= totalRoots counts,
        "structuralRoots" .= structuralRoots counts,
        "opaqueRoots" .= opaqueRoots counts,
        "jsonBoundaries" .= jsonBoundaries counts
      ]

instance ToJSON CoverageSummary where
  toJSON summary =
    object
      [ "privateEventPayloads" .= privateEventPayloads summary,
        "snapshotRegisters" .= snapshotRegisters summary
      ]

instance ToJSON CoverageFinding where
  toJSON finding =
    object
      [ "severity" .= severityValue (findingSeverity finding),
        "code" .= show (findingCode finding),
        "roots" .= findingRoots finding,
        "message" .= findingMessage finding
      ]
    where
      severityValue Error = "error" :: Text
      severityValue Warning = "advisory"

instance ToJSON CoveragePrevious where
  toJSON previous =
    object
      [ "reference" .= previousReference previous,
        "summary" .= previousSummary previous,
        "opaqueBoundaries" .= previousOpaqueBoundaries previous
      ]

instance ToJSON CoverageDelta where
  toJSON delta =
    object
      [ "privateEventRootDelta" .= privateEventRootDelta delta,
        "snapshotRegisterRootDelta" .= snapshotRegisterRootDelta delta,
        "opaqueBoundaryDelta" .= opaqueBoundaryDelta delta,
        "addedOpaqueBoundaries" .= addedOpaqueBoundaries delta,
        "removedOpaqueBoundaries" .= removedOpaqueBoundaries delta
      ]

instance ToJSON CoverageReport where
  toJSON report =
    object
      [ "schema" .= ("keiro-dsl/coverage-report/1" :: Text),
        "spec" .= coverageSpec report,
        "roots" .= coverageRoots report,
        "structuralBoundaries" .= coverageStructuralBoundaries report,
        "opaqueBoundaries" .= coverageOpaqueBoundaries report,
        "jsonBoundaries" .= coverageJsonBoundaries report,
        "snapshotBoundaries" .= coverageSnapshotBoundaries report,
        "unsupportedSurfaces" .= coverageUnsupportedSurfaces report,
        "summary" .= coverageSummary report,
        "findings" .= coverageFindings report,
        "previous" .= coveragePrevious report,
        "delta" .= coverageDelta report
      ]