Move this code out of our Katip fork.

LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2021 Alexei Uimanov
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

katip-sync-handle.cabal

@@ -0,0 +1,36 @@
+cabal-version:      2.4
+name:               katip-sync-handle
+version:            0.1
+synopsis:
+
+-- A longer description of the package.
+-- description:
+homepage:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+license:            MIT
+license-file:       LICENSE
+author:             Alexei Uimanov
+maintainer:         s9gf4ult@gmail.com
+
+copyright:          Antorica LLC
+category:           System
+
+library
+    exposed-modules:  Katip.Scribes.SyncHandle
+                      Katip.Scribes.SyncHandle.FileOwner
+    build-depends:    base >=4.12 && < 5,
+                      aeson >=1.4 && < 1.6,
+		      async,
+                      auto-update >= 0.1 && < 0.2,
+                      bytestring,
+                      deepseq,
+                      katip >= 0.8 && < 0.9,
+                      scientific,
+                      stm,
+		      text,
+		      unordered-containers >= 0.2 && < 0.3
+    hs-source-dirs:   src
+    default-language: Haskell2010
+    ghc-options:      -Wall

src/Katip/Scribes/SyncHandle.hs

@@ -0,0 +1,221 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module Katip.Scribes.SyncHandle where
+
+-------------------------------------------------------------------------------
+import           Control.Applicative    as A
+import           Control.Concurrent
+import           Control.Exception      (finally)
+import           Data.Aeson
+import           Data.Aeson.Text
+import           Data.ByteString.Builder as B
+import           Data.ByteString.Lazy    as BL (hPutStr)
+import           Data.ByteString.Lazy.Char8 as BL (singleton)
+import           Data.Monoid            as M
+import           Data.Scientific        as S
+import           Data.Text              (Text)
+import           Data.Text.Lazy.Builder as TL
+import           Data.Text.Lazy.Encoding     (encodeUtf8)
+import           System.IO
+import qualified Data.HashMap.Strict    as HM
+
+-------------------------------------------------------------------------------
+import           Katip.Core
+import           Katip.Format.Time      (formatAsLogTime)
+import           Katip.Scribes.SyncHandle.FileOwner
+-------------------------------------------------------------------------------
+
+
+-------------------------------------------------------------------------------
+brackets :: TL.Builder -> TL.Builder
+brackets m = fromText "[" M.<> m <> fromText "]"
+
+textBuilderToBS :: TL.Builder -> B.Builder
+textBuilderToBS = B.lazyByteString . encodeUtf8 . toLazyText
+
+appendNL :: B.Builder -> B.Builder
+appendNL b = b <> B.lazyByteString (BL.singleton '\n')
+
+-------------------------------------------------------------------------------
+getKeys :: LogItem s => Verbosity -> s -> [TL.Builder]
+getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
+  where
+    renderPair :: (Text, Value) -> [TL.Builder]
+    renderPair (k,v) =
+      case v of
+        Object o -> concat [renderPair (k <> "." <> k', v')  | (k', v') <- HM.toList o]
+        String t -> [fromText (k <> ":" <> t)]
+        Number n -> [fromText (k <> ":") <> fromString (formatNumber n)]
+        Bool b -> [fromText (k <> ":") <> fromString (show b)]
+        Null -> [fromText (k <> ":null")]
+        _ -> mempty -- Can't think of a sensible way to handle arrays
+    formatNumber :: Scientific -> String
+    formatNumber n =
+      formatScientific Generic (if isFloating n then Nothing else Just 0) n
+
+
+-------------------------------------------------------------------------------
+data ColorStrategy
+    = ColorLog Bool
+    -- ^ Whether to use color control chars in log output
+    | ColorIfTerminal
+    -- ^ Color if output is a terminal
+  deriving (Show, Eq)
+
+-------------------------------------------------------------------------------
+-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
+-- and other information will be flattened out into bracketed
+-- fields. For example:
+--
+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
+-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
+--
+-- Returns the newly-created `Scribe`. The finalizer flushes the
+-- handle. Handle mode is set to 'LineBuffering' automatically.
+mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
+mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
+
+
+mkFileScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
+                          -> ColorStrategy
+                          -> FilePath
+                          -> PermitFunc
+                          -> Verbosity
+                          -> IO Scribe
+mkFileScribeWithFormatter formatter color f permitF verb = do
+  h <- openBinaryFile f AppendMode
+  Scribe logger finalizer permit <- mkHandleScribeWithFormatter formatter color h permitF verb
+  return (Scribe logger (finalizer `finally` hClose h) permit)
+
+
+-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
+-- `ItemFormatter` that can be used to format `Item` as needed.
+--
+-- Returns the newly-created `Scribe`. The finalizer flushes the
+-- handle. Handle mode is set to 'LineBuffering' automatically.
+mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
+                            -> ColorStrategy
+                            -> Handle
+                            -> PermitFunc
+                            -> Verbosity
+                            -> IO Scribe
+mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
+    colorize <- case cs of
+      ColorIfTerminal -> hIsTerminalDevice h
+      ColorLog b      -> return b
+    lock <- newMVar ()
+    let logger i@Item{..} = withMVar lock $ \() -> do
+          BL.hPutStr h $ toLazyByteString $ itemFormatter colorize verb i
+    return $ Scribe logger (hFlush h) permitF
+
+-- | Just like mkFileScribeWithFormatter but does it with FileOwner. You can
+-- rotate your logs with commands to the FileOwner directly. This scribe will
+-- send messages to the given FileOwner
+mkFileOwnerScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
+                               -> ColorStrategy
+                               -> FileOwner
+                               -> PermitFunc
+                               -> Verbosity
+                               -> IO Scribe
+mkFileOwnerScribeWithFormatter itemFormatter cs owner permitF verb = do
+    let
+      colorize = case cs of
+        ColorIfTerminal -> False
+        -- File is never a terminal
+        ColorLog b      -> b
+      logger item = do
+        writeFileOwner owner $ toLazyByteString
+          $ itemFormatter colorize verb item
+      scribe = Scribe logger (fileOwnerControl owner CloseMsg) permitF
+    return scribe
+
+-------------------------------------------------------------------------------
+-- | A specialization of 'mkHandleScribe' that takes a 'FilePath'
+-- instead of a 'Handle'. It is responsible for opening the file in
+-- 'AppendMode' and will close the file handle on
+-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
+-- to 'LineBuffering' mode.
+mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
+mkFileScribe = mkFileScribeWithFormatter bracketFormat (ColorLog False)
+
+
+-------------------------------------------------------------------------------
+-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
+-- whether to colorize the output, `Verbosity` of output, and an `Item` to
+-- format. Note that formatter is responsible for appending the newline at the
+-- end of the string if required
+--
+-- See `bracketFormat` and `jsonFormat` for examples.
+type ItemFormatter a = Bool -> Verbosity -> Item a -> B.Builder
+
+
+formatItem :: LogItem a => ItemFormatter a
+formatItem = bracketFormat
+{-# DEPRECATED formatItem "Use bracketFormat instead" #-}
+
+-- | A traditional 'bracketed' log format. Contexts and other information will
+-- be flattened out into bracketed fields. For example:
+--
+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
+-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
+bracketFormat :: LogItem a => ItemFormatter a
+bracketFormat withColor verb Item{..} = appendNL $ textBuilderToBS $
+    brackets nowStr <>
+    brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
+    brackets (renderSeverity' _itemSeverity) <>
+    brackets (fromString _itemHost) <>
+    brackets ("PID " <> fromString (show _itemProcess)) <>
+    brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
+    mconcat ks <>
+    maybe mempty (brackets . fromString . locationToString) _itemLoc <>
+    fromText " " <> (unLogStr _itemMessage)
+  where
+    nowStr = fromText (formatAsLogTime _itemTime)
+    ks = map brackets $ getKeys verb _itemPayload
+    renderSeverity' severity =
+      colorBySeverity withColor severity (fromText $ renderSeverity severity)
+
+-- | Logs items as JSON. This can be useful in circumstances where you already
+-- have infrastructure that is expecting JSON to be logged to a standard stream
+-- or file. For example:
+--
+-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Started","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":44},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
+-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
+-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
+jsonFormat :: LogItem a => ItemFormatter a
+jsonFormat withColor verb i = appendNL $
+  textBuilderToBS $
+  colorBySeverity withColor (_itemSeverity i) $
+  encodeToTextBuilder $ itemJson verb i
+
+-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
+-- are colored red, `WarningS` is colored yellow, and all other messages are
+-- rendered in the default color.
+colorBySeverity :: Bool -> Severity -> TL.Builder -> TL.Builder
+colorBySeverity withColor severity msg = case severity of
+  EmergencyS -> red msg
+  AlertS     -> red msg
+  CriticalS  -> red msg
+  ErrorS     -> red msg
+  WarningS   -> yellow msg
+  _          -> msg
+  where
+    red = colorize "31"
+    yellow = colorize "33"
+    colorize c s
+      | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
+      | otherwise = s
+
+
+-- | Provides a simple log environment with 1 scribe going to
+-- stdout. This is a decent example of how to build a LogEnv and is
+-- best for scripts that just need a quick, reasonable set up to log
+-- to stdout.
+ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv
+ioLogEnv permit verb = do
+  le <- initLogEnv "io" "io"
+  lh <- mkHandleScribe ColorIfTerminal stdout permit verb
+  registerScribe "stdout" lh defaultScribeSettings le

src/Katip/Scribes/SyncHandle/FileOwner.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+module Katip.Scribes.SyncHandle.FileOwner where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Debounce
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.ByteString.Lazy   as BL
+import Data.IORef
+import GHC.IO.Handle
+import GHC.IO.Handle.FD
+import GHC.IO.IOMode
+
+#if MIN_VERSION_base(4,8,0)
+import Numeric.Natural
+#endif
+
+
+-- | File owner struct writing data to the file
+-- sequentially. Automatic buffer flushing and log rotating.
+data FileOwner = FileOwner
+  { foDataQueune   :: TBQueue BL.ByteString
+  , foControlQueue :: TBQueue ControlMsg
+  , foAsync        :: Async ()
+    -- ^ Wait for to be sure that worker thread is closed.
+  }
+
+#if MIN_VERSION_base(4,8,0)
+type QueueLen = Natural
+#else
+type QueueLen = Int
+#endif
+
+data FileOwnerSettings = FileOwnerSettings
+  { fosDebounceFreq    :: Maybe Int
+  , fosDataQueueLen    :: QueueLen
+  , fosControlQueueLen :: QueueLen
+  }
+
+defaultFileOwnerSettings :: FileOwnerSettings
+defaultFileOwnerSettings = FileOwnerSettings
+  { fosDebounceFreq    = Just 200000 -- every 200ms
+  , fosDataQueueLen    = 1000
+  , fosControlQueueLen = 100
+  }
+
+data ControlMsg
+  = CloseMsg
+  | FlushMsg
+  | ReopenMsg
+  deriving (Eq, Ord, Show)
+
+newFileOwner :: FilePath -> FileOwnerSettings -> IO FileOwner
+newFileOwner fp s = do
+  dqueue <- newTBQueueIO $ fosDataQueueLen s
+  cqueue <- newTBQueueIO $ fosControlQueueLen s
+  let
+    newResource = do
+      openBinaryFile fp AppendMode
+    ack = newResource >>= newIORef
+    release ref = do
+      h <- readIORef ref
+      hFlush h
+      hClose h
+    go ref = do
+      let
+        readAllData = do
+          a <- readTBQueue dqueue
+          -- flushTBQueue never retries
+          as <- flushTBQueue dqueue
+          return $ a:as
+        readMsg
+          =   (Left <$> readTBQueue cqueue)
+          <|> (Right <$> readAllData)
+        debounce action = case fosDebounceFreq s of
+          Nothing -> do
+            return $ return ()
+          Just freq -> mkDebounce $ defaultDebounceSettings
+            { debounceAction = action
+            , debounceFreq   = freq }
+      flush <- debounce $ readIORef ref >>= hFlush
+      let
+        recur = atomically readMsg >>= \case
+          Right bs -> do
+            h <- readIORef ref
+            BL.hPutStr h $ mconcat bs
+            flush -- auto debounced flush
+            recur
+          Left c -> case c of
+            CloseMsg -> do
+              lastMsgs <- atomically $ flushTBQueue dqueue
+              -- flush never blocks
+              case lastMsgs of
+                [] -> return ()
+                _  -> do
+                  h <- readIORef ref
+                  BL.hPutStr h $ mconcat lastMsgs
+                  return () -- release will flush and close the handler
+            FlushMsg -> do
+              readIORef ref >>= hFlush
+              recur
+            ReopenMsg -> do
+              newH <- newResource
+              oldH <- atomicModifyIORef' ref (\oldH -> (newH, oldH))
+              hFlush oldH
+              hClose oldH
+              recur
+      recur
+    worker :: IO ()
+    worker = try (bracket ack release go) >>= \case
+      Left (_ :: SomeException)   -> do
+        threadDelay 100000
+        -- to not restart the worker function too often
+        worker
+        -- We dont want the worker thread become unavailable because
+        -- of exceptions. E.g. could not create or write the file.
+      Right ()                    -> return ()
+  asyncRet <- async worker
+  return $ FileOwner
+    { foDataQueune   = dqueue
+    , foControlQueue = cqueue
+    , foAsync        = asyncRet
+    }
+
+fileOwnerControl :: FileOwner -> ControlMsg -> IO ()
+fileOwnerControl fo msg = do
+  atomically $ writeTBQueue (foControlQueue fo) msg
+  when (msg == CloseMsg) $ do
+    -- Wait for worker thread to finish
+    void $ waitCatch $ foAsync fo
+
+writeFileOwner :: FileOwner -> BL.ByteString -> IO ()
+writeFileOwner fo bs = do
+  a <- return $!! bs
+  -- The deepseq here is to be sure that writing thread will not
+  -- calculate thunks and will not get into the blackhole or
+  -- something. Precalculating is the responsibility of the sending
+  -- thread, because there may be several sending threads and only one
+  -- writing.
+  atomically $ writeTBQueue (foDataQueune fo) $!! a

stack.yaml

@@ -0,0 +1,67 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/9.yaml
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.5"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor