module Logger
(
  Logger,
  LogRecord,
  LogQueue,
  LogLevel(..),
  newLogger,
  postLog,
  postLogBlocking,
  postStop,
  processLogRecords,
  loggerSentryService
)
where

import SentryLogging (getCrashLogger, logCrashMessage)
import Config (Config, configSentryDSN, configDisableSentryLogging, configQueueCapacity)

import Control.Monad (unless, when, forM_)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueue, readTBQueue, writeTBQueue, isFullTBQueue)
import Data.Text (Text, unpack)
import Prelude hiding (log)

import qualified System.Log.Raven.Types as Sentry

import qualified Data.Text.IO as T

type LogRecord = Text

data LogLevel = LogInfo | LogError
  deriving (LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c== :: LogLevel -> LogLevel -> Bool
Eq, Eq LogLevel
Eq LogLevel
-> (LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmax :: LogLevel -> LogLevel -> LogLevel
>= :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c< :: LogLevel -> LogLevel -> Bool
compare :: LogLevel -> LogLevel -> Ordering
$ccompare :: LogLevel -> LogLevel -> Ordering
$cp1Ord :: Eq LogLevel
Ord, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> String
$cshow :: LogLevel -> String
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show, ReadPrec [LogLevel]
ReadPrec LogLevel
Int -> ReadS LogLevel
ReadS [LogLevel]
(Int -> ReadS LogLevel)
-> ReadS [LogLevel]
-> ReadPrec LogLevel
-> ReadPrec [LogLevel]
-> Read LogLevel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LogLevel]
$creadListPrec :: ReadPrec [LogLevel]
readPrec :: ReadPrec LogLevel
$creadPrec :: ReadPrec LogLevel
readList :: ReadS [LogLevel]
$creadList :: ReadS [LogLevel]
readsPrec :: Int -> ReadS LogLevel
$creadsPrec :: Int -> ReadS LogLevel
Read)

type LogQueue = TBQueue LogCommand

data Logger = Logger { Logger -> LogQueue
loggerQueue :: LogQueue, Logger -> Maybe SentryService
loggerSentryService :: Maybe Sentry.SentryService }

data LogCommand = LogRecord LogLevel LogRecord | LogStop
  deriving (LogCommand -> LogCommand -> Bool
(LogCommand -> LogCommand -> Bool)
-> (LogCommand -> LogCommand -> Bool) -> Eq LogCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogCommand -> LogCommand -> Bool
$c/= :: LogCommand -> LogCommand -> Bool
== :: LogCommand -> LogCommand -> Bool
$c== :: LogCommand -> LogCommand -> Bool
Eq, Eq LogCommand
Eq LogCommand
-> (LogCommand -> LogCommand -> Ordering)
-> (LogCommand -> LogCommand -> Bool)
-> (LogCommand -> LogCommand -> Bool)
-> (LogCommand -> LogCommand -> Bool)
-> (LogCommand -> LogCommand -> Bool)
-> (LogCommand -> LogCommand -> LogCommand)
-> (LogCommand -> LogCommand -> LogCommand)
-> Ord LogCommand
LogCommand -> LogCommand -> Bool
LogCommand -> LogCommand -> Ordering
LogCommand -> LogCommand -> LogCommand
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogCommand -> LogCommand -> LogCommand
$cmin :: LogCommand -> LogCommand -> LogCommand
max :: LogCommand -> LogCommand -> LogCommand
$cmax :: LogCommand -> LogCommand -> LogCommand
>= :: LogCommand -> LogCommand -> Bool
$c>= :: LogCommand -> LogCommand -> Bool
> :: LogCommand -> LogCommand -> Bool
$c> :: LogCommand -> LogCommand -> Bool
<= :: LogCommand -> LogCommand -> Bool
$c<= :: LogCommand -> LogCommand -> Bool
< :: LogCommand -> LogCommand -> Bool
$c< :: LogCommand -> LogCommand -> Bool
compare :: LogCommand -> LogCommand -> Ordering
$ccompare :: LogCommand -> LogCommand -> Ordering
$cp1Ord :: Eq LogCommand
Ord, Int -> LogCommand -> ShowS
[LogCommand] -> ShowS
LogCommand -> String
(Int -> LogCommand -> ShowS)
-> (LogCommand -> String)
-> ([LogCommand] -> ShowS)
-> Show LogCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogCommand] -> ShowS
$cshowList :: [LogCommand] -> ShowS
show :: LogCommand -> String
$cshow :: LogCommand -> String
showsPrec :: Int -> LogCommand -> ShowS
$cshowsPrec :: Int -> LogCommand -> ShowS
Show, ReadPrec [LogCommand]
ReadPrec LogCommand
Int -> ReadS LogCommand
ReadS [LogCommand]
(Int -> ReadS LogCommand)
-> ReadS [LogCommand]
-> ReadPrec LogCommand
-> ReadPrec [LogCommand]
-> Read LogCommand
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LogCommand]
$creadListPrec :: ReadPrec [LogCommand]
readPrec :: ReadPrec LogCommand
$creadPrec :: ReadPrec LogCommand
readList :: ReadS [LogCommand]
$creadList :: ReadS [LogCommand]
readsPrec :: Int -> ReadS LogCommand
$creadsPrec :: Int -> ReadS LogCommand
Read)

newLogger :: Config -> IO Logger
newLogger :: Config -> IO Logger
newLogger Config
config = LogQueue -> Maybe SentryService -> Logger
Logger
  (LogQueue -> Maybe SentryService -> Logger)
-> IO LogQueue -> IO (Maybe SentryService -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LogQueue
forall a. IO (TBQueue a)
createQueue
  IO (Maybe SentryService -> Logger)
-> IO (Maybe SentryService) -> IO Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Maybe SentryService)
createSentryService
  where
    createQueue :: IO (TBQueue a)
createQueue = STM (TBQueue a) -> IO (TBQueue a)
forall a. STM a -> IO a
atomically (Natural -> STM (TBQueue a)
forall a. Natural -> STM (TBQueue a)
newTBQueue (Word -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Natural) -> Word -> Natural
forall a b. (a -> b) -> a -> b
$ Config -> Word
configQueueCapacity Config
config))
    createSentryService :: IO (Maybe SentryService)
createSentryService
      | Config -> Bool
configDisableSentryLogging Config
config = Maybe SentryService -> IO (Maybe SentryService)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SentryService
forall a. Maybe a
Nothing
      | Bool
otherwise = (String -> IO SentryService)
-> Maybe String -> IO (Maybe SentryService)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO SentryService
getCrashLogger (Config -> Maybe String
configSentryDSN Config
config)

-- | Post a non-essential log message to the queue. The message is discarded
-- when the queue is full.
postLog :: Logger -> LogLevel -> LogRecord -> IO ()
postLog :: Logger -> LogLevel -> LogRecord -> IO ()
postLog Logger
logger LogLevel
level LogRecord
record = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
isFull <- LogQueue -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue (Logger -> LogQueue
loggerQueue Logger
logger)
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isFull (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ LogQueue -> LogCommand -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Logger -> LogQueue
loggerQueue Logger
logger) (LogLevel -> LogRecord -> LogCommand
LogRecord LogLevel
level LogRecord
record)

-- | Post an essential log message to the queue. This function blocks when the
-- queue is full.
postLogBlocking :: Logger -> LogLevel -> LogRecord -> IO ()
postLogBlocking :: Logger -> LogLevel -> LogRecord -> IO ()
postLogBlocking Logger
logger LogLevel
level LogRecord
record = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
  LogQueue -> LogCommand -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Logger -> LogQueue
loggerQueue Logger
logger) (LogLevel -> LogRecord -> LogCommand
LogRecord LogLevel
level LogRecord
record)

postStop :: Logger -> IO ()
postStop :: Logger -> IO ()
postStop Logger
logger = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogQueue -> LogCommand -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Logger -> LogQueue
loggerQueue Logger
logger) LogCommand
LogStop

processLogRecords :: Logger -> IO ()
processLogRecords :: Logger -> IO ()
processLogRecords Logger
logger = IO ()
go
  where
    go :: IO ()
go = do
      LogCommand
cmd <- STM LogCommand -> IO LogCommand
forall a. STM a -> IO a
atomically (STM LogCommand -> IO LogCommand)
-> STM LogCommand -> IO LogCommand
forall a b. (a -> b) -> a -> b
$ LogQueue -> STM LogCommand
forall a. TBQueue a -> STM a
readTBQueue (Logger -> LogQueue
loggerQueue Logger
logger)
      case LogCommand
cmd of
        LogRecord LogLevel
logLevel LogRecord
logRecord -> do
          LogRecord -> IO ()
T.putStrLn LogRecord
logRecord
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
LogError) (
              Maybe SentryService -> (SentryService -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
                (Logger -> Maybe SentryService
loggerSentryService Logger
logger)
                (\SentryService
service -> String -> SentryService -> String -> IO ()
logCrashMessage String
"Icepeak" SentryService
service (LogRecord -> String
unpack LogRecord
logRecord))
            )
          IO ()
go
        -- stop the loop when asked so
        LogCommand
LogStop -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()