module Log.Logger
( LoggerEnv(..)
, Logger
, mkLogger
, mkLogger'
, mkBulkLogger
, mkBulkLogger'
, execLogger
, waitForLogger
, shutdownLogger
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Semigroup
import Prelude
import qualified Data.Aeson.Types as A
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Log.Data
import Log.Internal.Logger
data LoggerEnv = LoggerEnv
{ LoggerEnv -> Logger
leLogger :: !Logger
, LoggerEnv -> Text
leComponent :: !T.Text
, LoggerEnv -> [Text]
leDomain :: ![T.Text]
, LoggerEnv -> [Pair]
leData :: ![A.Pair]
, LoggerEnv -> LogLevel
leMaxLogLevel :: LogLevel
}
mkLogger :: T.Text -> (LogMessage -> IO ()) -> IO Logger
mkLogger :: Text -> (LogMessage -> IO ()) -> IO Logger
mkLogger = Int -> Text -> (LogMessage -> IO ()) -> IO Logger
mkLogger' Int
defaultQueueCapacity
mkLogger' :: Int -> T.Text -> (LogMessage -> IO ()) -> IO Logger
mkLogger' :: Int -> Text -> (LogMessage -> IO ()) -> IO Logger
mkLogger' Int
cap Text
name LogMessage -> IO ()
exec = IO (TBQueue LogMessage)
-> (TBQueue LogMessage -> STM Bool)
-> (TBQueue LogMessage -> STM LogMessage)
-> (TBQueue LogMessage -> LogMessage -> STM ())
-> IO ()
-> Text
-> (LogMessage -> IO ())
-> IO ()
-> IO Logger
forall queue msgs.
IO queue
-> (queue -> STM Bool)
-> (queue -> STM msgs)
-> (queue -> LogMessage -> STM ())
-> IO ()
-> Text
-> (msgs -> IO ())
-> IO ()
-> IO Logger
mkLoggerImpl
(Natural -> IO (TBQueue LogMessage)
forall a. Natural -> IO (TBQueue a)
newTBQueueIO (Natural -> IO (TBQueue LogMessage))
-> Natural -> IO (TBQueue LogMessage)
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cap) TBQueue LogMessage -> STM Bool
forall a. TBQueue a -> STM Bool
isEmptyTBQueue TBQueue LogMessage -> STM LogMessage
forall a. TBQueue a -> STM a
readTBQueue TBQueue LogMessage -> LogMessage -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue
(() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Text
name LogMessage -> IO ()
exec (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
mkBulkLogger :: T.Text -> ([LogMessage] -> IO ()) -> IO () -> IO Logger
mkBulkLogger :: Text -> ([LogMessage] -> IO ()) -> IO () -> IO Logger
mkBulkLogger = Int -> Int -> Text -> ([LogMessage] -> IO ()) -> IO () -> IO Logger
mkBulkLogger' Int
defaultQueueCapacity Int
1000000
mkBulkLogger'
:: Int
-> Int
-> T.Text
-> ([LogMessage] -> IO ())
-> IO ()
-> IO Logger
mkBulkLogger' :: Int -> Int -> Text -> ([LogMessage] -> IO ()) -> IO () -> IO Logger
mkBulkLogger' Int
cap Int
dur = IO (SBQueue LogMessage)
-> (SBQueue LogMessage -> STM Bool)
-> (SBQueue LogMessage -> STM [LogMessage])
-> (SBQueue LogMessage -> LogMessage -> STM ())
-> IO ()
-> Text
-> ([LogMessage] -> IO ())
-> IO ()
-> IO Logger
forall queue msgs.
IO queue
-> (queue -> STM Bool)
-> (queue -> STM msgs)
-> (queue -> LogMessage -> STM ())
-> IO ()
-> Text
-> (msgs -> IO ())
-> IO ()
-> IO Logger
mkLoggerImpl
(Int -> IO (SBQueue LogMessage)
forall a. Int -> IO (SBQueue a)
newSBQueueIO Int
cap) SBQueue LogMessage -> STM Bool
forall a. SBQueue a -> STM Bool
isEmptySBQueue SBQueue LogMessage -> STM [LogMessage]
forall a. SBQueue a -> STM [a]
readSBQueue SBQueue LogMessage -> LogMessage -> STM ()
forall a. SBQueue a -> a -> STM ()
writeSBQueue
(Int -> IO ()
threadDelay Int
dur)
defaultQueueCapacity :: Int
defaultQueueCapacity :: Int
defaultQueueCapacity = Int
1000000
data SBQueue a = SBQueue !(TVar [a]) !(TVar Int) !Int
newSBQueueIO :: Int -> IO (SBQueue a)
newSBQueueIO :: Int -> IO (SBQueue a)
newSBQueueIO Int
capacity = TVar [a] -> TVar Int -> Int -> SBQueue a
forall a. TVar [a] -> TVar Int -> Int -> SBQueue a
SBQueue (TVar [a] -> TVar Int -> Int -> SBQueue a)
-> IO (TVar [a]) -> IO (TVar Int -> Int -> SBQueue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> IO (TVar [a])
forall a. a -> IO (TVar a)
newTVarIO [] IO (TVar Int -> Int -> SBQueue a)
-> IO (TVar Int) -> IO (Int -> SBQueue a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0 IO (Int -> SBQueue a) -> IO Int -> IO (SBQueue a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
capacity
isEmptySBQueue :: SBQueue a -> STM Bool
isEmptySBQueue :: SBQueue a -> STM Bool
isEmptySBQueue (SBQueue TVar [a]
queue TVar Int
count Int
_capacity) = do
Bool
isEmpty <- [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> STM [a] -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
queue
Int
numElems <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
count
Bool -> STM Bool -> STM Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (if Bool
isEmpty then Int
numElems Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 else Int
numElems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (STM Bool -> STM Bool) -> STM Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
isEmpty
readSBQueue :: SBQueue a -> STM [a]
readSBQueue :: SBQueue a -> STM [a]
readSBQueue (SBQueue TVar [a]
queue TVar Int
count Int
_capacity) = do
[a]
elems <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
queue
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
elems) STM ()
forall a. STM a
retry
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
queue []
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
count Int
0
[a] -> STM [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> STM [a]) -> [a] -> STM [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
elems
writeSBQueue :: SBQueue a -> a -> STM ()
writeSBQueue :: SBQueue a -> a -> STM ()
writeSBQueue (SBQueue TVar [a]
queue TVar Int
count Int
capacity) a
a = do
Int
numElems <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
count
if Int
numElems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
capacity
then do TVar [a] -> ([a] -> [a]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [a]
queue (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
count (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
else () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkLoggerImpl :: IO queue
-> (queue -> STM Bool)
-> (queue -> STM msgs)
-> (queue -> LogMessage -> STM ())
-> IO ()
-> T.Text
-> (msgs -> IO ())
-> IO ()
-> IO Logger
mkLoggerImpl :: IO queue
-> (queue -> STM Bool)
-> (queue -> STM msgs)
-> (queue -> LogMessage -> STM ())
-> IO ()
-> Text
-> (msgs -> IO ())
-> IO ()
-> IO Logger
mkLoggerImpl IO queue
newQueue queue -> STM Bool
isQueueEmpty queue -> STM msgs
readQueue queue -> LogMessage -> STM ()
writeQueue IO ()
afterExecDo
Text
name msgs -> IO ()
exec IO ()
sync = do
queue
queue <- IO queue
newQueue
TVar Bool
inProgress <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
TVar Bool
isRunning <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
ThreadId
tid <- IO Any -> (Either SomeException Any -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ queue -> TVar Bool -> IO ()
loop queue
queue TVar Bool
inProgress)
(\Either SomeException Any
_ -> queue -> TVar Bool -> IO ()
cleanup queue
queue TVar Bool
inProgress)
Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return Logger :: (LogMessage -> IO ()) -> IO () -> IO () -> Logger
Logger {
loggerWriteMessage :: LogMessage -> IO ()
loggerWriteMessage = \LogMessage
msg -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TVar Bool -> STM ()
checkIsRunning TVar Bool
isRunning
queue -> LogMessage -> STM ()
writeQueue queue
queue LogMessage
msg,
loggerWaitForWrite :: IO ()
loggerWaitForWrite = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ queue -> TVar Bool -> STM ()
waitForWrite queue
queue TVar Bool
inProgress
IO ()
sync,
loggerShutdown :: IO ()
loggerShutdown = do
ThreadId -> IO ()
killThread ThreadId
tid
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
isRunning Bool
False
}
where
checkIsRunning :: TVar Bool -> STM ()
checkIsRunning TVar Bool
isRunning' = do
Bool
isRunning <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
isRunning'
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isRunning) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
AssertionFailed -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (String -> AssertionFailed
AssertionFailed (String -> AssertionFailed) -> String -> AssertionFailed
forall a b. (a -> b) -> a -> b
$ String
"Log.Logger.mkLoggerImpl: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"attempt to write to a shut down logger")
loop :: queue -> TVar Bool -> IO ()
loop queue
queue TVar Bool
inProgress = do
queue -> TVar Bool -> IO ()
step queue
queue TVar Bool
inProgress
IO ()
afterExecDo
step :: queue -> TVar Bool -> IO ()
step queue
queue TVar Bool
inProgress = do
msgs
msgs <- STM msgs -> IO msgs
forall a. STM a -> IO a
atomically (STM msgs -> IO msgs) -> STM msgs -> IO msgs
forall a b. (a -> b) -> a -> b
$ do
TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
inProgress Bool
True
queue -> STM msgs
readQueue queue
queue
msgs -> IO ()
exec msgs
msgs
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
inProgress Bool
False
cleanup :: queue -> TVar Bool -> IO ()
cleanup queue
queue TVar Bool
inProgress = do
queue -> TVar Bool -> IO ()
step queue
queue TVar Bool
inProgress
IO ()
sync
IO ()
printLoggerTerminated
waitForWrite :: queue -> TVar Bool -> STM ()
waitForWrite queue
queue TVar Bool
inProgress = do
Bool
isEmpty <- queue -> STM Bool
isQueueEmpty queue
queue
Bool
isInProgress <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
inProgress
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isEmpty Bool -> Bool -> Bool
|| Bool
isInProgress) STM ()
forall a. STM a
retry
printLoggerTerminated :: IO ()
printLoggerTerminated = Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": logger thread terminated"