{-# LANGUAGE CPP #-}

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

module Testlib.Assertions where

import Control.Applicative ((<|>))
import Control.Exception as E
import Control.Lens ((^?))
import qualified Control.Lens.Plated as LP
import Control.Monad
import qualified Control.Monad.Catch as Catch
import Control.Monad.Reader
import Control.Retry
import Data.Aeson (Value)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Diff as AD
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import Data.Aeson.Lens (_Array, _Object)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.Foldable
import Data.Hex
import Data.List
import qualified Data.Map as Map
import Data.Maybe (isJust, mapMaybe)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import GHC.Stack as Stack
import qualified Network.HTTP.Client as HTTP
import System.FilePath
import Testlib.JSON
import Testlib.Printing
import Testlib.Types
import Prelude

assertBool :: (HasCallStack) => String -> Bool -> App ()
assertBool :: HasCallStack => String -> Bool -> App ()
assertBool String
_ Bool
True = () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
assertBool String
msg Bool
False = String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
msg

assertOne :: (HasCallStack, Foldable t) => t a -> App a
assertOne :: forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App a
assertOne t a
xs = case t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs of
  [a
x] -> a -> App a
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  [a]
other -> String -> App a
forall a. HasCallStack => String -> App a
assertFailure (String
"Expected one, but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
other))

assertAtLeastOne :: (HasCallStack, Foldable t) => t a -> App ()
assertAtLeastOne :: forall (t :: * -> *) a. (HasCallStack, Foldable t) => t a -> App ()
assertAtLeastOne t a
xs = case t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs of
  [] -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String
"Expected at least one, but got nothing")
  [a]
_ -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

expectFailure :: (HasCallStack) => (AssertionFailure -> App ()) -> App a -> App ()
expectFailure :: forall a.
HasCallStack =>
(AssertionFailure -> App ()) -> App a -> App ()
expectFailure AssertionFailure -> App ()
checkFailure App a
action = do
  env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  res :: Either AssertionFailure x <-
    liftIO
      (E.try (runAppWithEnv env action))
  case res of
    Left AssertionFailure
e -> AssertionFailure -> App ()
checkFailure AssertionFailure
e
    Right a
_ -> String -> App ()
forall a. HasCallStack => String -> App a
assertFailure String
"Expected AssertionFailure, but none occured"

shouldMatch ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected value
  b ->
  App ()
shouldMatch :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch = Maybe String -> a -> b -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
Maybe String -> a -> b -> App ()
shouldMatchWithMsg Maybe String
forall a. Maybe a
Nothing

-- | Retries every 100ms until timeOutSeconds from Env is reached
eventually :: App a -> App a
eventually :: forall a. App a -> App a
eventually App a
action = do
  timeout <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.timeOutSeconds)
  recovering
    (limitRetriesByCumulativeDelay (timeout * 1_000_000) $ constantDelay 100_000)
    ((\RetryStatus
_ -> (AssertionFailure -> App Bool) -> Handler App Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Catch.Handler ((AssertionFailure -> App Bool) -> Handler App Bool)
-> (AssertionFailure -> App Bool) -> Handler App Bool
forall a b. (a -> b) -> a -> b
$ \(AssertionFailure
_ :: AssertionFailure) -> Bool -> App Bool
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) : skipAsyncExceptions)
    (const action)

shouldMatchWithMsg ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  -- | Message to be added to failure report
  Maybe String ->
  -- | The actual value
  a ->
  -- | The expected value
  b ->
  App ()
shouldMatchWithMsg :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
Maybe String -> a -> b -> App ()
shouldMatchWithMsg Maybe String
msg a
a b
b = do
  xa <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a
  xb <- make b
  unless (xa == xb) do
    pa <- prettyJSON xa
    pb <- prettyJSON xb
    diff <- -- show diff, but only in the interesting cases.
      if (isJust (xa ^? _Object) && isJust (xb ^? _Object))
        || (isJust (xa ^? _Array) && isJust (xb ^? _Array))
        then ("\nDiff:\n" <>) <$> prettyJSON (AD.diff xa xb)
        else pure ""
    assertFailure $ (maybe "" (<> "\n") msg) <> "Actual:\n" <> pa <> "\nExpected:\n" <> pb <> diff

data LenientMatchRule
  = EmptyArrayIsNull
  | ArraysAreSets
  | RemoveNullFieldsFromObjects
  deriving (LenientMatchRule -> LenientMatchRule -> Bool
(LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> Eq LenientMatchRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LenientMatchRule -> LenientMatchRule -> Bool
== :: LenientMatchRule -> LenientMatchRule -> Bool
$c/= :: LenientMatchRule -> LenientMatchRule -> Bool
/= :: LenientMatchRule -> LenientMatchRule -> Bool
Eq, Eq LenientMatchRule
Eq LenientMatchRule =>
(LenientMatchRule -> LenientMatchRule -> Ordering)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> Bool)
-> (LenientMatchRule -> LenientMatchRule -> LenientMatchRule)
-> (LenientMatchRule -> LenientMatchRule -> LenientMatchRule)
-> Ord LenientMatchRule
LenientMatchRule -> LenientMatchRule -> Bool
LenientMatchRule -> LenientMatchRule -> Ordering
LenientMatchRule -> LenientMatchRule -> LenientMatchRule
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LenientMatchRule -> LenientMatchRule -> Ordering
compare :: LenientMatchRule -> LenientMatchRule -> Ordering
$c< :: LenientMatchRule -> LenientMatchRule -> Bool
< :: LenientMatchRule -> LenientMatchRule -> Bool
$c<= :: LenientMatchRule -> LenientMatchRule -> Bool
<= :: LenientMatchRule -> LenientMatchRule -> Bool
$c> :: LenientMatchRule -> LenientMatchRule -> Bool
> :: LenientMatchRule -> LenientMatchRule -> Bool
$c>= :: LenientMatchRule -> LenientMatchRule -> Bool
>= :: LenientMatchRule -> LenientMatchRule -> Bool
$cmax :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
max :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
$cmin :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
min :: LenientMatchRule -> LenientMatchRule -> LenientMatchRule
Ord, Int -> LenientMatchRule -> String -> String
[LenientMatchRule] -> String -> String
LenientMatchRule -> String
(Int -> LenientMatchRule -> String -> String)
-> (LenientMatchRule -> String)
-> ([LenientMatchRule] -> String -> String)
-> Show LenientMatchRule
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LenientMatchRule -> String -> String
showsPrec :: Int -> LenientMatchRule -> String -> String
$cshow :: LenientMatchRule -> String
show :: LenientMatchRule -> String
$cshowList :: [LenientMatchRule] -> String -> String
showList :: [LenientMatchRule] -> String -> String
Show, LenientMatchRule
LenientMatchRule -> LenientMatchRule -> Bounded LenientMatchRule
forall a. a -> a -> Bounded a
$cminBound :: LenientMatchRule
minBound :: LenientMatchRule
$cmaxBound :: LenientMatchRule
maxBound :: LenientMatchRule
Bounded, Int -> LenientMatchRule
LenientMatchRule -> Int
LenientMatchRule -> [LenientMatchRule]
LenientMatchRule -> LenientMatchRule
LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
LenientMatchRule
-> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
(LenientMatchRule -> LenientMatchRule)
-> (LenientMatchRule -> LenientMatchRule)
-> (Int -> LenientMatchRule)
-> (LenientMatchRule -> Int)
-> (LenientMatchRule -> [LenientMatchRule])
-> (LenientMatchRule -> LenientMatchRule -> [LenientMatchRule])
-> (LenientMatchRule -> LenientMatchRule -> [LenientMatchRule])
-> (LenientMatchRule
    -> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule])
-> Enum LenientMatchRule
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LenientMatchRule -> LenientMatchRule
succ :: LenientMatchRule -> LenientMatchRule
$cpred :: LenientMatchRule -> LenientMatchRule
pred :: LenientMatchRule -> LenientMatchRule
$ctoEnum :: Int -> LenientMatchRule
toEnum :: Int -> LenientMatchRule
$cfromEnum :: LenientMatchRule -> Int
fromEnum :: LenientMatchRule -> Int
$cenumFrom :: LenientMatchRule -> [LenientMatchRule]
enumFrom :: LenientMatchRule -> [LenientMatchRule]
$cenumFromThen :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
enumFromThen :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
$cenumFromTo :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
enumFromTo :: LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
$cenumFromThenTo :: LenientMatchRule
-> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
enumFromThenTo :: LenientMatchRule
-> LenientMatchRule -> LenientMatchRule -> [LenientMatchRule]
Enum)

shouldMatchWithRules ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  [LenientMatchRule] ->
  (Aeson.Value -> App (Maybe Aeson.Value)) ->
  a ->
  b ->
  App ()
shouldMatchWithRules :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
[LenientMatchRule]
-> (Value -> App (Maybe Value)) -> a -> b -> App ()
shouldMatchWithRules [LenientMatchRule]
rules Value -> App (Maybe Value)
customRules a
a b
b = do
  xa <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a
  xb <- make b
  simplify xa `shouldMatch` simplify xb
  where
    simplify :: Aeson.Value -> App Aeson.Value
    simplify :: Value -> App Value
simplify = (Value -> App (Maybe Value)) -> Value -> App Value
forall (m :: * -> *) a.
(Monad m, Plated a) =>
(a -> m (Maybe a)) -> a -> m a
LP.rewriteM ((Value -> App (Maybe Value)) -> Value -> App Value)
-> (Value -> App (Maybe Value)) -> Value -> App Value
forall a b. (a -> b) -> a -> b
$ (\Value
v -> (Maybe Value -> (Value -> App (Maybe Value)) -> App (Maybe Value))
-> Maybe Value -> [Value -> App (Maybe Value)] -> App (Maybe Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Value
-> Maybe Value -> (Value -> App (Maybe Value)) -> App (Maybe Value)
tryApplyRule Value
v) Maybe Value
forall a. Maybe a
Nothing [Value -> App (Maybe Value)]
compiledRules)

    tryApplyRule ::
      Aeson.Value ->
      Maybe Aeson.Value ->
      (Aeson.Value -> App (Maybe Aeson.Value)) ->
      App (Maybe Aeson.Value)
    tryApplyRule :: Value
-> Maybe Value -> (Value -> App (Maybe Value)) -> App (Maybe Value)
tryApplyRule Value
v Maybe Value
bresult Value -> App (Maybe Value)
arule = (Maybe Value
bresult Maybe Value -> Maybe Value -> Maybe Value
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>) (Maybe Value -> Maybe Value)
-> App (Maybe Value) -> App (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> App (Maybe Value)
arule Value
v

    compiledRules :: [Aeson.Value -> App (Maybe Aeson.Value)]
    compiledRules :: [Value -> App (Maybe Value)]
compiledRules = Value -> App (Maybe Value)
customRules (Value -> App (Maybe Value))
-> [Value -> App (Maybe Value)] -> [Value -> App (Maybe Value)]
forall a. a -> [a] -> [a]
: ((\LenientMatchRule
r Value
v -> Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> App (Maybe Value))
-> Maybe Value -> App (Maybe Value)
forall a b. (a -> b) -> a -> b
$ LenientMatchRule -> Value -> Maybe Value
runRule LenientMatchRule
r Value
v) (LenientMatchRule -> Value -> App (Maybe Value))
-> [LenientMatchRule] -> [Value -> App (Maybe Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LenientMatchRule]
rules)

    runRule :: LenientMatchRule -> Aeson.Value -> Maybe Aeson.Value
    runRule :: LenientMatchRule -> Value -> Maybe Value
runRule LenientMatchRule
EmptyArrayIsNull = \case
      Aeson.Array Vector Value
arr
        | Vector Value
arr Vector Value -> Vector Value -> Bool
forall a. Eq a => a -> a -> Bool
== Vector Value
forall a. Monoid a => a
mempty ->
            Value -> Maybe Value
forall a. a -> Maybe a
Just Value
Aeson.Null
      Value
_ -> Maybe Value
forall a. Maybe a
Nothing
    runRule LenientMatchRule
ArraysAreSets = \case
      Aeson.Array (Vector Value -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [Value]
arr) ->
        let arr' :: [Value]
arr' = [Value] -> [Value]
forall a. Ord a => [a] -> [a]
sort [Value]
arr
         in if [Value]
arr [Value] -> [Value] -> Bool
forall a. Eq a => a -> a -> Bool
== [Value]
arr' then Maybe Value
forall a. Maybe a
Nothing else Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON [Value]
arr'
      Value
_ -> Maybe Value
forall a. Maybe a
Nothing
    runRule LenientMatchRule
RemoveNullFieldsFromObjects = \case
      Aeson.Object (KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Aeson.toList -> [(Key, Value)]
obj)
        | ((Key, Value) -> Bool) -> [(Key, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
Aeson.Null) (Value -> Bool) -> ((Key, Value) -> Value) -> (Key, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Value
forall a b. (a, b) -> b
snd) [(Key, Value)]
obj ->
            let rmNulls :: (a, Value) -> Maybe (a, Value)
rmNulls (a
_, Value
Aeson.Null) = Maybe (a, Value)
forall a. Maybe a
Nothing
                rmNulls (a
k, Value
v) = (a, Value) -> Maybe (a, Value)
forall a. a -> Maybe a
Just (a
k, Value
v)
             in Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> ([(Key, Value)] -> Value) -> [(Key, Value)] -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Value -> Value
Aeson.Object (KeyMap Value -> Value)
-> ([(Key, Value)] -> KeyMap Value) -> [(Key, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> KeyMap Value
forall v. [(Key, v)] -> KeyMap v
Aeson.fromList ([(Key, Value)] -> Maybe Value) -> [(Key, Value)] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ((Key, Value) -> Maybe (Key, Value))
-> [(Key, Value)] -> [(Key, Value)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key, Value) -> Maybe (Key, Value)
forall {a}. (a, Value) -> Maybe (a, Value)
rmNulls [(Key, Value)]
obj
      Value
_ -> Maybe Value
forall a. Maybe a
Nothing

shouldMatchBase64 ::
  (MakesValue a, HasCallStack) =>
  -- | The actual value, in base64
  a ->
  -- | The expected value
  ByteString ->
  App ()
a
a shouldMatchBase64 :: forall a. (MakesValue a, HasCallStack) => a -> ByteString -> App ()
`shouldMatchBase64` ByteString
b = do
  let xb :: Text
xb = ByteString -> Text
Text.decodeUtf8 (ByteString -> ByteString
B64.encode ByteString
b)
  a
a a -> Text -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Text
xb

shouldNotMatch ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The un-expected value
  b ->
  App ()
a
a shouldNotMatch :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldNotMatch` b
b = do
  xa <- a -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make a
a
  xb <- make b

  unless (jsonType xa == jsonType xb) $ do
    pa <- prettyJSON xa
    pb <- prettyJSON xb
    assertFailure $
      "Compared values are not of the same type:\n"
        <> "Left side:\n"
        <> pa
        <> "\nRight side:\n"
        <> pb

  when (xa == xb) $ do
    pa <- prettyJSON xa
    assertFailure $ "Expected different value but got this:\n" <> pa

-- | Specialized variant of `shouldMatch` to avoid the need for type annotations.
shouldMatchInt ::
  (MakesValue a, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected value
  Int ->
  App ()
shouldMatchInt :: forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
shouldMatchInt = a -> Int -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatch

shouldNotMatchInt ::
  (MakesValue a, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected value
  Int ->
  App ()
shouldNotMatchInt :: forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
shouldNotMatchInt = a -> Int -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldNotMatch

shouldMatchRange ::
  (MakesValue a, HasCallStack) =>
  -- | The actual value
  a ->
  -- | The expected range, inclusive both sides
  (Int, Int) ->
  App ()
shouldMatchRange :: forall a. (MakesValue a, HasCallStack) => a -> (Int, Int) -> App ()
shouldMatchRange a
a (Int
lower, Int
upper) = do
  xa :: Int <- a -> App Int
forall i a. (Integral i, HasCallStack, MakesValue a) => a -> App i
asIntegral a
a
  when (xa < lower || xa > upper) $ do
    pa <- prettyJSON xa
    assertFailure $ "Actual:\n" <> pa <> "\nExpected:\nin range (" <> show lower <> ", " <> show upper <> ") (including bounds)"

-- | Match on sorted lists (sets where elements may occur more than once).  (Maybe this should
-- be called `shouldMatchMultiSet`?)
shouldMatchSet ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  a ->
  b ->
  App ()
shouldMatchSet :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatchSet a
a b
b = do
  la <- ([Value] -> [Value]) -> App [Value] -> App [Value]
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Value] -> [Value]
forall a. Ord a => [a] -> [a]
sort (a -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList a
a)
  lb <- fmap sort (asList b)
  la `shouldMatch` lb

shouldBeEmpty :: (MakesValue a, HasCallStack) => a -> App ()
shouldBeEmpty :: forall a. (MakesValue a, HasCallStack) => a -> App ()
shouldBeEmpty a
a = a
a a -> [Value] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` ([Value]
forall a. Monoid a => a
mempty :: [Value])

shouldBeNull :: (MakesValue a, HasCallStack) => a -> App ()
shouldBeNull :: forall a. (MakesValue a, HasCallStack) => a -> App ()
shouldBeNull a
a = a
a a -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value
Aeson.Null

shouldMatchOneOf ::
  (MakesValue a, MakesValue b, HasCallStack) =>
  a ->
  b ->
  App ()
shouldMatchOneOf :: forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
shouldMatchOneOf a
a b
b = do
  lb <- b -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList b
b
  xa <- make a
  unless (xa `elem` lb) $ do
    pa <- prettyJSON a
    pb <- prettyJSON b
    assertFailure $ "Expected:\n" <> pa <> "\n to match at least one of:\n" <> pb

shouldContainString ::
  (HasCallStack) =>
  -- | The actual value
  String ->
  -- | The expected value
  String ->
  App ()
shouldContainString :: HasCallStack => String -> String -> App ()
shouldContainString = String -> String -> App ()
forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
shouldContain

shouldContain ::
  (Eq a, Show a, HasCallStack) =>
  -- | The actual value
  [a] ->
  -- | The expected value
  [a] ->
  App ()
[a]
super shouldContain :: forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldContain` [a]
sub = do
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([a]
sub [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [a]
super) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"String or List:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show [a]
super String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nDoes not contain:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show [a]
sub

shouldNotContain ::
  (Eq a, Show a, HasCallStack) =>
  -- | The actual value
  [a] ->
  -- | The expected value
  [a] ->
  App ()
[a]
super shouldNotContain :: forall a. (Eq a, Show a, HasCallStack) => [a] -> [a] -> App ()
`shouldNotContain` [a]
sub = do
  Bool -> App () -> App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([a]
sub [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [a]
super) (App () -> App ()) -> App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
    String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ String
"String or List:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show [a]
super String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nDoes contain:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall a. Show a => a -> String
show [a]
sub

printFailureDetails :: AssertionFailure -> IO String
printFailureDetails :: AssertionFailure -> IO String
printFailureDetails (AssertionFailure CallStack
stack Maybe Response
mbResponse Maybe String
ctx String
msg) = do
  s <- CallStack -> IO String
prettierCallStack CallStack
stack
  pure . unlines $
    colored yellow "assertion failure:"
      : colored red msg
      : "\n" <> s
      : toList (fmap prettyResponse mbResponse)
        <> toList (fmap prettyContext ctx)

printAppFailureDetails :: AppFailure -> IO String
printAppFailureDetails :: AppFailure -> IO String
printAppFailureDetails (AppFailure String
msg CallStack
stack) = do
  s <- CallStack -> IO String
prettierCallStack CallStack
stack
  pure . unlines $
    colored yellow "app failure:"
      : colored red msg
      : "\n"
      : [s]

prettyContext :: String -> String
prettyContext :: String -> String
prettyContext String
ctx = do
  [String] -> String
unlines
    [ String -> String -> String
colored String
yellow String
"context:",
      String -> String -> String
colored String
blue String
ctx
    ]

printExceptionDetails :: SomeException -> IO String
printExceptionDetails :: SomeException -> IO String
printExceptionDetails SomeException
e = do
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> ([String] -> String) -> [String] -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO String) -> [String] -> IO String
forall a b. (a -> b) -> a -> b
$
    [ String -> String -> String
colored String
yellow String
"exception:",
      String -> String -> String
colored String
red (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
    ]

prettierCallStack :: CallStack -> IO String
prettierCallStack :: CallStack -> IO String
prettierCallStack CallStack
cstack = do
  sl <-
    CallStack -> IO String
prettierCallStackLines
      (CallStack -> IO String)
-> (CallStack -> CallStack) -> CallStack -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, SrcLoc)] -> CallStack
Stack.fromCallSiteList
      ([(String, SrcLoc)] -> CallStack)
-> (CallStack -> [(String, SrcLoc)]) -> CallStack -> CallStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, SrcLoc) -> Bool)
-> [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, SrcLoc) -> Bool) -> (String, SrcLoc) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> Bool
isTestlibEntry)
      ([(String, SrcLoc)] -> [(String, SrcLoc)])
-> (CallStack -> [(String, SrcLoc)])
-> CallStack
-> [(String, SrcLoc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [(String, SrcLoc)]
Stack.getCallStack
      (CallStack -> IO String) -> CallStack -> IO String
forall a b. (a -> b) -> a -> b
$ CallStack
cstack
  pure $ unlines [colored yellow "call stack: ", sl]
  where
    isTestlibEntry :: (String, SrcLoc) -> Bool
    isTestlibEntry :: (String, SrcLoc) -> Bool
isTestlibEntry (String
_, SrcLoc {Int
String
srcLocPackage :: String
srcLocModule :: String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
..}) =
      String
"RunAllTests.hs" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
srcLocFile

prettierCallStackLines :: CallStack -> IO String
prettierCallStackLines :: CallStack -> IO String
prettierCallStackLines CallStack
cstack =
  SourceDirCache -> String -> [(String, SrcLoc)] -> Int -> IO String
forall {t}.
(Show t, Num t) =>
SourceDirCache -> String -> [(String, SrcLoc)] -> t -> IO String
go SourceDirCache
forall k a. Map k a
Map.empty String
"" (CallStack -> [(String, SrcLoc)]
Stack.getCallStack CallStack
cstack) (Int
1 :: Int)
  where
    go :: SourceDirCache -> String -> [(String, SrcLoc)] -> t -> IO String
go SourceDirCache
_ String
s [] t
_ = String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s
    go SourceDirCache
cache String
s ((String
funName, SrcLoc {Int
String
srcLocEndCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocPackage :: SrcLoc -> String
srcLocPackage :: String
srcLocModule :: String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
..}) : [(String, SrcLoc)]
rest) t
i = do
      (cache', mSrcDir) <- SourceDirCache -> String -> IO (SourceDirCache, Maybe String)
getSourceDirCached SourceDirCache
cache String
srcLocPackage
      mLine <- case mSrcDir of
        Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
        Just String
srcDir -> do
          mSrc <- String -> IO (Maybe String)
tryReadFile (String
srcDir String -> String -> String
</> String
srcLocFile)
          case mSrc of
            Just String
src ->
              case Int -> String -> Maybe String
getLineNumber Int
srcLocStartLine String
src of
                Just String
line -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
line))
                Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
            Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
      let s' = String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
funName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
srcLocFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
yellow (Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
      let s'' = case Maybe String
mLine of
            Just String
line -> String
s' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String -> String
colored String
blue (String
"     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
line String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n")
            Maybe String
Nothing -> String
s'
      go cache' (s'' <> "\n") rest (i + 1)

getSourceDir :: String -> IO (Maybe FilePath)
getSourceDir :: String -> IO (Maybe String)
getSourceDir String
packageId = do
  ms <- String -> IO (Maybe String)
tryReadFile (String -> String
packagedbFile String
packageId)
  case ms of
    Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    Just String
s ->
      Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
extractDataDir String
s)
  where
    packagedbFile :: String -> FilePath
    packagedbFile :: String -> String
packagedbFile String
pkgId =
      let root :: String
root = String
"./dist-newstyle/packagedb/ghc-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> __GLASGOW_HASKELL_FULL_VERSION__
       in String
root String -> String -> String
</> (String
pkgId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".conf")

    extractDataDir :: String -> Maybe String
    extractDataDir :: String -> Maybe String
extractDataDir String
s = [String] -> Maybe String
go (String -> [String]
lines String
s)
      where
        go :: [String] -> Maybe String
go [] = Maybe String
forall a. Maybe a
Nothing
        go (String
line : [String]
otherlines) =
          case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"data-dir:" String
line of
            Just String
rest -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
rest
            Maybe String
Nothing -> [String] -> Maybe String
go [String]
otherlines

type SourceDirCache = Map.Map String (Maybe FilePath)

getSourceDirCached :: SourceDirCache -> String -> IO (SourceDirCache, Maybe FilePath)
getSourceDirCached :: SourceDirCache -> String -> IO (SourceDirCache, Maybe String)
getSourceDirCached SourceDirCache
cache String
packageId =
  case String -> SourceDirCache -> Maybe (Maybe String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
packageId SourceDirCache
cache of
    Just Maybe String
hit -> (SourceDirCache, Maybe String) -> IO (SourceDirCache, Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceDirCache
cache, Maybe String
hit)
    Maybe (Maybe String)
Nothing -> do
      v <- String -> IO (Maybe String)
getSourceDir String
packageId
      pure (Map.insert packageId v cache, v)

tryReadFile :: FilePath -> IO (Maybe String)
tryReadFile :: String -> IO (Maybe String)
tryReadFile String
p = do
  eith <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (String -> IO String
readFile String
p)
  pure $ case eith of
    Left SomeException
_ -> Maybe String
forall a. Maybe a
Nothing
    Right String
s -> String -> Maybe String
forall a. a -> Maybe a
Just String
s

getLineNumber :: Int -> String -> Maybe String
getLineNumber :: Int -> String -> Maybe String
getLineNumber Int
lineNo String
s =
  case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop (Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (String -> [String]
lines String
s) of
    [] -> Maybe String
forall a. Maybe a
Nothing
    (String
l : [String]
_) -> String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
l

prettyResponse :: Response -> String
prettyResponse :: Response -> String
prettyResponse Response
r =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
yellow String
"request: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Request -> String
showRequest Response
r.request,
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
yellow String
"request headers: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Header] -> String
showHeaders (Request -> [Header]
HTTP.requestHeaders Response
r.request),
        case Request -> Maybe ByteString
getRequestBody Response
r.request of
          Maybe ByteString
Nothing -> []
          Just ByteString
b ->
            [ String -> String -> String
colored String
yellow String
"request body:",
              Text -> String
Text.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
Text.decodeUtf8With OnDecodeError
Text.lenientDecode (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> ByteString
BS.fromStrict ByteString
b) of
                Just Value
v -> ByteString -> ByteString
BS.toStrict (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty (Value
v :: Aeson.Value))
                Maybe Value
Nothing -> ByteString -> ByteString
forall t. Hex t => t -> t
hex ByteString
b
            ],
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
blue String
"response status: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Response
r.status,
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
blue String
"response headers:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Header] -> String
showHeaders Response
r.headers,
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
colored String
blue String
"response body:",
        String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$
          ( Text -> String
TL.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TL.decodeUtf8With OnDecodeError
Text.lenientDecode (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$
              case Response
r.jsonBody of
                Just Value
b -> (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty Value
b)
                Maybe Value
Nothing -> ByteString -> ByteString
BS.fromStrict Response
r.body
          )
      ]