server/tests: Feature Matrix Compatibility Report

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6827
GitOrigin-RevId: f4d93684e5f47a6e43b4e870d2c87dbdee8f0bd8

cabal.project.freeze

@@ -189,6 +189,7 @@ constraints: any.Cabal ==3.6.3.0,
              any.lifted-base ==0.2.3.12,
              any.list-t ==1.0.5.1,
              any.logict ==0.7.0.3,
+             any.lucid2 ==0.0.20221012,
              any.managed ==1.0.9,
              any.megaparsec ==9.2.0,
              any.memory ==0.17.0,
@@ -374,4 +375,4 @@ constraints: any.Cabal ==3.6.3.0,
              any.xml-types ==0.3.8,
              any.yaml ==0.11.7.0,
              any.zlib ==0.6.2.3,
-index-state: hackage.haskell.org 2022-09-21T21:18:32Z
+index-state: hackage.haskell.org 2022-11-10T12:19:34Z

server/lib/api-tests/api-tests.cabal

@@ -171,3 +171,43 @@ executable api-tests
     Test.Subscriptions.DerivedDataSpec
     Test.Subscriptions.LiveQueriesSpec
     Test.Subscriptions.StreamingSubscriptionsSpec
+
+executable render-feature-matrix
+  build-depends:
+    , aeson
+    , attoparsec
+    , base
+    , bytestring
+    , containers
+    , lucid2
+    , mtl
+    , text
+
+  default-extensions:
+    BlockArguments
+    DataKinds
+    DeriveGeneric
+    DerivingStrategies
+    ImportQualifiedPost
+    MultiWayIf
+    NamedFieldPuns
+    NoImplicitPrelude
+    OverloadedStrings
+    PatternGuards
+    RecordWildCards
+    ScopedTypeVariables
+    TypeApplications
+    TypeFamilies
+
+  hs-source-dirs: src-render-feature-matrix
+  default-language: Haskell2010
+
+  -- Turning off optimizations is intentional; tests aren't
+  -- performance sensitive and waiting for compilation is a problem.
+  ghc-options:
+    -Wall
+    -Werror
+    -threaded
+    -rtsopts "-with-rtsopts=-N"
+
+  main-is: Main.hs

server/lib/api-tests/src-render-feature-matrix/Main.hs

@@ -0,0 +1,210 @@
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
+module Main (main) where
+
+import Control.Applicative
+import Control.Monad.Except
+import Control.Monad.State
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Attoparsec.ByteString as Atto
+import Data.ByteString (ByteString, interact)
+import Data.ByteString.Lazy qualified as LBS
+import Data.Foldable
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as M
+import Data.Maybe
+import Data.Set qualified as Set
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lucid
+import Prelude hiding (interact)
+
+type FeatureName = Text
+
+type Features = Map FeatureName [TestRun]
+
+data TestRun = TestRun
+  { -- Extra data we capture but do not currently use.
+    _testRunRequirement :: Text,
+    testRunGroups :: [Text],
+    testRunPassed :: Bool,
+    -- Extra data we capture but do not currently use.
+    _testRunHspecItem :: HspecItem
+  }
+
+data HspecEventItemDone = HspecEventItemDone
+  { heidGroups :: [Text],
+    heidItem :: HspecItem,
+    heidRequirement :: Text
+  }
+
+{- Decode things from events such as:
+
+    {
+        "event_tag": "ItemDone",
+        "groups": [
+            "Test.HelloWorld",
+            "Postgres",
+            "Example test"
+        ],
+        "item": {
+            "duration": 1.1321041419996618,
+            "info": "",
+            "location": {
+                "column": 5,
+                "file": "test/Test/HelloWorldSpec.hs",
+                "line": 60
+            },
+            "result": {
+                "result": "Success"
+            }
+        },
+        "requirement": "Works as expected",
+        "type": "Hspec Event"
+    }
+-}
+
+instance FromJSON HspecEventItemDone where
+  parseJSON =
+    withObject
+      "Hspec Event ItemDone"
+      ( \o -> do
+          let tags = parseMaybe (\o -> (,) <$> o .: "type" <*> o .: "event_tag") o
+          unless
+            (tags == Just ("Hspec Event" :: Text, "ItemDone" :: Text))
+            (fail "Not a Hspec Event ItemDone")
+
+          HspecEventItemDone <$> o .: "groups" <*> o .: "item" <*> o .: "requirement"
+      )
+
+data HspecItem = HspecItem
+  { hiResult :: HspecItemResult
+  }
+
+instance FromJSON HspecItem where
+  parseJSON =
+    withObject
+      "Hspec Item"
+      ( \o -> HspecItem <$> o .: "result"
+      )
+
+data HspecItemResult = HIRSuccess | HIRPending Text | HIRFailure Value -- Failures have details that we don't care about just yet.
+
+instance FromJSON HspecItemResult where
+  parseJSON =
+    withObject
+      "Hspec Item Result"
+      ( \o -> do
+          result :: String <- o .: "result"
+          case result of
+            "Success" -> pure HIRSuccess
+            "Failure" -> HIRFailure <$> (o .: "reason")
+            "Pending" -> HIRPending <$> (o .: "message")
+            _ -> fail $ "Unknown result type: " ++ result
+      )
+
+main :: IO ()
+main = interact \stdIn ->
+  let parsedLogs = parseLogs stdIn
+      features = runExcept . flip execStateT mempty . traverse extractFeatures <$> parsedLogs
+   in renderFeatureMatrix features
+
+parseLogs :: ByteString -> Atto.Result [Value]
+parseLogs = noPartial . Atto.parse (json `sepBy` (string "\n") <* (option () (void (string "\n")) *> endOfInput))
+
+noPartial :: Atto.Result a -> Atto.Result a
+noPartial (Partial c) = c "" -- You signal Attoparsec that you're done by
+-- giving an empty string to partial results. A bit weird...
+noPartial r = r
+
+extractFeatures :: Value -> (StateT Features (Except Text)) ()
+extractFeatures v = do
+  case parseEither parseJSON v of
+    -- Skip this entry, as it's uninteresting.
+    Left "Error in $: Not a Hspec Event ItemDone" -> return ()
+    -- We do want to report other errors though, because those are indicative
+    -- of format changes that we need to catch in order to ensure we're
+    -- reporting correctly.
+    Left err -> throwError (T.pack err)
+    Right (itemDone :: HspecEventItemDone) -> do
+      case testRun itemDone of
+        Nothing -> return ()
+        Just run -> modify (M.unionWith (<>) (M.singleton (featureName itemDone) [run]))
+  where
+    featureName :: HspecEventItemDone -> FeatureName
+    featureName HspecEventItemDone {..} = case heidGroups of
+      [] -> "empty??"
+      name : _ -> T.takeWhile (/= '.') $ fromMaybe name (T.stripPrefix "Test." name)
+
+    testRun :: HspecEventItemDone -> Maybe TestRun
+    testRun HspecEventItemDone {..} =
+      TestRun heidRequirement
+        <$> pure heidGroups
+        <*> case hiResult heidItem of
+          HIRSuccess -> Just True
+          HIRPending {} -> Nothing -- We don't care about pending items
+          HIRFailure {} -> Just False
+        <*> pure heidItem
+
+-- | Output the rendered feature matrix to stdout.
+renderFeatureMatrix :: Atto.Result (Either Text Features) -> ByteString
+renderFeatureMatrix =
+  LBS.toStrict . renderBS . \case
+    Fail unconsumed contexts errorMsg ->
+      reportHead do
+        h1_ "Failed to decode json"
+        pre_ (toHtml errorMsg)
+        pre_ (toHtml unconsumed)
+        mapM_ (pre_ . toHtml) contexts
+    Partial {} ->
+      reportHead do
+        h1_ "Failed to decode json (`Partial` result, impossible?)"
+    Done unconsumed (Left err) ->
+      reportHead do
+        h1_ "Failed to gather feature information"
+        pre_ (toHtml err)
+        h1_ "Maybe unconsumed input remains"
+        pre_ (toHtml unconsumed)
+    Done "" (Right features) ->
+      reportHead do
+        h1_ reportTitle
+        table_ $ traverse_ featureRow (M.toList features)
+    Done unconsumed (Right _) ->
+      reportHead do
+        h1_ "Parsing succeded, but unconsumed input remains (impossible?)"
+        pre_ (toHtml unconsumed)
+  where
+    reportHead :: Html () -> Html ()
+    reportHead content =
+      doctypehtml_ do
+        head_ (title_ reportTitle)
+        body_ content
+
+    reportTitle = "Feature Matrix Compatibility Report"
+
+    featureRow :: (FeatureName, [TestRun]) -> Html ()
+    featureRow (name, runs) = tr_ $ do
+      td_ (toHtml name)
+      td_ [title_ (runNames runs)] (runsStatus runs)
+
+    -- Construct a sensible list of indications of which tests have been run.
+    runNames :: [TestRun] -> Text
+    runNames =
+      T.unlines
+        . Set.toList
+        . Set.fromList
+        . filter (not . T.null)
+        . map (inlineGroups . testRunGroups)
+
+    inlineGroups :: [Text] -> Text
+    inlineGroups groups =
+      T.intercalate
+        "."
+        (filter (/= "Postgres") $ tail groups)
+
+    runsStatus :: [TestRun] -> Html ()
+    runsStatus runs
+      | all testRunPassed runs = "☑️ "
+      | otherwise = "☒"