{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2026 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/>.

-- | Self-tests for the 'Shape' DSL and 'shouldMatchShape' assertion.
module Test.Shape where

import Testlib.Prelude

-- | A matching object shape succeeds.
testShapeObjectMatch :: (HasCallStack) => App ()
testShapeObjectMatch :: HasCallStack => App ()
testShapeObjectMatch = do
  let v :: Value
v = [Pair] -> Value
object [String
"foo" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
42 :: Int), String
"bar" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"hello" :: String)]
  Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` [(String, Shape)] -> Shape
SObject [(String
"foo", Shape
SNumber), (String
"bar", Shape
SString)]

-- | An unexpected key in the actual object causes a failure.
testShapeUnexpectedKey :: (HasCallStack) => App ()
testShapeUnexpectedKey :: HasCallStack => App ()
testShapeUnexpectedKey = do
  let v :: Value
v = [Pair] -> Value
object [String
"foo" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
1 :: Int), String
"extra" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
2 :: Int)]
  (AssertionFailure -> App ()) -> App () -> App ()
forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure (\AssertionFailure
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) do
    Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` [(String, Shape)] -> Shape
SObject [(String
"foo", Shape
SNumber)]

-- | A missing key in the actual object causes a failure.
testShapeMissingKey :: (HasCallStack) => App ()
testShapeMissingKey :: HasCallStack => App ()
testShapeMissingKey = do
  let v :: Value
v = [Pair] -> Value
object [String
"foo" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
1 :: Int)]
  (AssertionFailure -> App ()) -> App () -> App ()
forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure (\AssertionFailure
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) do
    Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` [(String, Shape)] -> Shape
SObject [(String
"foo", Shape
SNumber), (String
"bar", Shape
SString)]

-- | Providing a non-object value when 'SObject' is expected causes a failure.
testShapeWrongTypeObject :: (HasCallStack) => App ()
testShapeWrongTypeObject :: HasCallStack => App ()
testShapeWrongTypeObject = do
  let v :: Value
v = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"hello" :: String)
  (AssertionFailure -> App ()) -> App () -> App ()
forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure (\AssertionFailure
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) do
    Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` [(String, Shape)] -> Shape
SObject [(String
"foo", Shape
SNumber)]

-- | Providing a non-string when 'SString' is expected causes a failure.
testShapeWrongTypeString :: (HasCallStack) => App ()
testShapeWrongTypeString :: HasCallStack => App ()
testShapeWrongTypeString = do
  let v :: Value
v = Scientific -> Value
Number Scientific
42
  (AssertionFailure -> App ()) -> App () -> App ()
forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure (\AssertionFailure
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) do
    Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` Shape
SString

-- | An array element with the wrong type causes a failure, and the error
-- message includes the element index.
testShapeArrayElementMismatch :: (HasCallStack) => App ()
testShapeArrayElementMismatch :: HasCallStack => App ()
testShapeArrayElementMismatch = do
  -- First two elements are strings (match), third is a number (mismatch at [2])
  let v :: Value
v = [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"a" :: String), String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"b" :: String), Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int
3 :: Int)]
  (AssertionFailure -> App ()) -> App () -> App ()
forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure (\AssertionFailure
e -> AssertionFailure
e.msg HasCallStack => String -> String -> App ()
String -> String -> App ()
`shouldContainString` String
"[2]") do
    Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` Shape -> Shape
SArray Shape
SString

-- | A nested mismatch deep in an object/array reports the full JSON path.
testShapeNestedPathReported :: (HasCallStack) => App ()
testShapeNestedPathReported :: HasCallStack => App ()
testShapeNestedPathReported = do
  let v :: Value
v =
        [Pair] -> Value
object
          [ String
"assets"
              String -> [Value] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [ [Pair] -> Value
object
                     [ String
"key" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
42 :: Int), -- wrong: should be SString
                       String
"size" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"preview" :: String),
                       String
"type" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"image" :: String)
                     ]
                 ]
          ]
  (AssertionFailure -> App ()) -> App () -> App ()
forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure (\AssertionFailure
e -> AssertionFailure
e.msg HasCallStack => String -> String -> App ()
String -> String -> App ()
`shouldContainString` String
".assets[0].key") do
    Value
v
      Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` [(String, Shape)] -> Shape
SObject
        [ ( String
"assets",
            Shape -> Shape
SArray
              ( [(String, Shape)] -> Shape
SObject
                  [ (String
"key", Shape
SString),
                    (String
"size", Shape
SString),
                    (String
"type", Shape
SString)
                  ]
              )
          )
        ]

-- | 'SAny' is a wildcard that matches every JSON value.
testShapeSAny :: (HasCallStack) => App ()
testShapeSAny :: HasCallStack => App ()
testShapeSAny = do
  let vals :: [Value]
      vals :: [Value]
vals = [Value
Null, Bool -> Value
Bool Bool
True, String -> Value
forall a. ToJSON a => a -> Value
toJSON (String
"x" :: String), Scientific -> Value
Number Scientific
1, [Int] -> Value
forall a. ToJSON a => a -> Value
toJSON ([] :: [Int]), [Pair] -> Value
object []]
  (Value -> App ()) -> [Value] -> App ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` Shape
SAny) [Value]
vals

-- | An empty array matches 'SArray' with any element shape.
testShapeEmptyArray :: (HasCallStack) => App ()
testShapeEmptyArray :: HasCallStack => App ()
testShapeEmptyArray = do
  let v :: Value
v = [Int] -> Value
forall a. ToJSON a => a -> Value
toJSON ([] :: [Int])
  Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` Shape -> Shape
SArray Shape
SString
  Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` Shape -> Shape
SArray Shape
SNumber
  Value
v Value -> Shape -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Shape -> App ()
`shouldMatchShape` Shape -> Shape
SArray ([(String, Shape)] -> Shape
SObject [])

-- | 'valueShape' computes the correct shape of a JSON value.
testValueShape :: (HasCallStack) => App ()
testValueShape :: HasCallStack => App ()
testValueShape = do
  let v :: Value
v =
        [Pair] -> Value
object
          [ String
"name" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"Alice" :: String),
            String
"age" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
30 :: Int),
            String
"active" String -> Bool -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Bool
True,
            String
"scores" String -> [Int] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [Int
1 :: Int, Int
2, Int
3],
            String
"address" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [Pair] -> Value
object [String
"city" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"London" :: String)]
          ]
  shape <- Value -> App Shape
forall a. MakesValue a => a -> App Shape
valueShape Value
v
  -- The computed shape should itself pass the shape-match on v
  v `shouldMatchShape` shape