{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- 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 Gundeck.Monad
  ( -- * Environment
    Env,
    reqId,
    options,
    applog,
    manager,
    cstate,
    createEnv,

    -- * Gundeck monad
    Gundeck,
    runDirect,
    runGundeck,
    posixTime,
    getRabbitMqChan,

    -- * Select which redis to target
    runWithDefaultRedis,
    runWithAdditionalRedis,
    msToUTCSecs,
  )
where

import Bilge hiding (Request, header, options, statusCode)
import Bilge.RPC
import Cassandra
import Control.Concurrent.Async (AsyncCancelled)
import Control.Exception (throwIO)
import Control.Lens (view, (.~), (^.))
import Control.Monad.Catch hiding (tryJust)
import Data.Misc (Milliseconds (..))
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.UUID as UUID
import Data.UUID.V4 as UUID
import Database.Redis qualified as Redis
import Gundeck.Env
import Gundeck.Redis qualified as Redis
import Imports
import Network.AMQP
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Utilities.Error
import Network.Wai.Utilities.Server
import Prometheus
import System.Logger (Logger)
import System.Logger qualified as Logger
import System.Logger.Class qualified as Log
import System.Timeout
import UnliftIO (async)

-- | TODO: 'Client' already has an 'Env'.  Why do we need two?  How does this even work?  We should
-- probably explain this here.
newtype Gundeck a = Gundeck
  { unGundeck :: ReaderT Env Client a
  }
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadThrow,
      MonadCatch,
      MonadMask,
      MonadReader Env,
      MonadClient,
      MonadUnliftIO
    )

-- This can be derived if we resolve the TODO above.
instance MonadMonitor Gundeck where
  doIO = liftIO

-- | 'Gundeck' doesn't have an instance for 'MonadRedis' because it contains two
-- connections to two redis instances. When using 'WithDefaultRedis', any redis
-- operation will only target the default redis instance (configured under
-- 'redis:' in the gundeck config). To write to both redises use
-- 'WithAdditionalRedis'.
newtype WithDefaultRedis a = WithDefaultRedis {runWithDefaultRedis :: Gundeck a}
  deriving newtype
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadThrow,
      MonadCatch,
      MonadMask,
      MonadReader Env,
      MonadClient,
      MonadUnliftIO,
      Log.MonadLogger
    )

instance Redis.MonadRedis WithDefaultRedis where
  liftRedis action = do
    defaultConn <- view rstate
    Redis.runRobust defaultConn action

instance Redis.RedisCtx WithDefaultRedis (Either Redis.Reply) where
  returnDecode :: (Redis.RedisResult a) => Redis.Reply -> WithDefaultRedis (Either Redis.Reply a)
  returnDecode = Redis.liftRedis . Redis.returnDecode

-- | 'Gundeck' doesn't have an instance for 'MonadRedis' because it contains two
-- connections to two redis instances. When using 'WithAdditionalRedis', any
-- redis operation will target both redis instances (configured under 'redis:'
-- and 'redisAddtionalWrite:' in the gundeck config). To write to only the
-- default redis use 'WithDefaultRedis'.
newtype WithAdditionalRedis a = WithAdditionalRedis {runWithAdditionalRedis :: Gundeck a}
  deriving newtype
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadThrow,
      MonadCatch,
      MonadMask,
      MonadReader Env,
      MonadClient,
      MonadUnliftIO,
      Log.MonadLogger
    )

instance Redis.MonadRedis WithAdditionalRedis where
  liftRedis action = do
    defaultConn <- view rstate
    ret <- Redis.runRobust defaultConn action

    mAdditionalRedisConn <- view rstateAdditionalWrite
    for_ mAdditionalRedisConn $ \additionalRedisConn ->
      -- We just fire and forget this call, as there is not much we can do if
      -- this fails.
      async $ Redis.runRobust additionalRedisConn action

    pure ret

instance Redis.RedisCtx WithAdditionalRedis (Either Redis.Reply) where
  returnDecode :: (Redis.RedisResult a) => Redis.Reply -> WithAdditionalRedis (Either Redis.Reply a)
  returnDecode = Redis.liftRedis . Redis.returnDecode

instance Log.MonadLogger Gundeck where
  log l m = do
    e <- ask
    Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m)

instance MonadHttp Gundeck where
  handleRequestWithCont req handler = do
    httpManager <- view manager
    liftIO $ withResponse req httpManager handler

instance HasRequestId Gundeck where
  getRequestId = view reqId

runGundeck :: Env -> Request -> Gundeck ResponseReceived -> IO ResponseReceived
runGundeck e r m = do
  rid <- lookupReqId e._applog r
  let e' = e & reqId .~ rid
  runDirect e' m

runDirect :: Env -> Gundeck a -> IO a
runDirect e m =
  runClient (e ^. cstate) (runReaderT (unGundeck m) e)
    `catch` ( \(exception :: SomeException) -> do
                case fromException exception of
                  Nothing ->
                    Logger.err (e ^. applog) $
                      Log.msg ("IO Exception occurred" :: ByteString)
                        . Log.field "message" (displayException exception)
                        . Log.field "request" (unRequestId (e ^. reqId))
                  Just (_ :: AsyncCancelled) -> pure ()
                throwIO exception
            )

lookupReqId :: Logger -> Request -> IO RequestId
lookupReqId l r = case lookup defaultRequestIdHeaderName (requestHeaders r) of
  Just rid -> pure $ RequestId rid
  Nothing -> do
    localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom
    Logger.info l $
      Log.field "request-id" localRid
        . Log.field "method" (requestMethod r)
        . Log.field "path" (rawPathInfo r)
        . Log.msg (Log.val "generated a new request id for local request")
    pure localRid

posixTime :: Gundeck Milliseconds
posixTime = view time >>= liftIO
{-# INLINE posixTime #-}

msToUTCSecs :: Milliseconds -> UTCTime
msToUTCSecs = posixSecondsToUTCTime . fromIntegral . (`div` 1000) . ms

getRabbitMqChan :: Gundeck Channel
getRabbitMqChan = do
  chanMVar <- view rabbitMqChannel
  mChan <- liftIO $ System.Timeout.timeout 1_000_000 $ readMVar chanMVar
  case mChan of
    Nothing -> do
      Log.err $ Log.msg (Log.val "Could not retrieve RabbitMQ channel")
      throwM $ mkError status500 "internal-server-error" "Could not retrieve RabbitMQ channel"
    Just chan -> pure chan
