{-# OPTIONS -Wno-ambiguous-fields #-}

-- 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 Test.Errors where

import API.Brig
import Control.Monad.Codensity
import Control.Monad.Reader
import qualified Data.Aeson as Aeson
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import SetupHelpers
import Testlib.Mock
import Testlib.Prelude
import Testlib.ResourcePool

testNestedError :: (HasCallStack) => App ()
testNestedError :: HasCallStack => App ()
testNestedError = do
  let innerError :: Value
innerError =
        [Pair] -> Value
object
          [ FilePath
"code" FilePath -> Port -> Pair
forall a. ToJSON a => FilePath -> a -> Pair
.= (Port
400 :: Int),
            FilePath
"label" FilePath -> FilePath -> Pair
forall a. ToJSON a => FilePath -> a -> Pair
.= FilePath
"example",
            FilePath
"message" FilePath -> FilePath -> Pair
forall a. ToJSON a => FilePath -> a -> Pair
.= FilePath
"Example remote federator failure"
          ]

  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ResourcePool BackendResource
resourcePool
  lowerCodensity $ do
    [res] <- acquireResources 1 resourcePool
    mockConfig <- do
      mBase <- asks (.servicesCwdBase)
      pure $ case mBase of
        Just FilePath
_ ->
          -- when running locally, spawn a fake ingress returning an error
          MockServerConfig
forall a. Default a => a
def
            { port = Just (fromIntegral res.berNginzSslPort),
              tls = True
            }
        Maybe FilePath
Nothing -> do
          -- on CI, the real federation ingress is available, so we spawn its federator upstream instead
          MockServerConfig
forall a. Default a => a
def
            { port = Just (fromIntegral res.berFederatorExternal),
              tls = False
            }
    void
      $ startMockServer mockConfig
      $ codensityApp
      $ \Request
_req -> Response -> Codensity IO Response
forall a. a -> Codensity IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Codensity IO Response)
-> Response -> Codensity IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HTTP.status400 ResponseHeaders
forall a. Monoid a => a
mempty (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
innerError

    -- get remote user
    lift $ do
      user <- randomUser OwnDomain def
      targetId <- randomId
      let target = [Pair] -> Value
object [FilePath
"id" FilePath -> FilePath -> Pair
forall a. ToJSON a => FilePath -> a -> Pair
.= FilePath
targetId, FilePath
"domain" FilePath -> FilePath -> Pair
forall a. ToJSON a => FilePath -> a -> Pair
.= BackendResource
res.berDomain]
      bindResponse (getUser user target) $ \Response
resp -> do
        Response
resp.status Port -> Port -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Port -> App ()
`shouldMatchInt` Port
533
        Response
resp.json App Value -> FilePath -> App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> FilePath -> App Value
%. FilePath
"inner" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value
innerError