packages feed

bytelog (empty) → 0.1.0.0

raw patch · 5 files changed

+306/−0 lines, 5 filesdep +basedep +bytebuilddep +byteslicesetup-changed

Dependencies added: base, bytebuild, byteslice, natural-arithmetic, posix-api, primitive

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for bytelog++## 0.1.0.0 -- 2020-03-09++* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bytelog.cabal view
@@ -0,0 +1,26 @@+cabal-version: 2.4+name: bytelog+version: 0.1.0.0+synopsis: Fast logging+bug-reports: https://github.com/byteverse/bytelog+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2020 Andrew Martin+category: Data+build-type: Simple+extra-source-files: CHANGELOG.md++library+  exposed-modules: Logger+  build-depends:+    , base >=4.12 && <5+    , bytebuild >=0.3.4+    , byteslice >=0.2.2+    , natural-arithmetic >=0.1.2+    , posix-api >=0.3.4+    , primitive >=0.7+  hs-source-dirs: src+  ghc-options: -O2 -Wall+  default-language: Haskell2010
+ src/Logger.hs view
@@ -0,0 +1,243 @@+{-# language BangPatterns #-}+{-# language MagicHash #-}+{-# language LambdaCase #-}+{-# language ScopedTypeVariables #-}++module Logger+  ( -- * Types+    Logger+    -- * Open+  , fromHandle+  , fromFd+    -- * Log+  , builder+  , boundedBuilder+  , bytes+  , byteArray+  , cstring+    -- * Flush+  , flush+  ) where++import Control.Concurrent (MVar,threadWaitWrite,putMVar,newMVar,tryTakeMVar,rtsSupportsBoundThreads)+import Control.Exception (SomeException,toException,onException,mask)+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 (MutablePrimArray,ByteArray)+import Foreign.C.Error (eINTR,eWOULDBLOCK,eAGAIN,eBADF)+import Foreign.C.String (CString)+import GHC.Exts (RealWorld)+import GHC.IO (IO(IO))+import Posix.File (uninterruptibleWriteByteArray,uninterruptibleGetStatusFlags)+import System.IO (Handle)+import System.Posix.Types (Fd(Fd))++import qualified Arithmetic.Types as Arithmetic+import qualified Data.Bytes.Builder as Builder+import qualified Data.Bytes.Builder.Bounded as BB+import qualified Data.Bytes as Bytes+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++-- | An output channel for logs. The intent is that there is only+-- one logger per application, opened at load time and shared across+-- all threads.+data Logger = Logger+  {-# UNPACK #-} !Fd+  -- ^ Output file descriptor, often stdout or stderr. Must be+  -- in nonblocking mode. This is checked when the logger is opened.+  {-# UNPACK #-} !Int+  -- ^ The number 1 if file descriptor is nonblocking. The number 0+  -- if it is blocking. Notably, stderr will almost certainly be in+  -- blocking mode.+  {-# UNPACK #-} !(MVar ())+  -- ^ Lock, only used when flushing.+  {-# UNPACK #-} !(IORef Chunks)+  -- ^ Chunks to be written out. This is only ever accessed by+  -- thread-safe atomicModify functions.+  {-# UNPACK #-} !(MutablePrimArray RealWorld Int)+  -- ^ Singleton array with a counter. This is used as a heuristic+  -- for when to flush. This is accessed in a non-thread-safe way+  -- where updates can be overridden. This is fine since logs will+  -- eventually get flushed anyway. Note that this is based on a+  -- number of units atomically written to the logger, not based+  -- on a byte count. Intuitively, it is deeply wrong to decide+  -- when to flush like this, but small-bytearray-builder is not+  -- able to provide the number of bytes that result from running+  -- a builder, so we use this hack instead.++-- | Convert a 'Handle' to a logger by extracting its file descriptor.+-- Warning: the caller must ensure that the handle does not get garbage+-- collected. This is very dangerous.+fromHandle :: Handle -> IO Logger+fromHandle h = do+  FD.FD{FD.fdFD=fd} <- FD.handleToFd h+  fromFd (Fd fd)++-- | Convert a file descriptor to a logger.+fromFd :: Fd -> IO Logger+fromFd !fd = do+  when (not rtsSupportsBoundThreads) (die threadedRuntimeRequired)+  status <- uninterruptibleGetStatusFlags fd >>= \case+    Left _ -> die flagsFailure+    Right status -> pure status+  when (not (File.isWriteOnly status || File.isReadWrite status))+    (die statusWriteFailure)+  let !nonblocking = if File.nonblocking .&. status == File.nonblocking+        then 1+        else 0+  !lock <- newMVar ()+  !ref <- newIORef Chunks.ChunksNil+  !counterRef <- PM.newPrimArray 1+  PM.writePrimArray counterRef 0 0+  pure $! Logger fd nonblocking lock ref counterRef++threshold :: Int+threshold = 32++-- | Log a @NUL@-terminated C string.+cstring :: Logger -> CString -> IO ()+cstring g str = builder g (Builder.cstring str)++-- | Log the chunks that result from executing the byte builder.+builder :: Logger -> Builder -> IO ()+builder logger@(Logger _ _ _ ref counterRef) bldr = do+  atomicModifyIORef' ref+    (\cs0 ->+      let !cs1 = Builder.reversedOnto 240 bldr cs0+       in (cs1,())+    )+  !counter <- bumpCounter counterRef+  when (counter >= threshold) $ do+    -- Reset the counter+    PM.writePrimArray counterRef 0 0+    flush logger++-- | Log the unsliced byte array that results from executing+-- the bounded builder.+boundedBuilder :: Logger -> Arithmetic.Nat n -> BB.Builder n -> IO ()+boundedBuilder logger n b = byteArray logger (BB.run n b)++-- | Log a byte sequence.+bytes :: Logger -> Bytes -> IO ()+bytes logger@(Logger _ _ _ ref counterRef) !b = do+  atomicModifyIORef' ref+    (\cs0 -> let !cs1 = Chunks.ChunksCons b cs0 in (cs1,()))+  !counter <- bumpCounter counterRef+  when (counter >= threshold) (flush logger)++-- | Log an unsliced byte array.+byteArray :: Logger -> ByteArray -> IO ()+byteArray logger = bytes logger . Bytes.fromByteArray++bumpCounter :: MutablePrimArray RealWorld Int -> IO Int+bumpCounter arr = do+  counter <- PM.readPrimArray arr 0+  let counter' = counter + 1+  PM.writePrimArray arr 0 counter'+  pure counter'++-- | Flush any pending logs out to the file descriptor.+flush :: Logger -> IO ()+{-# noinline flush #-}+flush (Logger fd nonblocking lock ref _) = mask $ \restore -> tryTakeMVar lock >>= \case+  -- Try to take the lock. This cannot be interrupted by async exceptions.+  -- If we cannot take the lock immidiately, someone else is already flushing+  -- logs, so we just give up.+  Nothing -> pure ()+  Just (_ :: ()) -> do+    -- Atomically remove all logs from the batch. GHC guarantees+    -- that this is cannot be interrupted by async exceptions+    -- inside of mask.+    yanked <- atomicModifyIORef' ref (\cs -> (Chunks.ChunksNil,cs))+    -- When cleaning up after an exception, we put all the logs+    -- back. This means that logs may end up duplicated. That is+    -- in addition to the inevitable chance of a torn log that+    -- was being written out when throwTo delivered the exception.+    -- The decision about the ordering of @cs@ and @yanked@ during+    -- cleanup is arbitrary.+    onException+      (restore (action yanked))+      (do atomicModifyIORef' ref (\cs -> (cs <> yanked,()))+          putMVar lock ()+      )+    putMVar lock ()+    where+    action yanked = case nonblocking of+      1 -> writeNonblocking fd yanked+      _ -> writeBlocking fd yanked++writeNonblocking :: Fd -> Chunks -> IO ()+writeNonblocking !fd yanked = go off0 len0+  -- TODO: Use writev so that we do not have to allocate+  -- memory to concatenate the chunks. This would need to+  -- be added to posix-api.+  where+  Bytes arr off0 len0 = Chunks.concat (Chunks.reverse yanked)+  go off len = do+    -- Remember, the file descriptor is known to be in non-blocking mode,+    -- so uninterruptible is fine.+    uninterruptibleWriteByteArray fd arr off (fromIntegral len) >>= \case+      Left err+        | err == eWOULDBLOCK || err == eAGAIN -> do+            threadWaitWrite fd+            go off len+        | err == eINTR -> go off len+        | err == eBADF -> die flushBadFdFailure+        | otherwise -> die flushFailure+      Right writtenC -> do+        let written = fromIntegral writtenC :: Int+        if written == len+          then pure ()+          else go (off + written) (len - written)++writeBlocking :: Fd -> Chunks -> IO ()+writeBlocking !fd yanked = go off0 len0+  -- Note: we concatenate the chunks into pinned memory. Pinned memory+  -- is required since we use the safe FFI.+  where+  Bytes arr off0 len0 = Chunks.concatPinned (Chunks.reverse yanked)+  go off len = do+    -- The file descriptor is known to be in blocking mode,+    -- so we do not bother with the event manager.+    File.writeByteArray fd arr off (fromIntegral len) >>= \case+      Left _ -> die flushFailure+      Right writtenC -> do+        let written = fromIntegral writtenC :: Int+        if written == len+          then pure ()+          else go (off + written) (len - written)++die :: SomeException -> IO a+{-# inline die #-}+die e = IO (Exts.raiseIO# e)++flagsFailure :: SomeException+{-# noinline flagsFailure #-}+flagsFailure = toException+  (userError "Logger: fcntl failed")++statusWriteFailure :: SomeException+{-# noinline statusWriteFailure #-}+statusWriteFailure = toException+  (userError "Logger: descriptor must have O_WRONLY or O_RDWR")++flushFailure :: SomeException+{-# noinline flushFailure #-}+flushFailure = toException (userError "Logger: flush encountered unknown error")++flushBadFdFailure :: SomeException+{-# noinline flushBadFdFailure #-}+flushBadFdFailure = toException (userError "Logger: EBADF while flushing")++threadedRuntimeRequired :: SomeException+{-# noinline threadedRuntimeRequired #-}+threadedRuntimeRequired = toException (userError "Logger: threaded runtime required")