{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- 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 Stern.App where

import Bilge qualified
import Bilge.RPC (HasRequestId (..))
import Control.Error
import Control.Lens (lensField, lensRules, makeLensesWith, (.~))
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class
import Data.ByteString.Conversion (toByteString')
import Data.Id
import Data.Text qualified as Text
import Data.Text.Encoding (encodeUtf8)
import Imports
import Network.HTTP.Client (responseTimeoutMicro)
import Network.Wai (Response, ResponseReceived)
import Network.Wai.Utilities (Error (..))
import Servant.Client qualified as SC
import Stern.Options as Opts
import System.Logger qualified as Log
import System.Logger.Class hiding (Error, info)
import System.Logger.Class qualified as LC
import System.Logger.Extended qualified as Log
import Util.Options
import Util.SuffixNamer

data Env = Env
  { brig :: !Bilge.Request,
    galley :: !Bilge.Request,
    gundeck :: !Bilge.Request,
    ibis :: !Bilge.Request,
    galeb :: !Bilge.Request,
    appLogger :: !Logger,
    requestId :: !Bilge.RequestId,
    httpManager :: !Bilge.Manager,
    brigServantClientEnv :: !SC.ClientEnv
  }

makeLensesWith (lensRules & lensField .~ suffixNamer) ''Env

newEnv :: Opts -> IO Env
newEnv opts = do
  l <- Log.mkLogger opts.logLevel opts.logNetStrings opts.logFormat
  manager <- newManager
  pure $
    Env
      (mkRequest opts.brig)
      (mkRequest opts.galley)
      (mkRequest opts.gundeck)
      (mkRequest opts.ibis)
      (mkRequest opts.galeb)
      l
      (RequestId defRequestId)
      manager
      (mkClientEnv manager)
  where
    mkRequest :: Endpoint -> Bilge.Request
    mkRequest s = Bilge.host (encodeUtf8 s.host) . Bilge.port s.port $ Bilge.empty

    newManager :: IO Bilge.Manager
    newManager = Bilge.newManager (Bilge.defaultManagerSettings {Bilge.managerResponseTimeout = responseTimeoutMicro 10000000})

    mkClientEnv :: Bilge.Manager -> SC.ClientEnv
    mkClientEnv manager =
      let url = SC.BaseUrl SC.Http (Text.unpack opts.brig.host) (fromIntegral opts.brig.port) ""
       in SC.mkClientEnv manager url

-- Monads
newtype AppT m a = AppT (ReaderT Env m a)
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadThrow,
      MonadCatch,
      MonadReader Env
    )

deriving instance MonadUnliftIO App

type App = AppT IO

instance (MonadIO m) => MonadLogger (AppT m) where
  log l m = do
    g <- asks (.appLogger)
    r <- asks (.requestId)
    Log.log g l $ "request" .= Bilge.unRequestId r ~~ m

instance MonadLogger (ExceptT e App) where
  log l m = lift (LC.log l m)

instance (MonadIO m) => Bilge.MonadHttp (AppT m) where
  handleRequestWithCont req h = do
    m <- asks (.httpManager)
    liftIO $ Bilge.withResponse req m h

instance (Monad m) => HasRequestId (AppT m) where
  getRequestId = asks (.requestId)

instance HasRequestId (ExceptT e App) where
  getRequestId = asks (.requestId)

instance Bilge.MonadHttp (ExceptT e App) where
  handleRequestWithCont req h = do
    m <- asks (.httpManager)
    liftIO $ Bilge.withResponse req m h

runAppT :: Env -> AppT m a -> m a
runAppT e (AppT ma) = runReaderT ma e

-------------------------------------------------------------------------------
-- Handler Monad

type Handler = ExceptT Error App

runHandler :: Env -> Handler a -> IO (Either Error a)
runHandler env = runAppT env . runExceptT

type Continue m = Response -> m ResponseReceived

userMsg :: UserId -> Msg -> Msg
userMsg = field "user" . toByteString'
