content: {-# OPTIONS_GHC -Wno-orphans #-}
  
  -- This file is part of the Wire Server implementation.
  --
  -- Copyright (C) 2022 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.Federator.ExternalServer where
  
  import Control.Monad.Except
  import Data.ByteString qualified as BS
  import Data.Default
  import Data.Domain
  import Data.Sequence as Seq
  import Data.String.Conversions
  import Data.Text.Encoding qualified as Text
  import Federator.Discovery
  import Federator.Error.ServerError (ServerError (..))
  import Federator.ExternalServer
  import Federator.Interpreter
  import Federator.Metrics
  import Federator.Options
  import Federator.Service (Service (..), ServiceStreaming)
  import Federator.Validation
  import Imports
  import Network.HTTP.Types
  import Network.HTTP.Types qualified as HTTP
  import Network.Wai qualified as Wai
  import Network.Wai.Internal qualified as Wai
  import Network.Wai.Utilities.Server qualified as Wai
  import Polysemy
  import Polysemy.Error
  import Polysemy.Input
  import Polysemy.Output
  import Polysemy.TinyLog
  import Servant.Client.Core qualified as Servant
  import Servant.Server qualified as Servant
  import Servant.Server.Generic
  import Servant.Types.SourceT
  import System.Logger (Msg)
  import Test.Federator.Options (noClientCertSettings)
  import Test.Federator.Util
  import Test.Federator.Validation (mockDiscoveryTrivial)
  import Test.Tasty
  import Test.Tasty.HUnit
  import Wire.API.Federation.Component
  import Wire.API.Routes.FederationDomainConfig
  import Wire.Sem.Logger
  import Wire.Sem.Logger.TinyLog
  
  tests :: TestTree
  tests =
    testGroup
      "ExternalServer"
      [ requestBrigSuccess,
        requestBrigFailure,
        requestGalleySuccess,
        requestNoCertificate,
        requestInvalidCertificate,
        requestNoDomain,
        testInvalidPaths,
        testExtractIp,
        testMethod
      ]
  
  interpretMetricsEmpty :: Sem (Metrics ': r) a -> Sem r a
  interpretMetricsEmpty = interpret $ \case
    OutgoingCounterIncr _ -> pure ()
    IncomingCounterIncr _ -> pure ()
  
  exampleRequest :: FilePath -> ByteString -> IO Wai.Request
  exampleRequest certFile path = do
    cert <- BS.readFile certFile
    testRequest
      def
        { trPath = path,
          trDomainHeader = Just (Text.encodeUtf8 exampleDomain),
          trCertificateHeader = Just cert,
          trBody = "\"foo\""
        }
  
  data Call = Call
    { cComponent :: Component,
      cPath :: ByteString,
      cHeaders :: RequestHeaders,
      cBody :: LByteString,
      cDomain :: Domain
    }
    deriving (Eq, Show)
  
  mockService ::
    (Members [Output Call, Embed IO] r) =>
    HTTP.Status ->
    Sem (ServiceStreaming ': r) a ->
    Sem r a
  mockService status = interpret $ \case
    ServiceCall comp path headers body domain -> do
      output (Call comp path headers body domain)
      pure
        Servant.Response
          { Servant.responseStatusCode = status,
            Servant.responseHeaders = Seq.fromList headers,
            Servant.responseHttpVersion = HTTP.http11,
            Servant.responseBody = source ["\"bar\""]
          }
  
  requestBrigSuccess :: TestTree
  requestBrigSuccess =
    testCase "should forward response from brig when status is 200" $ do
      request0 <-
        exampleRequest
          "test/resources/unit/localhost.example.com.pem"
          "/federation/brig/get-user-by-handle"
      let request =
            request0
              { Wai.requestHeaders =
                  ("Invalid-Header", "foo")
                    : ("X-Wire-API-Version", "v0")
                    : ("X-Forwarded-For", "unknown, [2001:db8::1]:443, 127.0.0.43")
                    : Wai.requestHeaders request0
              }
      Right cert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem"
  
      let assertMetrics :: (Member (Embed IO) r) => Sem (Metrics ': r) a -> Sem r a
          assertMetrics = interpret $ \case
            OutgoingCounterIncr _ -> embed @IO $ assertFailure "Should not increment outgoing counter"
            IncomingCounterIncr od -> embed @IO $ od @?= aValidDomain
  
      resRef <- newIORef Nothing
      (actualCalls, _) <-
        runM
          . assertMetrics
          . runOutputList
          . mockService HTTP.ok200
          . assertNoError @ValidationError
          . assertNoError @DiscoveryFailure
          . assertNoError @ServerError
          . discardTinyLogs
          . mockDiscoveryTrivial
          . runInputConst noClientCertSettings
          . runInputConst scaffoldingFederationDomainConfigs
          $ callInward Brig (RPC "get-user-by-handle") aValidDomain (CertHeader cert) request (saveResponse resRef)
  
      Just res <- readIORef resRef
      let expectedCall =
            Call
              { cComponent = Brig,
                cPath = "/federation/get-user-by-handle",
                cHeaders = [("Wire-Origin-IP", "2001:db8::1"), ("X-Wire-API-Version", "v0")],
                cBody = "\"foo\"",
                cDomain = aValidDomain
              }
      assertEqual "one call to brig should be made" [expectedCall] actualCalls
      Wai.responseStatus res @?= HTTP.status200
      body <- Wai.lazyResponseBody res
      body @?= "\"bar\""
  
  testExtractIp :: TestTree
  testExtractIp =
    testGroup
      "extractIp"
      [ testCase "trims whitespace and parses IPv4" $ do
          extractIp " 127.0.0.1 " @?= Just "127.0.0.1",
        testCase "parses IPv4 with port" $ do
          extractIp "192.0.2.10:8443" @?= Just "192.0.2.10",
        testCase "parses bracketed IPv6" $ do
          extractIp "[2001:db8::1]" @?= Just "2001:db8::1",
        testCase "parses bracketed IPv6 with port" $ do
          extractIp "[2001:db8::2]:443" @?= Just "2001:db8::2",
        testCase "parses bare IPv6" $ do
          extractIp "2001:db8::3" @?= Just "2001:db8::3",
        testCase "parses IPv4-mapped IPv6" $ do
          extractIp "[::ffff:192.168.0.1]:123" @?= Just "::ffff:192.168.0.1",
        testCase "rejects unknown" $ do
          extractIp "unknown" @?= Nothing,
        testCase "rejects invalid" $ do
          extractIp "not-an-ip" @?= Nothing
      ]
  
  requestBrigFailure :: TestTree
  requestBrigFailure =
    testCase "should preserve the status code returned by the service" $ do
      request <-
        exampleRequest
          "test/resources/unit/localhost.example.com.pem"
          "/federation/brig/get-user-by-handle"
      Right cert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem"
  
      resRef <- newIORef Nothing
      (actualCalls, _) <-
        runM
          . interpretMetricsEmpty
          . runOutputList
          . mockService HTTP.notFound404
          . assertNoError @ValidationError
          . assertNoError @DiscoveryFailure
          . assertNoError @ServerError
          . discardTinyLogs
          . mockDiscoveryTrivial
          . runInputConst noClientCertSettings
          . runInputConst scaffoldingFederationDomainConfigs
          $ callInward Brig (RPC "get-user-by-handle") aValidDomain (CertHeader cert) request (saveResponse resRef)
  
      Just res <- readIORef resRef
      let expectedCall = Call Brig "/federation/get-user-by-handle" [] "\"foo\"" aValidDomain
      assertEqual "one call to brig should be made" [expectedCall] actualCalls
      Wai.responseStatus res @?= HTTP.notFound404
      body <- Wai.lazyResponseBody res
      body @?= "\"bar\""
  
  requestGalleySuccess :: TestTree
  requestGalleySuccess =
    testCase "should forward response from galley when response has status 200" $ do
      request <-
        exampleRequest
          "test/resources/unit/localhost.example.com.pem"
          "/federation/galley/get-conversations"
  
      Right cert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem"
  
      resRef <- newIORef Nothing
      (actualCalls, _) <-
        runM
          . runOutputList
          . interpretMetricsEmpty
          . mockService HTTP.ok200
          . assertNoError @ValidationError
          . assertNoError @DiscoveryFailure
          . assertNoError @ServerError
          . discardTinyLogs
          . mockDiscoveryTrivial
          . runInputConst noClientCertSettings
          . runInputConst scaffoldingFederationDomainConfigs
          $ callInward Galley (RPC "get-conversations") aValidDomain (CertHeader cert) request (saveResponse resRef)
  
      Just res <- readIORef resRef
      let expectedCall = Call Galley "/federation/get-conversations" [] "\"foo\"" aValidDomain
      assertEqual "one call to galley should be made" [expectedCall] actualCalls
      Wai.responseStatus res @?= HTTP.status200
      body <- Wai.lazyResponseBody res
      body @?= "\"bar\""
  
  requestNoDomain :: TestTree
  requestNoDomain =
    testCase "should fail with a 404 when no origin domain header is given" $ do
      cert <- BS.readFile "test/resources/unit/localhost.example.com.pem"
      request <-
        testRequest
          def
            { trCertificateHeader = Just cert,
              trPath = "/federation/brig/get-users"
            }
      serviceCallsRef <- newIORef []
      let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined
      void . serverApp request $ \res -> do
        serviceCalls <- readIORef serviceCallsRef
        assertEqual "Expected response to have status 400" status400 (Wai.responseStatus res)
        assertEqual "no calls to any service should be made" [] serviceCalls
        pure Wai.ResponseReceived
  
  requestNoCertificate :: TestTree
  requestNoCertificate =
    testCase "should fail with a 404 when no certificate is given" $ do
      request <-
        testRequest
          def
            { trDomainHeader = Just (Text.encodeUtf8 exampleDomain),
              trPath = "/federation/brig/get-users"
            }
      serviceCallsRef <- newIORef []
      let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined
      void . serverApp request $ \res -> do
        serviceCalls <- readIORef serviceCallsRef
        assertEqual "Expected response to have status 400" status400 (Wai.responseStatus res)
        assertEqual "no calls to any service should be made" [] serviceCalls
        pure Wai.ResponseReceived
  
  -- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7
  -- Reject request if the client certificate for federator is invalid
  requestInvalidCertificate :: TestTree
  requestInvalidCertificate =
    testCase "testRequestInvalidCertificate - should fail with a 404 when an invalid certificate is given" $ do
      request <-
        testRequest
          def
            { trDomainHeader = Just (Text.encodeUtf8 exampleDomain),
              trPath = "/federation/brig/get-users",
              trCertificateHeader = Just "not a certificate"
            }
      serviceCallsRef <- newIORef []
      let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined
      void . serverApp request $ \res -> do
        serviceCalls <- readIORef serviceCallsRef
        assertEqual "Expected response to have status 400" status400 (Wai.responseStatus res)
        assertEqual "no calls to any service should be made" [] serviceCalls
        pure Wai.ResponseReceived
  
  -- @END
  
  testInvalidPaths :: TestTree
  testInvalidPaths = do
    let invalidPaths =
          [ ("", status404),
            ("/", status404),
            ("///", status404),
            -- disallowed paths
            ("federation", status404),
            ("/federation", status404),
            ("/federation/", status404),
            ("/federation/brig", status404),
            ("/federation/brig/", status404), -- empty component
            ("i/users", status404),
            ("/i/users", status404),
            ("/federation/brig/too/many/components", status404),
            -- syntax we don't wish to support
            ("http://federation.wire.link/federation/galley", status404), -- contains scheme and domain
            ("http://federation/stuff", status404), -- contains scheme
            ("federation.wire.link/federation/brig/stuff", status404), -- contains domain
            ("/federation/brig/rpc?bar[]=baz", status403), -- queries not allowed
            ("/federation/brig/stuff?key=value", status403), -- queries not allowed
            -- rpc names that don't match [0-9a-zA-Z-_]+
            ("/federation/brig/../i/users", status404),
            ("/federation/brig/%2e%2e/i/users", status404), -- percent-encoded '../'
            ("/federation/brig/%2E%2E/i/users", status404),
            ("/federation/brig/..%2Fi%2Fusers", status400), -- percent-encoded ../i/users
            ("/federation/brig/%252e%252e/i/users", status404), -- double percent-encoded '../'
            ("/federation/brig/%c0%ae%c0%ae/i/users", status404), -- weird-encoded '../'
            ("/federation/mast/get-users", status400) -- invalid component
          ]
    testGroup "should not forward requests with invalid paths to services" $
      map invalidPathTest invalidPaths
    where
      invalidPathTest :: (ByteString, Status) -> TestTree
      invalidPathTest (invalidPath, expectedStatus) =
        testCase (cs invalidPath) $ do
          request <-
            exampleRequest
              "test/resources/unit/localhost.example.com.pem"
              invalidPath
  
          serviceCallsRef <- newIORef []
          let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined
          void . serverApp request $ \res -> do
            serviceCalls <- readIORef serviceCallsRef
            assertEqual "Unexpected status" expectedStatus (Wai.responseStatus res)
            assertEqual "no calls to any service should be made" [] serviceCalls
            pure Wai.ResponseReceived
  
  testMethod :: TestTree
  testMethod =
    testGroup "only POST should be supported" $
      let invalidMethodTest method = testCase (cs method) $ do
            cert <- BS.readFile "test/resources/unit/localhost.example.com.pem"
            let tr =
                  def
                    { trPath = "/federation/galley/send-message",
                      trDomainHeader = Just (Text.encodeUtf8 exampleDomain),
                      trCertificateHeader = Just cert,
                      trBody = "\"hello\""
                    }
            request <- testRequest tr {trMethod = method}
            serviceCallsRef <- newIORef []
            let serverApp = genericServeT (testInterpreter serviceCallsRef) $ server undefined undefined
            void . serverApp request $ \res -> do
              serviceCalls <- readIORef serviceCallsRef
              assertEqual "Expected response to have status 403" status403 (Wai.responseStatus res)
              assertEqual "no calls to any service should be made" [] serviceCalls
              pure Wai.ResponseReceived
       in map invalidMethodTest [HTTP.methodGet, HTTP.methodDelete, HTTP.methodPut, HTTP.methodPatch]
  
  testInterpreter ::
    IORef [Call] ->
    Sem
      '[ Metrics,
         Input FederationDomainConfigs,
         Input RunSettings,
         DiscoverFederator,
         Error DiscoveryFailure,
         Error ValidationError,
         Error ServerError,
         Error Servant.ServerError,
         Logger (Msg -> Msg),
         ServiceStreaming,
         Output Call,
         Embed IO
       ]
      a ->
    Servant.Handler a
  testInterpreter serviceCallsRef =
    Servant.Handler
      . ExceptT
      . runM @IO
      . runOutputMonoidIORef @Call serviceCallsRef (: [])
      . mockService HTTP.ok200
      . discardLogs
      . runError
      . runWaiErrors @'[DiscoveryFailure, ValidationError, ServerError]
      . mockDiscoveryTrivial
      . runInputConst noClientCertSettings
      . runInputConst scaffoldingFederationDomainConfigs
      . interpretMetricsEmpty
  
  saveResponse :: IORef (Maybe Wai.Response) -> Wai.Response -> IO Wai.ResponseReceived
  saveResponse ref res = writeIORef ref (Just res) $> Wai.ResponseReceived
  
  exampleDomain :: Text
  exampleDomain = "localhost.example.com"
  
  aValidDomain :: Domain
  aValidDomain = Domain exampleDomain
  
  scaffoldingFederationDomainConfigs :: FederationDomainConfigs
  scaffoldingFederationDomainConfigs = defFederationDomainConfigs {strategy = AllowAll}
  