{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}

module System.Log.FastLogger.Logger (
    Logger(..)
  , newLogger
  , pushLog
  , flushLog
  ) where


import Control.Concurrent (MVar, newMVar, withMVar)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (plusPtr)

import System.Log.FastLogger.FileIO
import System.Log.FastLogger.IO
import System.Log.FastLogger.Imports
import System.Log.FastLogger.LogStr

----------------------------------------------------------------

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
getBuffer 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

----------------------------------------------------------------

pushLog :: IORef FD -> Logger -> LogStr -> IO ()
pushLog :: IORef FD -> Logger -> LogStr -> IO ()
pushLog IORef FD
fdref logger :: Logger
logger@(Logger BufSize
size MVar Buffer
mbuf IORef LogStr
ref) nlogmsg :: LogStr
nlogmsg@(LogStr BufSize
nlen Builder
nbuilder)
  | BufSize
nlen BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
> BufSize
size = do
      IORef FD -> Logger -> IO ()
flushLog IORef FD
fdref Logger
logger
      -- Make sure we have a large enough buffer to hold the entire
      -- contents, thereby allowing for a single write system call and
      -- avoiding interleaving. This does not address the possibility
      -- of write not writing the entire buffer at once.
      BufSize -> (Buffer -> IO ()) -> IO ()
forall a b. BufSize -> (Ptr a -> IO b) -> IO b
allocaBytes BufSize
nlen ((Buffer -> IO ()) -> IO ()) -> (Buffer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Buffer
buf -> 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
_ ->
        Buffer
-> BufSize -> (Buffer -> BufSize -> IO ()) -> Builder -> IO ()
toBufIOWith Buffer
buf BufSize
nlen (IORef FD -> Buffer -> BufSize -> IO ()
write IORef FD
fdref) Builder
nbuilder
  | Bool
otherwise = do
    Maybe LogStr
mmsg <- IORef LogStr
-> (LogStr -> (LogStr, Maybe LogStr)) -> IO (Maybe LogStr)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LogStr
ref LogStr -> (LogStr, Maybe LogStr)
checkBuf
    case Maybe LogStr
mmsg of
        Maybe LogStr
Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just LogStr
msg -> 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
msg
  where
    checkBuf :: LogStr -> (LogStr, Maybe LogStr)
checkBuf ologmsg :: LogStr
ologmsg@(LogStr BufSize
olen Builder
_)
      | BufSize
size BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
< BufSize
olen BufSize -> BufSize -> BufSize
forall a. Num a => a -> a -> a
+ BufSize
nlen = (LogStr
nlogmsg, LogStr -> Maybe LogStr
forall a. a -> Maybe a
Just LogStr
ologmsg)
      | Bool
otherwise          = (LogStr
ologmsg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
nlogmsg, Maybe LogStr
forall a. Maybe a
Nothing)

----------------------------------------------------------------

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 = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"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
0 BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufSize
written Bool -> Bool -> Bool
&& 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)