From cfc7abb19bbe1c22db5f68b0cbab43ebe3f353b3 Mon Sep 17 00:00:00 2001 From: Stevan Andjelkovic Date: Wed, 27 Nov 2024 12:12:03 +0100 Subject: [PATCH] feat: add json logging and json result output --- spex.cabal | 1 + src/Spex/CommandLine/Option.hs | 10 ++ src/Spex/LibMain.hs | 12 +++ src/Spex/Logger.hs | 93 +++++++++++++++---- src/Spex/Monad.hs | 11 ++- src/Spex/PrettyPrinter.hs | 7 +- src/Spex/Verifier.hs | 2 +- src/Spex/Verifier/Result.hs | 8 ++ ...lts.spex_--seed_8800299288541500217.golden | 4 +- 9 files changed, 120 insertions(+), 28 deletions(-) diff --git a/spex.cabal b/spex.cabal index ba8f2b8..fd4d46e 100644 --- a/spex.cabal +++ b/spex.cabal @@ -87,6 +87,7 @@ library , prettyprinter , random , template-haskell + , time , utf8-string , vector , wai diff --git a/src/Spex/CommandLine/Option.hs b/src/Spex/CommandLine/Option.hs index 785d1ab..a003e64 100644 --- a/src/Spex/CommandLine/Option.hs +++ b/src/Spex/CommandLine/Option.hs @@ -23,6 +23,7 @@ data Options = Options , logging :: Logging , logFile :: Maybe FilePath , nonInteractive :: Bool + , jsonLogging :: Bool } data Logging = Quiet Bool | Verbose Bool | Trace Bool @@ -44,6 +45,7 @@ data VerifyOptions = VerifyOptions , numTests :: Word , seed :: Maybe Int , noShrinking :: Bool + , jsonResult :: Bool , specFilePath :: FilePath } @@ -168,6 +170,10 @@ parser = ( long "non-interactive" <> help "Disable fancy logging" ) + <*> switch + ( long "json-logging" + <> help "Enable logging in JSON format" + ) where verify :: Parser VerifyOptions verify = @@ -217,6 +223,10 @@ parser = ( long "no-shrinking" <> help "Disable shrinking" ) + <*> switch + ( long "json-result" + <> help "Output the result in JSON format" + ) <*> specFile specFile :: Parser FilePath diff --git a/src/Spex/LibMain.hs b/src/Spex/LibMain.hs index db24f87..f7930d2 100644 --- a/src/Spex/LibMain.hs +++ b/src/Spex/LibMain.hs @@ -3,6 +3,7 @@ module Spex.LibMain where import Control.Exception +import Data.Aeson qualified as Json import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Text qualified as Text @@ -48,6 +49,7 @@ mainWith opts testing = do -- During testing, redirect the printing of the result to the logs, -- so it's easier to test the complete output using one golden test. | testing -> (verifyAppLog vopts, vopts.specFilePath) + | vopts.jsonResult -> (verifyAppJson vopts, vopts.specFilePath) | otherwise -> (verifyAppStdout vopts, vopts.specFilePath) Format fopts -> (formatApp fopts, fopts.specFilePath) Mock mopts -> (mockApp mopts, mopts.specFilePath) @@ -77,6 +79,16 @@ verifyAppLog opts = opts (\spec result seed -> info_ (displayResult spec result seed)) +verifyAppJson :: VerifyOptions -> App () +verifyAppJson opts = + verifyApp + opts + ( \_spec result seed -> + liftIO $ + LBS.putStr + (Json.encode (ResultJson result.failingTests result.coverage seed)) + ) + verifyApp :: VerifyOptions -> (Spec -> Result -> Int -> App ()) -> App () verifyApp opts handleResult = do diff --git a/src/Spex/Logger.hs b/src/Spex/Logger.hs index e1203f2..745c204 100644 --- a/src/Spex/Logger.hs +++ b/src/Spex/Logger.hs @@ -3,15 +3,25 @@ module Spex.Logger (module Spex.Logger) where import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time.Clock +import Data.Time.Format.ISO8601 import Spex.CommandLine.Ansi ------------------------------------------------------------------------ +data LoggerKind = PlainLogger | JsonLogger + +data InfoKind = PlainInfo | NormalInfo | DoneInfo + +data DebugKind = PlainDebug | NormalDebug + data Logger = Logger - { loggerInfo :: Bool -> Text -> IO () + { loggerKind :: LoggerKind + , loggerInfo :: InfoKind -> Text -> IO () , loggerError :: Text -> IO () - , loggerDebug :: Text -> IO () + , loggerDebug :: DebugKind -> Text -> IO () , loggerTrace :: Text -> IO () , loggerFlush :: IO () , loggerClose :: IO () @@ -21,13 +31,14 @@ data Logger = Logger noAnsiLogger :: (Text -> IO ()) -> IO () -> IO () -> Logger noAnsiLogger printer flusher closer = Logger - { loggerInfo = \b -> - if b - then printer . ("✓ " <>) - else printer . ("i " <>) + { loggerKind = PlainLogger + , loggerInfo = \k -> case k of + PlainInfo -> printer + NormalInfo -> printer . ("i " <>) + DoneInfo -> printer . ("✓ " <>) , loggerError = printer . ("Error: " <>) - , loggerDebug = \_s -> return () - , loggerTrace = \_s -> return () + , loggerDebug = \_k _msg -> return () + , loggerTrace = \_msg -> return () , loggerFlush = flusher , loggerClose = closer } @@ -35,25 +46,69 @@ noAnsiLogger printer flusher closer = ansiLogger :: (Text -> IO ()) -> IO () -> IO () -> Logger ansiLogger printer flusher closer = Logger - { loggerInfo = \b -> - if b - then printer . (green "✓ " <>) - else printer . (cyan "i " <>) + { loggerKind = PlainLogger + , loggerInfo = \k -> case k of + PlainInfo -> printer + NormalInfo -> printer . (cyan "i " <>) + DoneInfo -> printer . (green "✓ " <>) , loggerError = printer . ((boldRed "Error" <> ": ") <>) - , loggerDebug = \_s -> return () - , loggerTrace = \_s -> return () + , loggerDebug = \_k _msg -> return () + , loggerTrace = \_msg -> return () + , loggerFlush = flusher + , loggerClose = closer + } + +jsonLogger :: (Text -> IO ()) -> IO () -> IO () -> Logger +jsonLogger printer flusher closer = + Logger + { loggerKind = JsonLogger + , loggerInfo = \_k -> logJson printer "info" + , loggerError = logJson printer "error" + , loggerDebug = \_k _msg -> return () + , loggerTrace = \_msg -> return () , loggerFlush = flusher , loggerClose = closer } +logJson :: (Text -> IO ()) -> Text -> Text -> IO () +logJson printer level msg = do + if Text.null (Text.strip msg) + then return () + else do + t <- getCurrentTime + printer $ + Text.concat + [ "{\"timestamp\":\"" + , Text.pack (iso8601Show t) + , "\"," + , "\"level\":\"" + , level + , "\"," + , "\"message\":\"" + , Text.strip msg + , "\"}" + ] + quietLogger :: Logger -> Logger quietLogger l = l {loggerInfo = \_ _ -> return ()} verboseLogger :: (Text -> IO ()) -> Logger -> Logger -verboseLogger printer l = l {loggerDebug = printer . (faint "d " <>)} +verboseLogger printer l = case l.loggerKind of + PlainLogger -> + l + { loggerDebug = \k -> case k of + PlainDebug -> printer + NormalDebug -> printer . (faint "d " <>) + } + JsonLogger -> l {loggerDebug = \_k -> logJson printer "debug"} traceLogger :: (Text -> IO ()) -> Logger -> Logger -traceLogger printer l = - (verboseLogger printer l) - { loggerTrace = printer . (faint "t " <>) - } +traceLogger printer l = case l.loggerKind of + PlainLogger -> + (verboseLogger printer l) + { loggerTrace = printer . (faint "t " <>) + } + JsonLogger -> + (verboseLogger printer l) + { loggerTrace = logJson printer "trace" + } diff --git a/src/Spex/Monad.hs b/src/Spex/Monad.hs index 57033c2..fad36de 100644 --- a/src/Spex/Monad.hs +++ b/src/Spex/Monad.hs @@ -63,6 +63,7 @@ newAppEnv opts = do return (Text.hPutStrLn h, hFlush h, hClose h) let logger' + | opts.jsonLogging = jsonLogger printer flusher closer | not hasAnsi || opts.nonInteractive = noAnsiLogger printer flusher closer | otherwise = ansiLogger printer flusher closer @@ -82,12 +83,12 @@ newAppEnv opts = do info :: Text -> App () info t = do l <- asks logger - liftIO (l.loggerInfo False t) + liftIO (l.loggerInfo NormalInfo t) info_ :: Text -> App () info_ t = do l <- asks logger - liftIO (l.loggerInfo False ("\b\b " <> t)) + liftIO (l.loggerInfo PlainInfo t) logError :: Text -> App () logError t = do @@ -97,12 +98,12 @@ logError t = do debug :: Text -> App () debug t = do l <- asks logger - liftIO (l.loggerDebug t) + liftIO (l.loggerDebug NormalDebug t) debug_ :: Text -> App () debug_ t = do l <- asks logger - liftIO (l.loggerDebug ("\b\b " <> t)) + liftIO (l.loggerDebug PlainDebug t) trace :: Text -> App () trace t = do @@ -112,7 +113,7 @@ trace t = do done :: Text -> App () done t = do l <- asks logger - liftIO (l.loggerInfo True t) + liftIO (l.loggerInfo DoneInfo t) flushLogger :: App () flushLogger = do diff --git a/src/Spex/PrettyPrinter.hs b/src/Spex/PrettyPrinter.hs index 436719f..122fceb 100644 --- a/src/Spex/PrettyPrinter.hs +++ b/src/Spex/PrettyPrinter.hs @@ -10,6 +10,8 @@ import Data.Map qualified as Map import Data.String import Data.Text (Text) import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector import Prettyprinter import Prettyprinter.Render.Text import System.IO @@ -116,6 +118,9 @@ prettyRecord p = prettyFields :: (a -> Doc x) -> Map Field a -> [Doc x] prettyFields p = map (\(Field f, x) -> pretty f <+> p x) . Map.toList +prettyArray :: (a -> Doc x) -> Vector a -> Doc x +prettyArray p = list . map p . Vector.toList + prettyBS :: (Coercible a ByteString) => a -> Doc x prettyBS = fromString . BS8.unpack . coerce @@ -129,7 +134,7 @@ prettyValue UnitV = "()" prettyValue (BoolV b) = viaShow b prettyValue (IntV i) = viaShow i prettyValue (StringV t) = pretty t -prettyValue (ArrayV vs) = undefined +prettyValue (ArrayV vs) = prettyArray prettyValue vs prettyValue (RecordV fvs) = prettyRecord (\val -> "=" <+> prettyValue val) fvs displayValue :: Value -> Text diff --git a/src/Spex/Verifier.hs b/src/Spex/Verifier.hs index e70bcf6..9fdbc7a 100644 --- a/src/Spex/Verifier.hs +++ b/src/Spex/Verifier.hs @@ -90,7 +90,7 @@ verifyLoop opts spec deployment client = go -- If we've seen a failure already, then don't add it to the test -- cases. if failure0 `elem` map failure res.failingTests - then return (res {coverage = cov'}) + then return (res {coverage = cov'} :: Result) else do test <- counterExample diff --git a/src/Spex/Verifier/Result.hs b/src/Spex/Verifier/Result.hs index da39c05..57069f0 100644 --- a/src/Spex/Verifier/Result.hs +++ b/src/Spex/Verifier/Result.hs @@ -17,6 +17,14 @@ import Spex.Verifier.Coverage ------------------------------------------------------------------------ +data ResultJson = ResultJson + { failingTests :: [FailingTest] + , coverage :: Coverage + , seed :: Int + } + deriving stock (Generic) + deriving anyclass (ToJSON) + data Result = Result { failingTests :: [FailingTest] -- XXX: Set? , coverage :: Coverage diff --git a/test/golden/verify_example-petstore-modal-faults.spex_--seed_8800299288541500217.golden b/test/golden/verify_example-petstore-modal-faults.spex_--seed_8800299288541500217.golden index 0008530..c7bcf27 100644 --- a/test/golden/verify_example-petstore-modal-faults.spex_--seed_8800299288541500217.golden +++ b/test/golden/verify_example-petstore-modal-faults.spex_--seed_8800299288541500217.golden @@ -1,4 +1,4 @@ -i  + i Verifying the deployment: http://localhost:8080 against the specification: example/petstore-modal-faults.spex @@ -11,7 +11,7 @@ i Waiting for health check to pass... i Starting to run tests... ✓ Done testing! -i  + Found 2 intereresting test cases: 1. getBadPet : GET /pet/badJson/{petId = 0} -> Pet