{-# 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
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
data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD) (Array Int Logger) (IO ())
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
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
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
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
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))
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
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'
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)
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