{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Logger
(
Logger
, fromHandle
, fromFd
, builder
, boundedBuilder
, chunks
, bytes
, byteArray
, cstring
, cstring#
, flush
) where
import Control.Concurrent (MVar, newMVar, putMVar, rtsSupportsBoundThreads, threadWaitWrite, tryTakeMVar)
import Control.Exception (SomeException, mask, onException, toException)
import Control.Monad (when)
import Data.Bits ((.&.))
import Data.Bytes.Builder (Builder)
import Data.Bytes.Chunks (Chunks)
import Data.Bytes.Types (Bytes (Bytes))
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Primitive (ByteArray, MutablePrimArray)
import Foreign.C.Error (eAGAIN, eBADF, eINTR, eWOULDBLOCK)
import Foreign.C.String (CString)
import GHC.Exts (Addr#, Ptr (Ptr), RealWorld)
import GHC.IO (IO (IO))
import Posix.File (uninterruptibleGetStatusFlags, uninterruptibleWriteByteArray)
import System.IO (Handle)
import System.Posix.Types (Fd (Fd))
import qualified Arithmetic.Types as Arithmetic
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Builder as Builder
import qualified Data.Bytes.Builder.Bounded as BB
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Primitive as PM
import qualified GHC.Exts as Exts
import qualified GHC.IO.FD as FD
import qualified GHC.IO.Handle.FD as FD
import qualified Posix.File as File
data Logger
= Logger
{-# UNPACK #-} !Fd
{-# UNPACK #-} !Int
{-# UNPACK #-} !(MVar ())
{-# UNPACK #-} !(IORef Chunks)
{-# UNPACK #-} !(MutablePrimArray RealWorld Int)
fromHandle :: Handle -> IO Logger
fromHandle :: Handle -> IO Logger
fromHandle Handle
h = do
FD.FD {fdFD :: FD -> CInt
FD.fdFD = CInt
fd} <- Handle -> IO FD
FD.handleToFd Handle
h
Fd -> IO Logger
fromFd (CInt -> Fd
Fd CInt
fd)
fromFd :: Fd -> IO Logger
fromFd :: Fd -> IO Logger
fromFd !Fd
fd = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
rtsSupportsBoundThreads) (SomeException -> IO ()
forall a. SomeException -> IO a
die SomeException
threadedRuntimeRequired)
StatusFlags
status <-
Fd -> IO (Either Errno StatusFlags)
uninterruptibleGetStatusFlags Fd
fd IO (Either Errno StatusFlags)
-> (Either Errno StatusFlags -> IO StatusFlags) -> IO StatusFlags
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Errno
_ -> SomeException -> IO StatusFlags
forall a. SomeException -> IO a
die SomeException
flagsFailure
Right StatusFlags
status -> StatusFlags -> IO StatusFlags
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusFlags
status
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(Bool -> Bool
not (StatusFlags -> Bool
File.isWriteOnly StatusFlags
status Bool -> Bool -> Bool
|| StatusFlags -> Bool
File.isReadWrite StatusFlags
status))
(SomeException -> IO ()
forall a. SomeException -> IO a
die SomeException
statusWriteFailure)
let !nonblocking :: Int
nonblocking =
if StatusFlags
File.nonblocking StatusFlags -> StatusFlags -> StatusFlags
forall a. Bits a => a -> a -> a
.&. StatusFlags
status StatusFlags -> StatusFlags -> Bool
forall a. Eq a => a -> a -> Bool
== StatusFlags
File.nonblocking
then Int
1
else Int
0
!MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
!IORef Chunks
ref <- Chunks -> IO (IORef Chunks)
forall a. a -> IO (IORef a)
newIORef Chunks
Chunks.ChunksNil
!MutablePrimArray RealWorld Int
counterRef <- Int -> IO (MutablePrimArray (PrimState IO) Int)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
PM.newPrimArray Int
1
MutablePrimArray (PrimState IO) Int -> Int -> Int -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PM.writePrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
counterRef Int
0 Int
0
Logger -> IO Logger
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$! Fd
-> Int
-> MVar ()
-> IORef Chunks
-> MutablePrimArray RealWorld Int
-> Logger
Logger Fd
fd Int
nonblocking MVar ()
lock IORef Chunks
ref MutablePrimArray RealWorld Int
counterRef
threshold :: Int
threshold :: Int
threshold = Int
32
cstring :: Logger -> CString -> IO ()
cstring :: Logger -> CString -> IO ()
cstring Logger
g CString
str = Logger -> Builder -> IO ()
builder Logger
g (CString -> Builder
Builder.cstring CString
str)
cstring# :: Logger -> Addr# -> IO ()
cstring# :: Logger -> Addr# -> IO ()
cstring# Logger
g Addr#
str = Logger -> Builder -> IO ()
builder Logger
g (CString -> Builder
Builder.cstring (Addr# -> CString
forall a. Addr# -> Ptr a
Ptr Addr#
str))
chunks :: Logger -> Chunks -> IO ()
{-# NOINLINE chunks #-}
chunks :: Logger -> Chunks -> IO ()
chunks logger :: Logger
logger@(Logger Fd
_ Int
_ MVar ()
_ IORef Chunks
ref MutablePrimArray RealWorld Int
counterRef) Chunks
ch = do
IORef Chunks -> (Chunks -> (Chunks, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef'
IORef Chunks
ref
( \Chunks
cs0 ->
let !cs1 :: Chunks
cs1 = Chunks -> Chunks -> Chunks
Chunks.reverseOnto Chunks
cs0 Chunks
ch
in (Chunks
cs1, ())
)
!Int
counter <- MutablePrimArray RealWorld Int -> IO Int
bumpCounter MutablePrimArray RealWorld Int
counterRef
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
counter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
threshold) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
MutablePrimArray (PrimState IO) Int -> Int -> Int -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PM.writePrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
counterRef Int
0 Int
0
Logger -> IO ()
flush Logger
logger
builder :: Logger -> Builder -> IO ()
builder :: Logger -> Builder -> IO ()
builder logger :: Logger
logger@(Logger Fd
_ Int
_ MVar ()
_ IORef Chunks
ref MutablePrimArray RealWorld Int
counterRef) Builder
bldr = do
IORef Chunks -> (Chunks -> (Chunks, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef'
IORef Chunks
ref
( \Chunks
cs0 ->
let !cs1 :: Chunks
cs1 = Int -> Builder -> Chunks -> Chunks
Builder.reversedOnto Int
240 Builder
bldr Chunks
cs0
in (Chunks
cs1, ())
)
!Int
counter <- MutablePrimArray RealWorld Int -> IO Int
bumpCounter MutablePrimArray RealWorld Int
counterRef
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
counter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
threshold) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
MutablePrimArray (PrimState IO) Int -> Int -> Int -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PM.writePrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
counterRef Int
0 Int
0
Logger -> IO ()
flush Logger
logger
boundedBuilder :: Logger -> Arithmetic.Nat n -> BB.Builder n -> IO ()
boundedBuilder :: forall (n :: Nat). Logger -> Nat n -> Builder n -> IO ()
boundedBuilder Logger
logger Nat n
n Builder n
b = Logger -> ByteArray -> IO ()
byteArray Logger
logger (Nat n -> Builder n -> ByteArray
forall (n :: Nat). Nat n -> Builder n -> ByteArray
BB.run Nat n
n Builder n
b)
bytes :: Logger -> Bytes -> IO ()
bytes :: Logger -> Bytes -> IO ()
bytes logger :: Logger
logger@(Logger Fd
_ Int
_ MVar ()
_ IORef Chunks
ref MutablePrimArray RealWorld Int
counterRef) !Bytes
b = do
IORef Chunks -> (Chunks -> (Chunks, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef'
IORef Chunks
ref
(\Chunks
cs0 -> let !cs1 :: Chunks
cs1 = Bytes -> Chunks -> Chunks
Chunks.ChunksCons Bytes
b Chunks
cs0 in (Chunks
cs1, ()))
!Int
counter <- MutablePrimArray RealWorld Int -> IO Int
bumpCounter MutablePrimArray RealWorld Int
counterRef
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
counter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
threshold) (Logger -> IO ()
flush Logger
logger)
byteArray :: Logger -> ByteArray -> IO ()
byteArray :: Logger -> ByteArray -> IO ()
byteArray Logger
logger = Logger -> Bytes -> IO ()
bytes Logger
logger (Bytes -> IO ()) -> (ByteArray -> Bytes) -> ByteArray -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteArray -> Bytes
Bytes.fromByteArray
bumpCounter :: MutablePrimArray RealWorld Int -> IO Int
bumpCounter :: MutablePrimArray RealWorld Int -> IO Int
bumpCounter MutablePrimArray RealWorld Int
arr = do
Int
counter <- MutablePrimArray (PrimState IO) Int -> Int -> IO Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
PM.readPrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
arr Int
0
let counter' :: Int
counter' = Int
counter Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
MutablePrimArray (PrimState IO) Int -> Int -> Int -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PM.writePrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
arr Int
0 Int
counter'
Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
counter'
flush :: Logger -> IO ()
{-# NOINLINE flush #-}
flush :: Logger -> IO ()
flush (Logger Fd
fd Int
nonblocking MVar ()
lock IORef Chunks
ref MutablePrimArray RealWorld Int
_) = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
lock IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ()
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (()
_ :: ()) -> do
Chunks
yanked <- IORef Chunks -> (Chunks -> (Chunks, Chunks)) -> IO Chunks
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Chunks
ref (\Chunks
cs -> (Chunks
Chunks.ChunksNil, Chunks
cs))
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
onException
(IO () -> IO ()
forall a. IO a -> IO a
restore (Chunks -> IO ()
action Chunks
yanked))
( do
IORef Chunks -> (Chunks -> (Chunks, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Chunks
ref (\Chunks
cs -> (Chunks
cs Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
yanked, ()))
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()
)
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()
where
action :: Chunks -> IO ()
action Chunks
yanked = case Int
nonblocking of
Int
1 -> Fd -> Chunks -> IO ()
writeNonblocking Fd
fd Chunks
yanked
Int
_ -> Fd -> Chunks -> IO ()
writeBlocking Fd
fd Chunks
yanked
writeNonblocking :: Fd -> Chunks -> IO ()
writeNonblocking :: Fd -> Chunks -> IO ()
writeNonblocking !Fd
fd Chunks
yanked = Int -> Int -> IO ()
go Int
off0 Int
len0
where
Bytes ByteArray
arr Int
off0 Int
len0 = Chunks -> Bytes
Chunks.concat (Chunks -> Chunks
Chunks.reverse Chunks
yanked)
go :: Int -> Int -> IO ()
go Int
off Int
len = do
Fd -> ByteArray -> Int -> CSize -> IO (Either Errno CSize)
uninterruptibleWriteByteArray Fd
fd ByteArray
arr Int
off (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) IO (Either Errno CSize) -> (Either Errno CSize -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Errno
err
| Errno
err Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eWOULDBLOCK Bool -> Bool -> Bool
|| Errno
err Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eAGAIN -> do
Fd -> IO ()
threadWaitWrite Fd
fd
Int -> Int -> IO ()
go Int
off Int
len
| Errno
err Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eINTR -> Int -> Int -> IO ()
go Int
off Int
len
| Errno
err Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eBADF -> SomeException -> IO ()
forall a. SomeException -> IO a
die SomeException
flushBadFdFailure
| Bool
otherwise -> SomeException -> IO ()
forall a. SomeException -> IO a
die SomeException
flushFailure
Right CSize
writtenC -> do
let written :: Int
written = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
writtenC :: Int
if Int
written Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len
then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else Int -> Int -> IO ()
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
written) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
written)
writeBlocking :: Fd -> Chunks -> IO ()
writeBlocking :: Fd -> Chunks -> IO ()
writeBlocking !Fd
fd Chunks
yanked = Int -> Int -> IO ()
go Int
off0 Int
len0
where
Bytes ByteArray
arr Int
off0 Int
len0 = Chunks -> Bytes
Chunks.concatPinned (Chunks -> Chunks
Chunks.reverse Chunks
yanked)
go :: Int -> Int -> IO ()
go Int
off Int
len = do
Fd -> ByteArray -> Int -> CSize -> IO (Either Errno CSize)
File.writeByteArray Fd
fd ByteArray
arr Int
off (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) IO (Either Errno CSize) -> (Either Errno CSize -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Errno
_ -> SomeException -> IO ()
forall a. SomeException -> IO a
die SomeException
flushFailure
Right CSize
writtenC -> do
let written :: Int
written = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
writtenC :: Int
if Int
written Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len
then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else Int -> Int -> IO ()
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
written) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
written)
die :: SomeException -> IO a
{-# INLINE die #-}
die :: forall a. SomeException -> IO a
die SomeException
e = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (SomeException -> State# RealWorld -> (# State# RealWorld, a #)
forall a b. a -> State# RealWorld -> (# State# RealWorld, b #)
Exts.raiseIO# SomeException
e)
flagsFailure :: SomeException
{-# NOINLINE flagsFailure #-}
flagsFailure :: SomeException
flagsFailure =
IOError -> SomeException
forall e. Exception e => e -> SomeException
toException
(String -> IOError
userError String
"Logger: fcntl failed")
statusWriteFailure :: SomeException
{-# NOINLINE statusWriteFailure #-}
statusWriteFailure :: SomeException
statusWriteFailure =
IOError -> SomeException
forall e. Exception e => e -> SomeException
toException
(String -> IOError
userError String
"Logger: descriptor must have O_WRONLY or O_RDWR")
flushFailure :: SomeException
{-# NOINLINE flushFailure #-}
flushFailure :: SomeException
flushFailure = IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> IOError
userError String
"Logger: flush encountered unknown error")
flushBadFdFailure :: SomeException
{-# NOINLINE flushBadFdFailure #-}
flushBadFdFailure :: SomeException
flushBadFdFailure = IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> IOError
userError String
"Logger: EBADF while flushing")
threadedRuntimeRequired :: SomeException
{-# NOINLINE threadedRuntimeRequired #-}
threadedRuntimeRequired :: SomeException
threadedRuntimeRequired = IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> IOError
userError String
"Logger: threaded runtime required")