-- 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/>.
{-# LANGUAGE TemplateHaskell #-}

-- 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 Federator.Service
  ( Service (..),
    ServiceStreaming,
    interpretServiceHTTP,
    serviceCall,
  )
where

-- FUTUREWORK(federation): Once we authenticate the call, we should send authentication data
-- to brig so brig can do some authorization as required.

import Control.Exception
import Control.Lens (view)
import Control.Monad.Codensity
import Data.ByteString qualified as BS
import Data.Domain
import Data.Id
import Data.Sequence qualified as Seq
import Data.Text.Encoding qualified as Text
import Federator.Env
import Imports
import Network.HTTP.Client
import Network.HTTP.Types qualified as HTTP
import Network.HTTP.Types.Header
import Network.Wai.Utilities.Server
import Polysemy
import Polysemy.Input
import Servant.Client.Core qualified as Servant
import Servant.Types.SourceT
import Util.Options
import Wire.API.Federation.Component
import Wire.API.Federation.Domain (originDomainHeaderName)

type ServiceStreaming = Service (SourceT IO ByteString)

data Service body m a where
  -- | Returns status, headers and body, 'HTTP.Response' is not nice to work with in tests
  ServiceCall :: Component -> ByteString -> RequestHeaders -> LByteString -> Domain -> Service body m (Servant.ResponseF body)

makeSem ''Service

bodyReaderToStreamT :: (Monad m) => m ByteString -> SourceT m ByteString
bodyReaderToStreamT action = fromStepT go
  where
    go = Effect $ do
      chunk <- action
      pure $
        if BS.null chunk
          then Stop
          else Yield chunk go

-- FUTUREWORK(federation): Do we want to use servant client here? May make
-- everything typed and safe
--
-- FUTUREWORK: Avoid letting the IO errors escape into `Embed IO` and
-- return them as `Left`
--
-- FUTUREWORK: unify this interpretation with similar ones in Galley
--
interpretServiceHTTP ::
  ( Member (Embed (Codensity IO)) r,
    Member (Input Env) r,
    Member (Input RequestId) r
  ) =>
  Sem (ServiceStreaming ': r) a ->
  Sem r a
interpretServiceHTTP = interpret $ \case
  ServiceCall component rpcPath headers body domain -> do
    Endpoint serviceHost servicePort <- inputs (view service) <*> pure component
    manager <- inputs (view httpManager)
    RequestId rid <- input
    let req =
          defaultRequest
            { method = HTTP.methodPost,
              host = Text.encodeUtf8 serviceHost,
              port = fromIntegral servicePort,
              requestBody = RequestBodyLBS body,
              path = rpcPath,
              requestHeaders =
                [ ("Content-Type", "application/json"),
                  (originDomainHeaderName, Text.encodeUtf8 (domainText domain)),
                  (defaultRequestIdHeaderName, rid)
                ]
                  <> headers
            }

    embed $
      Codensity $ \k ->
        bracket (responseOpen req manager) responseClose $ \resp ->
          k $
            Servant.Response
              { Servant.responseStatusCode = responseStatus resp,
                Servant.responseHeaders = Seq.fromList (responseHeaders resp),
                Servant.responseHttpVersion = HTTP.http11,
                Servant.responseBody = bodyReaderToStreamT (responseBody resp)
              }
