{-# LANGUAGE BangPatterns #-}
module EasyLogger.LoggerSet
  ( Logger(..)
  , LoggerSet(..)
  , BufSize
  , newFileLoggerSet
  , newFileLoggerSetSameFile
  , newStdoutLoggerSet
  , newStderrLoggerSet
  , newFDLoggerSet
  , toBufIOWith
  , write
  , writeLogStr
  , flushLog
  , rmLoggerSet
  , flushLoggerSet
  ) where

import           Control.Concurrent            (getNumCapabilities)
import           Control.Concurrent.MVar
import           Control.Debounce              (debounceAction, defaultDebounceSettings,
                                                mkDebounce)
import           Control.Monad                 (replicateM, when)
import           Data.Array                    (Array, bounds, listArray, (!))
import           Data.ByteString.Builder
import           Data.ByteString.Builder.Extra (Next (..))
import qualified Data.ByteString.Builder.Extra as BBE
import           Data.ByteString.Internal
import           Data.IORef
import           Data.Maybe                    (isJust)
import           Data.Word
import           Foreign.ForeignPtr            (withForeignPtr)
import           Foreign.Marshal.Alloc         (free, mallocBytes)
import           Foreign.Ptr                   (Ptr, plusPtr)
import           GHC.IO.Device                 (close)
import           GHC.IO.FD                     (FD, openFile, stderr, stdout,
                                                writeRawBufferPtr)
import           GHC.IO.IOMode                 (IOMode (..))

import           EasyLogger.LogStr

-- | The type for buffer size of each core.
type BufSize = Int
type Buffer = Ptr Word8

data Logger = Logger !BufSize (MVar Buffer) (IORef LogStr)

newLogger :: BufSize -> IO Logger
newLogger :: BufSize -> IO Logger
newLogger BufSize
size = BufSize -> MVar Buffer -> IORef LogStr -> Logger
Logger BufSize
size (MVar Buffer -> IORef LogStr -> Logger)
-> IO (MVar Buffer) -> IO (IORef LogStr -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BufSize -> IO Buffer
forall a. BufSize -> IO (Ptr a)
mallocBytes BufSize
size IO Buffer -> (Buffer -> IO (MVar Buffer)) -> IO (MVar Buffer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO (MVar Buffer)
forall a. a -> IO (MVar a)
newMVar) IO (IORef LogStr -> Logger) -> IO (IORef LogStr) -> IO Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LogStr -> IO (IORef LogStr)
forall a. a -> IO (IORef a)
newIORef LogStr
forall a. Monoid a => a
mempty

-- | A set of loggers.
--   The number of loggers is the capabilities of GHC RTS.
--   You can specify it with \"+RTS -N\<x\>\".
--   A buffer is prepared for each capability.
data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD) (Array Int Logger) (IO ())

-- | Creating a new 'LoggerSet' using a file.
newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
size FilePath
file = IO FD
openFileFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file)
  where
    openFileFD :: IO FD
openFileFD = (FD, IODeviceType) -> FD
forall a b. (a, b) -> a
fst ((FD, IODeviceType) -> FD) -> IO (FD, IODeviceType) -> IO FD
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IOMode -> Bool -> IO (FD, IODeviceType)
openFile FilePath
file IOMode
AppendMode Bool
False

-- | Creating a new 'LoggerSet' using a file.
newFileLoggerSetSameFile :: BufSize -> LoggerSet -> IO LoggerSet
newFileLoggerSetSameFile :: BufSize -> LoggerSet -> IO LoggerSet
newFileLoggerSetSameFile BufSize
size (LoggerSet Maybe FilePath
mFp IORef FD
ioRefFD Array BufSize Logger
_ IO ()
_) = IORef FD -> IO FD
forall a. IORef a -> IO a
readIORef IORef FD
ioRefFD IO FD -> (FD -> IO LoggerSet) -> IO LoggerSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe FilePath
mFp


-- | Creating a new 'LoggerSet' using stdout.
newStdoutLoggerSet :: BufSize -> IO LoggerSet
newStdoutLoggerSet :: BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
size = BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe FilePath
forall a. Maybe a
Nothing FD
stdout

-- | Creating a new 'LoggerSet' using stderr.
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet :: BufSize -> IO LoggerSet
newStderrLoggerSet BufSize
size = BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe FilePath
forall a. Maybe a
Nothing FD
stderr

-- | Creating a new 'LoggerSet' using a FD.
newFDLoggerSet :: BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet :: BufSize -> Maybe FilePath -> FD -> IO LoggerSet
newFDLoggerSet BufSize
size Maybe FilePath
mfile FD
fd = do
    BufSize
n <- IO BufSize
getNumCapabilities
    [Logger]
loggers <- BufSize -> IO Logger -> IO [Logger]
forall (m :: * -> *) a. Applicative m => BufSize -> m a -> m [a]
replicateM BufSize
n (IO Logger -> IO [Logger]) -> IO Logger -> IO [Logger]
forall a b. (a -> b) -> a -> b
$ BufSize -> IO Logger
newLogger (BufSize -> BufSize -> BufSize
forall a. Ord a => a -> a -> a
max BufSize
1 BufSize
size)
    let arr :: Array BufSize Logger
arr = (BufSize, BufSize) -> [Logger] -> Array BufSize Logger
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (BufSize
0,BufSize
nBufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
-BufSize
1) [Logger]
loggers
    IORef FD
fref <- FD -> IO (IORef FD)
forall a. a -> IO (IORef a)
newIORef FD
fd
    IO ()
flush <- DebounceSettings -> IO (IO ())
mkDebounce DebounceSettings
defaultDebounceSettings
        { debounceAction :: IO ()
debounceAction = IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fref Array BufSize Logger
arr
        }
    LoggerSet -> IO LoggerSet
forall (m :: * -> *) a. Monad m => a -> m a
return (LoggerSet -> IO LoggerSet) -> LoggerSet -> IO LoggerSet
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> IORef FD -> Array BufSize Logger -> IO () -> LoggerSet
LoggerSet Maybe FilePath
mfile IORef FD
fref Array BufSize Logger
arr IO ()
flush


flushLogStrRaw :: IORef FD -> Array Int Logger -> IO ()
flushLogStrRaw :: IORef FD -> Array BufSize Logger -> IO ()
flushLogStrRaw IORef FD
fdref Array BufSize Logger
arr = do
    let (BufSize
l,BufSize
u) = Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
flushIt [BufSize
l .. BufSize
u]
  where
    flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)


flushLog :: IORef FD -> Logger -> IO ()
flushLog :: IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Logger BufSize
size MVar Buffer
mbuf IORef LogStr
lref) = do
    LogStr
logmsg <- IORef LogStr -> (LogStr -> (LogStr, LogStr)) -> IO LogStr
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LogStr
lref (\LogStr
old -> (LogStr
forall a. Monoid a => a
mempty, LogStr
old))
    -- If a special buffer is prepared for flusher, this MVar could
    -- be removed. But such a code does not contribute logging speed
    -- according to experiment. And even with the special buffer,
    -- there is no grantee that this function is exclusively called
    -- for a buffer. So, we use MVar here.
    -- This is safe and speed penalty can be ignored.
    MVar Buffer -> (Buffer -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mbuf ((Buffer -> IO ()) -> IO ()) -> (Buffer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Buffer
buf -> IORef FD -> Buffer -> BufSize -> LogStr -> IO ()
writeLogStr IORef FD
fdref Buffer
buf BufSize
size LogStr
logmsg


-- | Writting 'LogStr' using a buffer in blocking mode.
--   The size of 'LogStr' must be smaller or equal to
--   the size of buffer.
writeLogStr :: IORef FD
            -> Buffer
            -> BufSize
            -> LogStr
            -> IO ()
writeLogStr :: IORef FD -> Buffer -> BufSize -> LogStr -> IO ()
writeLogStr IORef FD
fdref Buffer
buf BufSize
size (LogStr BufSize
len Builder
builder)
  | BufSize
size BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
len = FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"writeLogStr"
  | Bool
otherwise  = Buffer
-> BufSize -> (Buffer -> BufSize -> IO ()) -> Builder -> IO ()
toBufIOWith Buffer
buf BufSize
size (IORef FD -> Buffer -> BufSize -> IO ()
write IORef FD
fdref) Builder
builder

write :: IORef FD -> Buffer -> Int -> IO ()
write :: IORef FD -> Buffer -> BufSize -> IO ()
write IORef FD
fdref Buffer
buf BufSize
len' = Buffer -> BufSize -> IO ()
loop Buffer
buf (BufSize -> BufSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral BufSize
len')
  where
    loop :: Buffer -> BufSize -> IO ()
loop Buffer
bf !BufSize
len = do
        BufSize
written <- IORef FD -> Buffer -> BufSize -> IO BufSize
writeRawBufferPtr2FD IORef FD
fdref Buffer
bf BufSize
len
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufSize
written BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Buffer -> BufSize -> IO ()
loop (Buffer
bf Buffer -> BufSize -> Buffer
forall a b. Ptr a -> BufSize -> Ptr b
`plusPtr` BufSize -> BufSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral BufSize
written) (BufSize
len BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
- BufSize
written)

writeRawBufferPtr2FD :: IORef FD -> Ptr Word8 -> Int -> IO Int
writeRawBufferPtr2FD :: IORef FD -> Buffer -> BufSize -> IO BufSize
writeRawBufferPtr2FD IORef FD
fdref Buffer
bf BufSize
len = do
    FD
fd <- IORef FD -> IO FD
forall a. IORef a -> IO a
readIORef IORef FD
fdref
    CInt -> BufSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> BufSize) -> IO CInt -> IO BufSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FD -> Buffer -> BufSize -> CSize -> IO CInt
writeRawBufferPtr FilePath
"write" FD
fd Buffer
bf BufSize
0 (BufSize -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral BufSize
len)


toBufIOWith :: Buffer -> BufSize -> (Buffer -> Int -> IO ()) -> Builder -> IO ()
toBufIOWith :: Buffer
-> BufSize -> (Buffer -> BufSize -> IO ()) -> Builder -> IO ()
toBufIOWith Buffer
buf !BufSize
size Buffer -> BufSize -> IO ()
io Builder
builder = BufferWriter -> IO ()
loop (BufferWriter -> IO ()) -> BufferWriter -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> BufferWriter
BBE.runBuilder Builder
builder
  where
    loop :: BufferWriter -> IO ()
loop BufferWriter
writer = do
        (BufSize
len, Next
next) <- BufferWriter
writer Buffer
buf BufSize
size
        Buffer -> BufSize -> IO ()
io Buffer
buf BufSize
len
        case Next
next of
             Next
Done -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             More BufSize
minSize BufferWriter
writer'
               | BufSize
size BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
minSize -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"toBufIOWith: More: minSize"
               | Bool
otherwise      -> BufferWriter -> IO ()
loop BufferWriter
writer'
             Chunk (PS ForeignPtr Word8
fptr BufSize
off BufSize
siz) BufferWriter
writer' ->
               ForeignPtr Word8 -> (Buffer -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Buffer -> IO ()) -> IO ()) -> (Buffer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Buffer
ptr -> Buffer -> BufSize -> IO ()
io (Buffer
ptr Buffer -> BufSize -> Buffer
forall a b. Ptr a -> BufSize -> Ptr b
`plusPtr` BufSize
off) BufSize
siz IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BufferWriter -> IO ()
loop BufferWriter
writer'

-- | Flushing the buffers.
flushLoggerSet :: LoggerSet -> IO ()
flushLoggerSet :: LoggerSet -> IO ()
flushLoggerSet (LoggerSet Maybe FilePath
_ IORef FD
fdref Array BufSize Logger
arr IO ()
_) = do
    let (BufSize
l,BufSize
u) = Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
    let nums :: [BufSize]
nums = [BufSize
l .. BufSize
u]
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
flushIt [BufSize]
nums
  where
    flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)


-- | Flushing the buffers, closing the internal file information
--   and freeing the buffers.
rmLoggerSet :: LoggerSet -> IO ()
rmLoggerSet :: LoggerSet -> IO ()
rmLoggerSet (LoggerSet Maybe FilePath
mfile IORef FD
fdref Array BufSize Logger
arr IO ()
_) = do
    let (BufSize
l,BufSize
u) = Array BufSize Logger -> (BufSize, BufSize)
forall i e. Array i e -> (i, i)
bounds Array BufSize Logger
arr
    let nums :: [BufSize]
nums = [BufSize
l .. BufSize
u]
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
flushIt [BufSize]
nums
    (BufSize -> IO ()) -> [BufSize] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BufSize -> IO ()
freeIt [BufSize]
nums
    FD
fd <- IORef FD -> IO FD
forall a. IORef a -> IO a
readIORef IORef FD
fdref
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
mfile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FD -> IO ()
forall a. IODevice a => a -> IO ()
close FD
fd
  where
    flushIt :: BufSize -> IO ()
flushIt BufSize
i = IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref (Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i)
    freeIt :: BufSize -> IO ()
freeIt BufSize
i = do
        let (Logger BufSize
_ MVar Buffer
mbuf IORef LogStr
_) = Array BufSize Logger
arr Array BufSize Logger -> BufSize -> Logger
forall i e. Ix i => Array i e -> i -> e
! BufSize
i
        MVar Buffer -> IO Buffer
forall a. MVar a -> IO a
takeMVar MVar Buffer
mbuf IO Buffer -> (Buffer -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Buffer -> IO ()
forall a. Ptr a -> IO ()
free