Add tool to aggregate and push test statistics from junit/ant XML rep…

…orts (#3652)

Co-authored-by: Akshay Mankar <akshay@wire.com>

cabal.project

@@ -55,6 +55,7 @@ packages:
   , tools/rex/
   , tools/stern/
   , tools/mlsstats/
+  , tools/test-stats/
 
 tests: True
 benchmarks: True
@@ -113,6 +114,8 @@ package metrics-wai
     ghc-options: -Werror
 package migrate-sso-feature-flag
     ghc-options: -Werror
+package mlsstats
+    ghc-options: -Werror
 package move-team
     ghc-options: -Werror
 package polysemy-wire-zoo
@@ -143,6 +146,8 @@ package stern
     ghc-options: -Werror
 package tasty-cannon
     ghc-options: -Werror
+package test-stats
+    ghc-options: -Werror
 package types-common
     ghc-options: -Werror
 package types-common-aws

changelog.d/5-internal/test-stats

@@ -0,0 +1 @@
+Add tool to analyse test results in junit/ant xml format

nix/haskell-pins.nix

@@ -242,6 +242,10 @@ let
       version = "4.1.0";
       sha256 = "sha256-D6RWYBguoj+W1LwNeX04h4csXV69rrs0tZpeNr7ZBqE=";
     };
+    optparse-generic = {
+      version = "1.5.1";
+      sha256 = "sha256-TS3T6AtYfdzmPkG6SwvN/tr2Vdr4eTdGRRH2Xbd8fzM=";
+    };
   };
   # Name -> Source -> Maybe Subpath -> Drv
   mkGitDrv = name: src: subpath:

nix/local-haskell-packages.nix

@@ -56,4 +56,5 @@
   rabbitmq-consumer = hself.callPackage ../tools/rabbitmq-consumer/default.nix { inherit gitignoreSource; };
   rex = hself.callPackage ../tools/rex/default.nix { inherit gitignoreSource; };
   stern = hself.callPackage ../tools/stern/default.nix { inherit gitignoreSource; };
+  test-stats = hself.callPackage ../tools/test-stats/default.nix { inherit gitignoreSource; };
 }

nix/wire-server.nix

@@ -85,6 +85,7 @@ let
     background-worker = [ "background-worker" ];
     integration = [ "integration" ];
     rabbitmq-consumer = [ "rabbitmq-consumer" ];
+    test-stats = [ "test-stats" ];
   };
 
   attrsets = lib.attrsets;
@@ -289,6 +290,7 @@ let
       integration-dynamic-backends-s3
       integration-dynamic-backends-vhosts
     ];
+    test-stats = [ pkgs.awscli2 pkgs.jq ];
   };
 
   # useful to poke around a container during a 'kubectl exec'

tools/test-stats/Main.hs

@@ -0,0 +1,171 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2023 Wire Swiss GmbH <opensource@wire.com>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Main (main) where
+
+import Control.Exception
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.List
+import Data.Map.Monoidal (MonoidalMap)
+import Data.Map.Monoidal qualified as MonoidalMap
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import Data.Time
+import Database.PostgreSQL.Simple
+import Imports hiding (Map)
+import Options.Generic
+import Prometheus
+import Text.XML.Light
+
+main :: IO ()
+main = do
+  opts :: Options Unwrapped <- unwrapRecord "Test Statistics"
+  xmlFiles <- map ((opts.testResults <> "/") <>) . filter (".xml" `isSuffixOf`) <$> listDirectory opts.testResults
+  reports <- mconcat <$> traverse parse xmlFiles
+  pushToPostgresql opts reports
+  LBS.putStrLn =<< exportMetricsAsText
+
+-- * Command Line Options
+
+data Options w = Options
+  { testResults :: w ::: FilePath <?> "Directory containing test results in the JUNIT xml format. All files with 'xml' extension in this directory will be considered test results",
+    time :: w ::: Maybe ZonedTime <?> "Time at which the test suite was run, defaults to current time.",
+    runId :: w ::: Text <?> "ID of the flake-news run, this can be used to unite multiple test suites together",
+    codeVersion :: w ::: Text <?> "Version of the code and tests, Plainly stored next to the stats so it can be used for some analysis",
+    suiteName :: w ::: Text <?> "Name of the test suite, e.g brig, galley, integration, etc.",
+    postgresqlHost :: w ::: String <?> "Hostname for postgresql DB" <!> "localhost",
+    postgresqlPort :: w ::: Word16 <?> "Port for postgresql DB" <!> "5432",
+    postgresqlDatabase :: w ::: String <?> "The database to use in postgresql DB" <!> "flake_news",
+    postgresqlUser :: w ::: String <?> "Username for postgresql DB" <!> "flake_journalist",
+    postgresqlPassword :: w ::: String <?> "Password for postgresql DB" <!> ""
+  }
+  deriving (Generic)
+
+instance ParseRecord (Options Wrapped) where
+  parseRecord = parseRecordWithModifiers lispCaseModifiers
+
+-- * Intermediate representation
+
+type TestCase = Text
+
+data Report = Report
+  { success :: Int,
+    failure :: Int,
+    failureDesc :: [Text]
+  }
+  deriving (Show)
+
+instance Semigroup Report where
+  a <> b =
+    Report
+      (a.success + b.success)
+      (a.failure + b.failure)
+      (a.failureDesc <> b.failureDesc)
+
+successCase :: Report
+successCase = Report 1 0 mempty
+
+failureCase :: [Text] -> Report
+failureCase = Report 0 1
+
+-- * XML parser
+
+-- | Returns (report by test case name, overallTestSuiteFailures, overallTestSuiteSucesses)
+--
+-- The overall numbers are always 1 or 0 and wrapped in the `Sum` type so we can
+-- mconcat them to get the overall sum.
+parse :: FilePath -> IO (MonoidalMap TestCase Report, Sum Int, Sum Int)
+parse fn = do
+  testCaseReport <- parseRaw <$> T.readFile fn
+  if any (\r -> r.failure > 0) testCaseReport
+    then pure (testCaseReport, Sum 1, Sum 0)
+    else pure (testCaseReport, Sum 0, Sum 1)
+
+parseRaw :: Text -> MonoidalMap TestCase Report
+parseRaw = mconcat . map parseTestSuites . selectTestSuites . parseXML
+  where
+    selectTestSuites = filter (matchQName "testsuites" . elName) . onlyElems
+
+parseTestSuites :: Element -> MonoidalMap TestCase Report
+parseTestSuites = mconcat . liftM2 map (parseTestSuite . name) (children "testsuite")
+
+parseTestSuite :: [Text] -> Element -> MonoidalMap TestCase Report
+parseTestSuite names =
+  liftM2
+    (MonoidalMap.unionWith (<>))
+    (mconcat . liftM2 map (parseTestSuite . (names <>) . name) (children "testsuite"))
+    (mconcat . liftM2 map (parseTestCase . (names <>) . name) (children "testcase"))
+
+parseTestCase :: [Text] -> Element -> MonoidalMap TestCase Report
+parseTestCase names el
+  | null failures = MonoidalMap.singleton compName successCase
+  | otherwise = MonoidalMap.singleton compName $ failureCase failures
+  where
+    compName = T.intercalate "." $ names <> name el
+    failures = map (T.pack . strContent) $ children "failure" el
+
+matchQName :: String -> QName -> Bool
+matchQName = flip $ (==) . qName
+
+children :: String -> Element -> [Element]
+children = filterChildrenName . matchQName
+
+name :: Element -> [Text]
+name = maybeToList . fmap T.pack . findAttrBy (matchQName "name")
+
+-- * Postgresql outout
+
+runMigrations :: Connection -> IO ()
+runMigrations conn = do
+  void $ execute_ conn "CREATE TABLE IF NOT EXISTS test_suite_runs (id SERIAL PRIMARY KEY, run_id VARCHAR, time TIMESTAMP, version VARCHAR, suite VARCHAR, failed_runs INT, successful_runs INT)"
+  void $ execute_ conn "CREATE TABLE IF NOT EXISTS test_case_runs (id SERIAL PRIMARY KEY, name VARCHAR, test_suite_run_id integer, failure_count integer, success_count integer)"
+  void $ execute_ conn "CREATE TABLE IF NOT EXISTS test_case_failures (id SERIAL PRIMARY KEY, test_case_run_id integer, failure_log text)"
+
+pushToPostgresql :: Options Unwrapped -> (MonoidalMap TestCase Report, Sum Int, Sum Int) -> IO ()
+pushToPostgresql opts (reports, failedRuns, successfulRuns) = do
+  let connInfo =
+        ConnectInfo
+          { connectHost = opts.postgresqlHost,
+            connectPort = opts.postgresqlPort,
+            connectUser = opts.postgresqlUser,
+            connectPassword = opts.postgresqlPassword,
+            connectDatabase = opts.postgresqlDatabase
+          }
+  currentTime <- getCurrentTime
+  bracket (connect connInfo) close $ \conn -> do
+    runMigrations conn
+    suiteRunId <-
+      extractId
+        =<< returning
+          conn
+          "INSERT INTO test_suite_runs (run_id, time, version, suite, failed_runs, successful_runs) VALUES (?,?,?,?,?,?) RETURNING id"
+          [(opts.runId, maybe currentTime zonedTimeToUTC opts.time, opts.codeVersion, opts.suiteName, getSum failedRuns, getSum successfulRuns)]
+    let saveTestCaseRun testCase report = do
+          testCaseRunId <-
+            extractId
+              =<< returning
+                conn
+                "INSERT INTO test_case_runs (name, test_suite_run_id, failure_count, success_count) VALUES (?,?,?,?) RETURNING id"
+                [(testCase, suiteRunId, report.failure, report.success)]
+          void $
+            executeMany conn "INSERT INTO test_case_failures (test_case_run_id, failure_log) VALUES (?,?)" $
+              zip (repeat testCaseRunId) report.failureDesc
+    void $ MonoidalMap.traverseWithKey saveTestCaseRun reports
+
+extractId :: HasCallStack => [Only Int] -> IO Int
+extractId [] = error $ "No ID returned by query"
+extractId (Only x : _) = pure x

tools/test-stats/README.md

@@ -0,0 +1 @@
+# Test stats

tools/test-stats/default.nix

@@ -0,0 +1,40 @@
+# WARNING: GENERATED FILE, DO NOT EDIT.
+# This file is generated by running hack/bin/generate-local-nix-packages.sh and
+# must be regenerated whenever local packages are added or removed, or
+# dependencies are added or removed.
+{ mkDerivation
+, base
+, bytestring
+, gitignoreSource
+, imports
+, lib
+, monoidal-containers
+, optparse-generic
+, postgresql-simple
+, prometheus-client
+, text
+, time
+, xml
+}:
+mkDerivation {
+  pname = "test-stats";
+  version = "0.1.0";
+  src = gitignoreSource ./.;
+  isLibrary = false;
+  isExecutable = true;
+  executableHaskellDepends = [
+    base
+    bytestring
+    imports
+    monoidal-containers
+    optparse-generic
+    postgresql-simple
+    prometheus-client
+    text
+    time
+    xml
+  ];
+  description = "Test run statistics";
+  license = lib.licenses.agpl3Only;
+  mainProgram = "test-stats";
+}

tools/test-stats/test-stats.cabal

@@ -0,0 +1,82 @@
+cabal-version: >=1.10
+name:          test-stats
+version:       0.1.0
+synopsis:      Test run statistics
+description:   Collect test run statistics
+category:      Tool
+author:        Wire Swiss GmbH
+maintainer:    Wire Swiss GmbH <backend@wire.com>
+license:       AGPL-3
+license-file:  LICENSE
+build-type:    Simple
+
+flag static
+  description: Enable static linking
+  default:     False
+
+executable test-stats
+  main-is:            Main.hs
+  build-depends:
+      base
+    , bytestring
+    , imports
+    , monoidal-containers
+    , optparse-generic
+    , postgresql-simple
+    , prometheus-client
+    , text
+    , time
+    , xml
+
+  default-extensions:
+    NoImplicitPrelude
+    AllowAmbiguousTypes
+    BangPatterns
+    ConstraintKinds
+    DataKinds
+    DefaultSignatures
+    DeriveFunctor
+    DeriveGeneric
+    DeriveLift
+    DeriveTraversable
+    DerivingStrategies
+    DerivingVia
+    DuplicateRecordFields
+    EmptyCase
+    FlexibleContexts
+    FlexibleInstances
+    FunctionalDependencies
+    GADTs
+    InstanceSigs
+    KindSignatures
+    LambdaCase
+    MultiParamTypeClasses
+    MultiWayIf
+    NamedFieldPuns
+    OverloadedRecordDot
+    OverloadedStrings
+    PackageImports
+    PatternSynonyms
+    PolyKinds
+    QuasiQuotes
+    RankNTypes
+    ScopedTypeVariables
+    StandaloneDeriving
+    TupleSections
+    TypeApplications
+    TypeFamilies
+    TypeFamilyDependencies
+    TypeOperators
+    UndecidableInstances
+    ViewPatterns
+
+  ghc-options:
+    -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+    -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
+    -threaded -rtsopts -with-rtsopts=-T -Wredundant-constraints
+    -Wunused-packages
+
+  if flag(static)
+    ld-options: -static
+
+  default-language:   GHC2021