{-# LANGUAGE RecordWildCards #-}

-- 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 Wire.Sem.Logger.TinyLog
  ( loggerToTinyLog,
    loggerToTinyLogReqId,
    stringLoggerToTinyLog,
    discardTinyLogs,
    module Wire.Sem.Logger.Level,
    LogRecorder (..),
    newLogRecorder,
    recordLogs,
  )
where

import Data.Id
import Imports
import Polysemy
import Polysemy.TinyLog (TinyLog)
import qualified System.Logger as Log
import Wire.Sem.Logger
import Wire.Sem.Logger.Level

loggerToTinyLog ::
  (Member (Embed IO) r) =>
  Log.Logger ->
  Sem (Logger (Log.Msg -> Log.Msg) ': r) a ->
  Sem r a
loggerToTinyLog :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
Logger -> Sem (Logger (Msg -> Msg) : r) a -> Sem r a
loggerToTinyLog Logger
tinylog = (forall (rInitial :: EffectRow) x.
 Logger (Msg -> Msg) (Sem rInitial) x -> Sem r x)
-> Sem (Logger (Msg -> Msg) : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Logger (Msg -> Msg) (Sem rInitial) x -> Sem r x)
 -> Sem (Logger (Msg -> Msg) : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Logger (Msg -> Msg) (Sem rInitial) x -> Sem r x)
-> Sem (Logger (Msg -> Msg) : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Log Level
lvl Msg -> Msg
msg ->
    forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed @IO (IO x -> Sem r x) -> IO x -> Sem r x
forall a b. (a -> b) -> a -> b
$ Logger -> Level -> (Msg -> Msg) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
Log.log Logger
tinylog (Level -> Level
toLevel Level
lvl) Msg -> Msg
msg

-- | Log the request ID along with the message
loggerToTinyLogReqId ::
  (Member (Embed IO) r) =>
  RequestId ->
  Log.Logger ->
  Sem (TinyLog ': r) a ->
  Sem r a
loggerToTinyLogReqId :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
RequestId -> Logger -> Sem (Logger (Msg -> Msg) : r) a -> Sem r a
loggerToTinyLogReqId RequestId
r Logger
tinylog =
  Logger -> Sem (Logger (Msg -> Msg) : r) a -> Sem r a
forall (r :: EffectRow) a.
Member (Embed IO) r =>
Logger -> Sem (Logger (Msg -> Msg) : r) a -> Sem r a
loggerToTinyLog Logger
tinylog
    (Sem (Logger (Msg -> Msg) : r) a -> Sem r a)
-> (Sem (Logger (Msg -> Msg) : r) a
    -> Sem (Logger (Msg -> Msg) : r) a)
-> Sem (Logger (Msg -> Msg) : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Msg -> Msg) -> Msg -> Msg)
-> Sem (Logger (Msg -> Msg) : Logger (Msg -> Msg) : r) a
-> Sem (Logger (Msg -> Msg) : r) a
forall msg msg' (r :: EffectRow) a.
Member (Logger msg') r =>
(msg -> msg') -> Sem (Logger msg : r) a -> Sem r a
mapLogger (ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"request" (RequestId -> ByteString
unRequestId RequestId
r) (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
    (Sem (Logger (Msg -> Msg) : Logger (Msg -> Msg) : r) a
 -> Sem (Logger (Msg -> Msg) : r) a)
-> (Sem (Logger (Msg -> Msg) : r) a
    -> Sem (Logger (Msg -> Msg) : Logger (Msg -> Msg) : r) a)
-> Sem (Logger (Msg -> Msg) : r) a
-> Sem (Logger (Msg -> Msg) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder @TinyLog

stringLoggerToTinyLog :: (Member (Logger (Log.Msg -> Log.Msg)) r) => Sem (Logger String ': r) a -> Sem r a
stringLoggerToTinyLog :: forall (r :: EffectRow) a.
Member (Logger (Msg -> Msg)) r =>
Sem (Logger String : r) a -> Sem r a
stringLoggerToTinyLog = forall msg msg' (r :: EffectRow) a.
Member (Logger msg') r =>
(msg -> msg') -> Sem (Logger msg : r) a -> Sem r a
mapLogger @String String -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg

discardTinyLogs :: Sem (Logger (Log.Msg -> Log.Msg) ': r) a -> Sem r a
discardTinyLogs :: forall (r :: EffectRow) a.
Sem (Logger (Msg -> Msg) : r) a -> Sem r a
discardTinyLogs = Sem (Logger (Msg -> Msg) : r) a -> Sem r a
forall msg (r :: EffectRow) a. Sem (Logger msg : r) a -> Sem r a
discardLogs

newtype LogRecorder = LogRecorder {LogRecorder -> IORef [(Level, LByteString)]
recordedLogs :: IORef [(Level, LByteString)]}

newLogRecorder :: IO LogRecorder
newLogRecorder :: IO LogRecorder
newLogRecorder = IORef [(Level, LByteString)] -> LogRecorder
LogRecorder (IORef [(Level, LByteString)] -> LogRecorder)
-> IO (IORef [(Level, LByteString)]) -> IO LogRecorder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Level, LByteString)] -> IO (IORef [(Level, LByteString)])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []

recordLogs :: (Member (Embed IO) r) => LogRecorder -> Sem (TinyLog ': r) a -> Sem r a
recordLogs :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
LogRecorder -> Sem (Logger (Msg -> Msg) : r) a -> Sem r a
recordLogs LogRecorder {IORef [(Level, LByteString)]
$sel:recordedLogs:LogRecorder :: LogRecorder -> IORef [(Level, LByteString)]
recordedLogs :: IORef [(Level, LByteString)]
..} = (forall (rInitial :: EffectRow) x.
 Logger (Msg -> Msg) (Sem rInitial) x -> Sem r x)
-> Sem (Logger (Msg -> Msg) : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Logger (Msg -> Msg) (Sem rInitial) x -> Sem r x)
 -> Sem (Logger (Msg -> Msg) : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Logger (Msg -> Msg) (Sem rInitial) x -> Sem r x)
-> Sem (Logger (Msg -> Msg) : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \(Log Level
lvl Msg -> Msg
msg) ->
  IORef [(Level, LByteString)]
-> ([(Level, LByteString)] -> [(Level, LByteString)]) -> Sem r ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef [(Level, LByteString)]
recordedLogs ([(Level, LByteString)]
-> [(Level, LByteString)] -> [(Level, LByteString)]
forall a. [a] -> [a] -> [a]
++ [(Level
lvl, ([Element] -> Builder) -> (Msg -> Msg) -> LByteString
Log.render (ByteString -> [Element] -> Builder
Log.renderDefault ByteString
", ") Msg -> Msg
msg)])