Merge pull request #106 from quickstrom/json-reporter

Add JSON reporter
quickstrom · Jul 9, 2021 · 4c729a7 · 4c729a7
2 parents f15ce47 + 197403f
commit 4c729a7
Show file tree

Hide file tree

Showing 6 changed files with 294 additions and 239 deletions.
diff --git a/cli/app/Main.hs b/cli/app/Main.hs
@@ -31,6 +31,7 @@ import Quickstrom.CLI.Reporter (Reporter)
 import qualified Quickstrom.CLI.Reporter as Reporter
 import qualified Quickstrom.CLI.Reporter.Console as Reporter
 import qualified Quickstrom.CLI.Reporter.HTML as Reporter
+import qualified Quickstrom.CLI.Reporter.JSON as Reporter
 import qualified Quickstrom.CLI.Version as Quickstrom
 import qualified Quickstrom.LogLevel as Quickstrom
 import Quickstrom.Prelude hiding (option, try)
@@ -78,7 +79,8 @@ data CheckOptions = CheckOptions
     webDriverPort :: Int,
     webDriverPath :: FilePath,
     reporters :: [Text],
-    htmlReportDirectory :: FilePath
+    htmlReportDirectory :: FilePath,
+    jsonReportDirectory :: FilePath
   }
 
 data LintOptions = LintOptions
@@ -209,6 +211,13 @@ checkOptionsParser =
           <> value "html-report"
           <> help "Output directory of generated HTML report"
       )
+    <*> option
+      str
+      ( metavar "DIR"
+          <> long "json-report-directory"
+          <> value "json-report"
+          <> help "Output directory of generated JSON report"
+      )
 
 lintOptionsParser :: Parser LintOptions
 lintOptionsParser =
@@ -353,7 +362,8 @@ main = do
 availableReporters :: (MonadIO m, MonadReader Quickstrom.LogLevel m) => [(Text, CheckOptions -> Reporter m)]
 availableReporters =
   [ ("console", const Reporter.consoleReporter),
-    ("html", \opts -> Reporter.htmlReporter (htmlReportDirectory opts))
+    ("html", \opts -> Reporter.htmlReporter (htmlReportDirectory opts)),
+    ("json", \opts -> Reporter.jsonReporter (jsonReportDirectory opts))
   ]
 
 reporterNames :: [Text]

diff --git a/cli/quickstrom-cli.cabal b/cli/quickstrom-cli.cabal
@@ -41,6 +41,7 @@ library
                     , Quickstrom.CLI.Reporter
                     , Quickstrom.CLI.Reporter.Console
                     , Quickstrom.CLI.Reporter.HTML
+                    , Quickstrom.CLI.Reporter.JSON
                     , Quickstrom.CLI.Version
                     , Paths_quickstrom_cli
   hs-source-dirs:     src
@@ -70,7 +71,7 @@ test-suite quickstrom-cli-test
   type:               exitcode-stdio-1.0
   main-is:            Main.hs
   hs-source-dirs:     test
-  other-modules:      Quickstrom.CLI.Reporter.HTMLTest
+  other-modules:      Quickstrom.CLI.Reporter.JSONTest
   build-depends:      base
                     , hedgehog
                     , QuickCheck

diff --git a/cli/src/Quickstrom/CLI/Reporter/HTML.hs b/cli/src/Quickstrom/CLI/Reporter/HTML.hs
@@ -1,273 +1,48 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Quickstrom.CLI.Reporter.HTML where
 
-import qualified Codec.Picture as Image
-import Control.Lens hiding (Identical)
-import qualified Data.Aeson as JSON
 import qualified Data.ByteString as BS
-import "base64" Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Lazy as LBS
 import Data.Generics.Labels ()
-import Data.Generics.Sum (_Ctor)
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (fromJust)
-import qualified Data.Text.Encoding as Text
-import Data.Text.Prettyprint.Doc (pretty, (<+>))
-import qualified Data.Time.Clock as Time
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import qualified Quickstrom.Action as Quickstrom
 import qualified Quickstrom.CLI.Reporter as Quickstrom
-import qualified Quickstrom.Element as Quickstrom
+import qualified Quickstrom.CLI.Reporter.JSON as Quickstrom
 import qualified Quickstrom.LogLevel as Quickstrom
 import Quickstrom.Prelude hiding (State, to, uncons)
-import qualified Quickstrom.Run as Quickstrom
-import qualified Quickstrom.Trace as Quickstrom
 import qualified System.Directory as Directory
 import System.Environment (getEnv)
 import System.FilePath ((</>))
 
-data Report = Report
-  { generatedAt :: Time.UTCTime,
-    result :: Result
-  }
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data Result
-  = Passed {passedTests :: Vector Test}
-  | Failed
-      { numShrinks :: Int,
-        reason :: Maybe Text,
-        passedTests :: Vector Test,
-        failedTest :: Test
-      }
-  | Errored {error :: Text, tests :: Int}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data Test = Test {transitions :: Transitions}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data Transition screenshot = Transition
-  { actionSequence :: Maybe (NonEmpty (Quickstrom.Action ActionSubject)),
-    states :: States screenshot,
-    stutter :: Bool
-  }
-  deriving (Eq, Show, Generic, JSON.ToJSON, Functor, Foldable, Traversable)
-
-type Transitions = Vector (Transition FileScreenshot)
-
-data ActionSubject = ActionSubject {selected :: Quickstrom.Selected, element :: ActionElement}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data States screenshot = States {from :: State screenshot, to :: State screenshot}
-  deriving (Eq, Show, Generic, JSON.ToJSON, Functor, Foldable, Traversable)
-
-data State screenshot = State {screenshot :: Maybe screenshot, queries :: Vector Query}
-  deriving (Eq, Show, Generic, JSON.ToJSON, Functor, Foldable, Traversable)
-
-data Base64Screenshot = Base64Screenshot {encoded :: Text, width :: Int, height :: Int}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data FileScreenshot = FileScreenshot {url :: FilePath, width :: Int, height :: Int}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data Query = Query {selector :: Text, elements :: Vector QueriedElement}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data QueriedElement = QueriedElement {id :: Text, position :: Maybe Quickstrom.Position, state :: Vector ElementStateValue}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data ActionElement = ActionElement {id :: Text, position :: Maybe Quickstrom.Position}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data ElementStateValue = ElementStateValue {elementState :: Quickstrom.ElementState, value :: JSON.Value, diff :: Diff}
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-data Diff = Identical | Modified | Removed | Added
-  deriving (Eq, Show, Generic, JSON.ToJSON)
-
-type ElementStateDiffs = HashMap (Quickstrom.Element, Quickstrom.ElementState) Diff
-
-elementStateDiffs :: Quickstrom.ObservedState -> Quickstrom.ObservedState -> ElementStateDiffs
-elementStateDiffs s1 s2 =
-  let vs1 = fromObservedState s1
-      vs2 = fromObservedState s2
-      allKeys = HashMap.keys (HashMap.union vs1 vs2)
-   in HashMap.fromList
-        ( map
-            ( \k ->
-                case (HashMap.lookup k vs1, HashMap.lookup k vs2) of
-                  (Just v1, Just v2)
-                    | v1 == v2 -> (k, Identical)
-                    | otherwise -> (k, Modified)
-                  (Nothing, Just _) -> (k, Added)
-                  (Just _, Nothing) -> (k, Removed)
-                  (Nothing, Nothing) -> (k, Identical) -- absurd case
-            )
-            allKeys
-        )
-  where
-    fromObservedState :: Quickstrom.ObservedState -> HashMap (Quickstrom.Element, Quickstrom.ElementState) JSON.Value
-    fromObservedState s = foldMap fromElement (s ^.. #elementStates . _Wrapped' . folded . folded)
-    fromElement :: Quickstrom.ObservedElementState -> HashMap (Quickstrom.Element, Quickstrom.ElementState) JSON.Value
-    fromElement oes =
-      let element' = oes ^. #element
-       in HashMap.fromList [((element', es), value) | (es, value) <- HashMap.toList (oes ^. #elementState)]
-
-data HTMLReporterException = HTMLReporterException Text
+newtype HTMLReporterException = HTMLReporterException Text
   deriving (Show, Eq)
 
 instance Exception HTMLReporterException
 
 htmlReporter :: (MonadReader Quickstrom.LogLevel m, MonadIO m) => FilePath -> Quickstrom.Reporter m
 htmlReporter reportDir = Quickstrom.Reporter {preCheck, report}
   where
-    preCheck _webDriverOpts _checkOpts = do
-      alreadyExists <- liftIO (Directory.doesPathExist reportDir)
-      if alreadyExists
-        then pure (Quickstrom.CannotBeInvoked ("File or directory already exists, refusing to overwrite:" <+> pretty reportDir))
-        else pure Quickstrom.OK
-
-    report _webDriverOpts checkOpts result = do
-      now <- liftIO Time.getCurrentTime
-
-      whenM (liftIO (Directory.doesPathExist reportDir)) $
-        throwIO (HTMLReporterException "File or directory already exists, refusing to overwrite!")
-
-      liftIO (Directory.createDirectoryIfMissing True reportDir)
-      reportResult <- case result of
-        Quickstrom.CheckFailure {Quickstrom.passedTests, Quickstrom.failedTest} -> do
-          passedTests' <- traverse (traceToTest reportDir . view #trace) passedTests
-          failedTest' <- traceToTest reportDir (failedTest ^. #trace)
-          pure
-            Failed
-              { numShrinks = Quickstrom.numShrinks failedTest,
-                reason = Quickstrom.reason failedTest,
-                passedTests = passedTests',
-                failedTest = failedTest'
-              }
-        Quickstrom.CheckError {Quickstrom.checkError} -> do
-          pure Errored {error = checkError, tests = Quickstrom.checkTests checkOpts}
-        Quickstrom.CheckSuccess {passedTests} -> do
-          passedTests' <- traverse (traceToTest reportDir . view #trace) passedTests
-          pure Passed {passedTests = passedTests'}
-      let reportFile = reportDir </> "report.jsonp.js"
-          json = JSON.encode (Report now reportResult)
+    jsonReporter = Quickstrom.jsonReporter reportDir
+    preCheck = Quickstrom.preCheck jsonReporter
+    report webDriverOpts checkOpts result = do
+      Quickstrom.report jsonReporter webDriverOpts checkOpts result
       liftIO $ do
-        BS.writeFile reportFile (Text.encodeUtf8 "window.report = " <> LBS.toStrict json)
+        json <- LBS.readFile (reportDir </> "report.json")
+        LBS.writeFile (reportDir </> "report.jsonp.js") ("window.report = " <> json)
         getAssets >>= \case
           Just assets | not (null assets) ->
             for_ assets $ \(name, contents) ->
               BS.writeFile (reportDir </> name) contents
           _ -> throwIO (HTMLReporterException "HTML report assets not found.")
 
-encodeScreenshot :: ByteString -> Either Text Base64Screenshot
-encodeScreenshot b =
-  let b64 = Base64.encodeBase64 b
-   in bimap
-        toS
-        (Image.dynamicMap (\i -> Base64Screenshot b64 (Image.imageWidth i) (Image.imageHeight i)))
-        (Image.decodePng b)
-
-traceToTransitions :: Quickstrom.Trace Quickstrom.TraceElementEffect -> Vector (Transition ByteString)
-traceToTransitions (Quickstrom.Trace es) = go (Vector.fromList es) mempty
-  where
-    go :: Vector (Quickstrom.TraceElement Quickstrom.TraceElementEffect) -> Vector (Transition ByteString) -> Vector (Transition ByteString)
-    go trace' acc =
-      case actionTransition trace' <|> trailingStateTransition trace' of
-        Just (transition, trace'') -> go trace'' (acc <> pure transition)
-        Nothing -> acc
-
-    actionTransition :: Vector (Quickstrom.TraceElement Quickstrom.TraceElementEffect) -> Maybe (Transition ByteString, Vector (Quickstrom.TraceElement Quickstrom.TraceElementEffect))
-    actionTransition t = flip evalStateT t $ do
-      (_, s1) <- pop (_Ctor @"TraceState")
-      actionSeq <- pop (_Ctor @"TraceAction" . _2)
-      let a = map (map toActionSubject) (Quickstrom.actionSequenceToNonEmpty actionSeq)
-      (ann2, s2) <- pop (_Ctor @"TraceState")
-      let diffs = elementStateDiffs s1 s2
-      pure (Transition (Just a) (States (toState diffs s1) (toState diffs s2)) (ann2 == Quickstrom.Stutter), Vector.drop 2 t)
-
-    trailingStateTransition :: Vector (Quickstrom.TraceElement Quickstrom.TraceElementEffect) -> Maybe (Transition ByteString, Vector (Quickstrom.TraceElement Quickstrom.TraceElementEffect))
-    trailingStateTransition t = flip evalStateT t $ do
-      (_, s1) <- pop (_Ctor @"TraceState")
-      (ann2, s2) <- pop (_Ctor @"TraceState")
-      let diffs = elementStateDiffs s1 s2
-      pure (Transition Nothing (States (toState diffs s1) (toState diffs s2)) (ann2 == Quickstrom.Stutter), Vector.tail t)
-
-    toState :: ElementStateDiffs -> Quickstrom.ObservedState -> State ByteString
-    toState diffs s = State (s ^. #screenshot) (toQueries diffs (s ^. #elementStates))
-
-    toQueries :: ElementStateDiffs -> Quickstrom.ObservedElementStates -> Vector Query
-    toQueries diffs (Quickstrom.ObservedElementStates os) = Vector.fromList (map (toQuery diffs) (HashMap.toList os))
-
-    toQuery :: ElementStateDiffs -> (Quickstrom.Selector, [Quickstrom.ObservedElementState]) -> Query
-    toQuery diffs (Quickstrom.Selector sel, elements') =
-      Query {selector = sel, elements = Vector.fromList (map (toQueriedElement diffs) elements')}
-
-    toQueriedElement :: ElementStateDiffs -> Quickstrom.ObservedElementState -> QueriedElement
-    toQueriedElement diffs o =
-      QueriedElement
-        (o ^. #element . #ref)
-        (o ^. #position)
-        (Vector.fromList (map (toElementStateValue diffs (o ^. #element)) (HashMap.toList (o ^. #elementState))))
-
-    toElementStateValue :: ElementStateDiffs -> Quickstrom.Element -> (Quickstrom.ElementState, JSON.Value) -> ElementStateValue
-    toElementStateValue diffs element' (state', value) =
-      ElementStateValue state' value (fromJust (HashMap.lookup (element', state') diffs))
-
-    pop ctor = do
-      t <- get
-      case uncons t of
-        Just (a, t') ->
-          case a ^? ctor of
-            Just x -> put t' >> pure x
-            Nothing -> mzero
-        Nothing -> mzero
-
-toActionSubject :: Quickstrom.ActionSubject -> ActionSubject
-toActionSubject as =
-  ActionSubject
-    { selected = as ^. #selected,
-      element = ActionElement {id = as ^. #element . #ref, position = as ^. #position}
-    }
-
-data ScreenshotFileException = ScreenshotFileException Text
-  deriving (Show)
-
-instance Exception ScreenshotFileException
-
-writeScreenshotFile :: MonadIO m => FilePath -> ByteString -> m FileScreenshot
-writeScreenshotFile reportDir s = do
-  let fileName = "screenshot-" <> show (hash s) <> ".png"
-  liftIO (BS.writeFile (reportDir </> fileName) s)
-  either
-    (throwIO . ScreenshotFileException . toS)
-    (pure . Image.dynamicMap (\i -> FileScreenshot fileName (Image.imageWidth i) (Image.imageHeight i)))
-    (Image.decodePng s)
-
-traceToTest :: MonadIO m => FilePath -> Quickstrom.Trace Quickstrom.TraceElementEffect -> m Test
-traceToTest reportDir trace' =
-  traceToTransitions trace'
-    & traverse . traverse %%~ writeScreenshotFile reportDir
-    & fmap Test
-
 getAssets :: MonadIO m => m (Maybe [(FilePath, ByteString)])
 getAssets = liftIO $ do
   path <- getEnv "QUICKSTROM_HTML_REPORT_DIR"