graphql-engine/server/lib/dc-api/test/Test/Expectations.hs
Tom Harding a1c5ac46f6 Extract dc-api and its tests from graphql-engine.cabal
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6000
Co-authored-by: Daniel Chambers <1214352+daniel-chambers@users.noreply.github.com>
GitOrigin-RevId: d8f3cd0194191ab4c51a5a7d350cb2c3a0a5a7f3
2022-09-27 07:21:54 +00:00

100 lines
4.2 KiB
Haskell

module Test.Expectations
( jsonShouldBe,
rowsShouldBe,
)
where
import Control.Lens ((%~), (&))
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (ToJSON (..), Value)
import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff)
import Data.HashMap.Strict (HashMap)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Data.Yaml qualified as Yaml
import GHC.Stack (HasCallStack)
import Hasura.Backends.DataConnector.API (FieldName, FieldValue, deserializeAsRelationshipFieldValue, mkRelationshipFieldValue, qrRows)
import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleLayer (..), SGR (..), hSupportsANSIColor, setSGRCode)
import System.IO (stdout)
import Test.Hspec (Expectation, expectationFailure)
import Prelude
newtype YamlShow = YamlShow {unYamlShow :: Value}
deriving newtype (Eq)
instance Show YamlShow where
show = T.unpack . TE.decodeUtf8With TE.lenientDecode . Yaml.encode . unYamlShow
-- | Compares two JSON values for equality, but prints their diff upon failure
-- as formatted YAML, which is a much nicer way to visualise the difference in
-- expected vs actual.
jsonShouldBe :: (HasCallStack, ToJSON value) => value -> value -> Expectation
jsonShouldBe actual expected =
shouldBeWithLineDiff (YamlShow $ toJSON actual) (YamlShow $ toJSON expected)
-- | Compares two lists of response rows, but normalizes them first to remove
-- immaterial differences that show up when diffing in JSON/YAML
rowsShouldBe :: HasCallStack => [HashMap FieldName FieldValue] -> [HashMap FieldName FieldValue] -> Expectation
rowsShouldBe actual expected =
(normalize <$> actual) `jsonShouldBe` (normalize <$> expected)
-- | Normalizes a response row so that immaterial differences are removed.
--
-- Immaterial differences can show up because 'FieldValue's are not actually decoded
-- into Haskell types and are instead decoded as appropriate while traversing the Query
-- IR (see 'FieldType' Haddocks for more info).
-- This causes any JSON-based diff to show up immaterial differences even though two
-- 'FieldValue's are equal, because the JSON contains differences that are ignored
-- for equality purposes (eg the difference between a missing rows property and a
-- null one).
-- Normalization simply removes these differences by fully deserializing and then
-- reserializing the JSON. It can do this by making the assumption that there are no
-- custom scalar types that look like relationship field values (true for the Chinook
-- data set used by the agent tests).
normalize :: HashMap FieldName FieldValue -> HashMap FieldName FieldValue
normalize =
fmap
( \fieldValue ->
case deserializeAsRelationshipFieldValue fieldValue of
Left _ -> fieldValue
Right queryResponse ->
mkRelationshipFieldValue $
queryResponse & qrRows . traverse . traverse %~ normalize
)
shouldBeWithLineDiff :: (HasCallStack, Show value, Eq value) => value -> value -> Expectation
shouldBeWithLineDiff actual expected =
unless (actual == expected) $
expectationFailure =<< renderDiffError actual expected
renderDiffError :: (Show value, MonadIO m) => value -> value -> m String
renderDiffError actual expected = do
useColor <- liftIO $ hSupportsANSIColor stdout
pure $ renderDiffString useColor (show actual) (show expected)
renderDiffString :: Bool -> String -> String -> String
renderDiffString useColor actual expected =
unlines $ resetHspecErrorColor <$> explanation <> diffLines
where
resetHspecErrorColor line = colorCode Reset ++ line
explanation =
[ "━━━",
colorSpan Red "--- present, but not expected",
colorSpan Green "+++ expected, but not present",
"━━━"
]
diffLines = annotateDiffLine <$> getDiff (lines actual) (lines expected)
annotateDiffLine :: Diff String -> String
annotateDiffLine = \case
Both _ s -> " " ++ s
First s -> colorSpan Red $ "--- " ++ s
Second s -> colorSpan Green $ "+++ " ++ s
colorSpan c s = colorCode (SetColor Foreground Dull c) ++ s ++ colorCode Reset
colorCode sgr = if useColor then setSGRCode [sgr] else ""