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

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


import Control.Concurrent (MVar, 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

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

newtype Logger = Logger (IORef LogStr)

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

newLogger :: IO Logger
newLogger :: IO Logger
newLogger = IORef LogStr -> Logger
Logger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty

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

pushLog :: IORef FD -> BufSize -> MVar Buffer -> Logger -> LogStr -> IO ()
pushLog :: IORef FD -> Int -> MVar Buffer -> Logger -> LogStr -> IO ()
pushLog IORef FD
fdref Int
size MVar Buffer
mbuf logger :: Logger
logger@(Logger IORef LogStr
ref) nlogmsg :: LogStr
nlogmsg@(LogStr Int
nlen Builder
nbuilder)
  | Int
nlen forall a. Ord a => a -> a -> Bool
> Int
size = do
      IORef FD -> Int -> MVar Buffer -> Logger -> IO ()
flushLog IORef FD
fdref Int
size MVar Buffer
mbuf 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.
      forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
nlen forall a b. (a -> b) -> a -> b
$ \Buffer
buf -> forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mbuf forall a b. (a -> b) -> a -> b
$ \Buffer
_ ->
        Buffer -> Int -> (Buffer -> Int -> IO ()) -> Builder -> IO ()
toBufIOWith Buffer
buf Int
nlen (IORef FD -> Buffer -> Int -> IO ()
write IORef FD
fdref) Builder
nbuilder
  | Bool
otherwise = do
    Maybe LogStr
mmsg <- 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  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just LogStr
msg -> forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mbuf forall a b. (a -> b) -> a -> b
$ \Buffer
buf -> IORef FD -> Buffer -> Int -> LogStr -> IO ()
writeLogStr IORef FD
fdref Buffer
buf Int
size LogStr
msg
  where
    checkBuf :: LogStr -> (LogStr, Maybe LogStr)
checkBuf ologmsg :: LogStr
ologmsg@(LogStr Int
olen Builder
_)
      | Int
size forall a. Ord a => a -> a -> Bool
< Int
olen forall a. Num a => a -> a -> a
+ Int
nlen = (LogStr
nlogmsg, forall a. a -> Maybe a
Just LogStr
ologmsg)
      | Bool
otherwise          = (LogStr
ologmsg forall a. Semigroup a => a -> a -> a
<> LogStr
nlogmsg, forall a. Maybe a
Nothing)

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

flushLog :: IORef FD -> BufSize -> MVar Buffer -> Logger -> IO ()
flushLog :: IORef FD -> Int -> MVar Buffer -> Logger -> IO ()
flushLog IORef FD
fdref Int
size MVar Buffer
mbuf (Logger IORef LogStr
lref) = do
    LogStr
logmsg <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef LogStr
lref (\LogStr
old -> (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.
    forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Buffer
mbuf forall a b. (a -> b) -> a -> b
$ \Buffer
buf -> IORef FD -> Buffer -> Int -> LogStr -> IO ()
writeLogStr IORef FD
fdref Buffer
buf Int
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 -> Int -> LogStr -> IO ()
writeLogStr IORef FD
fdref Buffer
buf Int
size (LogStr Int
len Builder
builder)
  | Int
size forall a. Ord a => a -> a -> Bool
< Int
len = forall a. HasCallStack => [Char] -> a
error [Char]
"writeLogStr"
  | Bool
otherwise  = Buffer -> Int -> (Buffer -> Int -> IO ()) -> Builder -> IO ()
toBufIOWith Buffer
buf Int
size (IORef FD -> Buffer -> Int -> IO ()
write IORef FD
fdref) Builder
builder

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