{-# LANGUAGE TypeApplications #-}

module Test.Cardano.CLI.Aeson
  ( assertEqualModuloDesc
  , assertHasKeys
  , assertHasMappings
  , redactJsonFieldsInFile
  )
where

import           Control.Monad (forM_)
import           Control.Monad.IO.Class
import           Data.Aeson hiding (pairs)
import           Data.Aeson.Encode.Pretty (encodePretty)
import           Data.Aeson.Key
import qualified Data.Aeson.Key as Aeson
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as Vector
import           GHC.Stack (HasCallStack)
import qualified GHC.Stack as GHC

import           Hedgehog
import qualified Hedgehog as H
import qualified Hedgehog.Extras as H

{- HLINT ignore "Use uncurry" -}

-- | @assertHasKeys keys path@ succeeds if @path@ is a file containing a JSON object
-- whose keys is a superset of @keys@.
--
-- For example. if @path@ contains @"{ "a":0, "b":1.0, "c": "foo"}"@,
-- @hasKeys ["b", "a"] path@ succeeds.
assertHasKeys
  :: ()
  => HasCallStack
  => MonadTest m
  => MonadIO m
  => [Text]
  -> FilePath
  -> m ()
assertHasKeys :: forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
[Text] -> FilePath -> m ()
assertHasKeys [Text]
keys FilePath
jsonFile = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ByteString
content <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LBS.readFile FilePath
jsonFile
  case ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
content of
    Maybe Object
Nothing -> do
      FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot read JSON file: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
jsonFile
      m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure
    Just Object
obj -> do
      [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
keys ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
key -> FilePath -> Object -> Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadTest m) =>
FilePath -> Object -> Text -> m ()
assertHasKey FilePath
jsonFile Object
obj Text
key

-- | @assertHasKey file obj key@ checks that @obj@ has @key@ as a top-level key.
-- @file@ is only used for logging in case of failure: it is assumed to be
-- the path from which @obj@ was loaded.
--
-- Having this functions allows for good feedback in case of a test failure.
assertHasKey
  :: ()
  => HasCallStack
  => MonadTest m
  => FilePath
  -> Object
  -> Text
  -> m ()
assertHasKey :: forall (m :: * -> *).
(HasCallStack, MonadTest m) =>
FilePath -> Object -> Text -> m ()
assertHasKey FilePath
file Object
obj Text
key = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Aeson.KeyMap.lookup (Text -> Key
Aeson.fromText Text
key) Object
obj of
    Maybe Value
Nothing -> do
      FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"JSON file at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is missing key: \"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
key FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
      m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure
    Just Value
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
H.success

-- | @assertHasMappings pairs path@ succeeds if @path@ is a file containing a JSON object
-- whose mappings is a superset of @pairs@.
--
-- For example, if @path@ contains @"{ "a":"bar", "b":"buzz", "c":"foo"}"@,
-- @assertHasMappings "[("b", "buzz"), ("a", "bar")] path@ succeeds.
assertHasMappings
  :: ()
  => HasCallStack
  => MonadTest m
  => MonadIO m
  => [(Text, Text)]
  -> FilePath
  -> m ()
assertHasMappings :: forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
[(Text, Text)] -> FilePath -> m ()
assertHasMappings [(Text, Text)]
pairs FilePath
jsonFile = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ByteString
content <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LBS.readFile FilePath
jsonFile
  case ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
content of
    Maybe Object
Nothing -> do
      FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot read JSON file: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
jsonFile
      m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure
    Just Object
obj -> do
      [(Text, Text)] -> ((Text, Text) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Text)]
pairs (((Text, Text) -> m ()) -> m ()) -> ((Text, Text) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Text
key, Text
value) -> FilePath -> Object -> Text -> Text -> m ()
forall (m :: * -> *).
(HasCallStack, MonadTest m) =>
FilePath -> Object -> Text -> Text -> m ()
assertHasMapping FilePath
jsonFile Object
obj Text
key Text
value

-- | @assertHasMapping file obj key value@ checks that @obj@ has the @key->value@
-- at its top-level. @file@ is only used for logging in case of failure: it is assumed to be
-- the path from which @obj@ was loaded.
--
-- Having this functions allows for good feedback in case of a test failure.
assertHasMapping
  :: ()
  => HasCallStack
  => MonadTest m
  => FilePath
  -> Object
  -> Text
  -> Text
  -> m ()
assertHasMapping :: forall (m :: * -> *).
(HasCallStack, MonadTest m) =>
FilePath -> Object -> Text -> Text -> m ()
assertHasMapping FilePath
file Object
obj Text
key Text
value = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Aeson.KeyMap.lookup (Text -> Key
Aeson.fromText Text
key) Object
obj of
    Maybe Value
Nothing -> do
      FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"JSON file at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is missing key: \"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
key FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
      m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure
    Just Value
inThere ->
      case Value
inThere of
        String Text
textInThere | Text
value Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
textInThere -> m ()
forall (m :: * -> *). MonadTest m => m ()
H.success
        String Text
textInThere -> do
          FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$
            FilePath
"JSON file at "
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" has the mapping \""
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
key
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\"->\""
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
textInThere
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
          FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"whereas it was expected to be \"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
key FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\"->\"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
value FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
          m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure
        Object Object
_ -> FilePath -> m ()
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"object"
        Array Array
_ -> FilePath -> m ()
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"array"
        Number Scientific
_ -> FilePath -> m ()
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"number"
        Bool Bool
_ -> FilePath -> m ()
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"bool"
        Value
Null -> FilePath -> m ()
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"null"
 where
  failWrongType :: FilePath -> m b
failWrongType FilePath
got = do
    FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"JSON file at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" has wrong type for key: \"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
key FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
    FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Expected string but got: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
got
    m b
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure

-- | @assertEqualModuloDesc file1 file2@ loads @file1@ and @file2@ from disk,
-- then it strips the field @description@ from the loaded content, and finally compare
-- the two values. The values must be equal, otherwise the test is failed.
--
-- Required, because command @"key" "verification-key"@ generates keys without descriptions.
-- Note that it would be better to write descriptions, see:
-- https://github.com/IntersectMBO/cardano-cli/issues/429#issuecomment-2003880575
assertEqualModuloDesc
  :: ()
  => (HasCallStack, MonadIO m, MonadTest m)
  => FilePath
  -- ^ The file of the first generated verification key
  -> FilePath
  -- ^ The file of the second generated verification key, i.e. the one
  --   generated by calling "key verification-key"
  -> m ()
assertEqualModuloDesc :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> FilePath -> m ()
assertEqualModuloDesc FilePath
file1 FilePath
file2 = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Value
value1 <- forall a (m :: * -> *).
(MonadTest m, MonadIO m, FromJSON a, HasCallStack) =>
FilePath -> m a
H.readJsonFileOk @Value FilePath
file1
  Value
value1' <- Value -> m Value
forall (m :: * -> *).
(HasCallStack, MonadTest m) =>
Value -> m Value
removeDescription Value
value1

  Value
value2 <- forall a (m :: * -> *).
(MonadTest m, MonadIO m, FromJSON a, HasCallStack) =>
FilePath -> m a
H.readJsonFileOk @Value FilePath
file2
  Value
value2' <- Value -> m Value
forall (m :: * -> *).
(HasCallStack, MonadTest m) =>
Value -> m Value
removeDescription Value
value2

  Value
value1' Value -> Value -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
H.=== Value
value2'

-- | Removes the @description@ field from a JSON object.
removeDescription
  :: ()
  => (HasCallStack, MonadTest m)
  => Value
  -> m Value
removeDescription :: forall (m :: * -> *).
(HasCallStack, MonadTest m) =>
Value -> m Value
removeDescription Value
v =
  case Value
v of
    Object Object
inner ->
      Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
Aeson.KeyMap.delete (Text -> Key
Aeson.fromText Text
"description") Object
inner
    Array Array
_ -> FilePath -> m Value
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"array"
    Number Scientific
_ -> FilePath -> m Value
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"number"
    Bool Bool
_ -> FilePath -> m Value
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"bool"
    String Text
_ -> FilePath -> m Value
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"string"
    Value
Null -> FilePath -> m Value
forall {m :: * -> *} {b}. MonadTest m => FilePath -> m b
failWrongType FilePath
"null"
 where
  failWrongType :: FilePath -> m b
failWrongType FilePath
got = do
    FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Expected object but got: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
got
    m b
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure

-- | @redactJsonStringFieldInFile [(k0, v0), (k1, v1), ..] sourceFilePath targetFilePath@ reads the JSON at @sourceFilePath@, and then
-- replaces the value associated to @k0@ by @v0@, replaces the value associated to @k1@ by @v1@, etc.
-- Then the obtained JSON is written to @targetFilePath@. This replacement is done recursively
-- so @k0@, @k1@, etc. can appear at any depth within the JSON.
redactJsonFieldsInFile
  :: ()
  => MonadTest m
  => MonadIO m
  => HasCallStack
  => Map.Map Text Text
  -- ^ Map from key name, to the new (String) value to attach to this key
  -> FilePath
  -> FilePath
  -> m ()
redactJsonFieldsInFile :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
Map Text Text -> FilePath -> FilePath -> m ()
redactJsonFieldsInFile Map Text Text
changes FilePath
sourceFilePath FilePath
targetFilePath = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ByteString
contents <- IO ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LBS.readFile FilePath
sourceFilePath
  case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
contents :: Either String Value of
    Left FilePath
err -> do
      FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to decode JSON: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err
      m ()
forall (m :: * -> *). MonadTest m => m ()
H.success
    Right Value
json -> do
      let redactedJson :: Value
redactedJson = Map Text Text -> Value -> Value
redactJsonFields Map Text Text
changes Value
json
      IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
targetFilePath (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Value
redactedJson

redactJsonFields :: () => Map.Map Text Text -> Value -> Value
redactJsonFields :: Map Text Text -> Value -> Value
redactJsonFields Map Text Text
changes Value
v =
  case Value
v of
    Object Object
obj ->
      let obj' :: Object
obj' =
            (Key -> Value -> Value) -> Object -> Object
forall a b. (Key -> a -> b) -> KeyMap a -> KeyMap b
Aeson.KeyMap.mapWithKey
              ( \Key
k Value
v' ->
                  case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Key -> Text
toText Key
k) Map Text Text
changes of
                    Just Text
replacement -> Text -> Value
String Text
replacement
                    Maybe Text
Nothing -> Value -> Value
recurse Value
v'
              )
              Object
obj
       in Object -> Value
Object Object
obj'
    Array Array
vector ->
      Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> Array -> Array
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map Value -> Value
recurse Array
vector
    Value
_ -> Value
v
 where
  recurse :: Value -> Value
recurse = Map Text Text -> Value -> Value
redactJsonFields Map Text Text
changes