diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for placeholder + +## 0.1.0.0 -- 2023-10-26 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Eldritch Cookie + +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 Eldritch Cookie 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. diff --git a/katip-effectful.cabal b/katip-effectful.cabal new file mode 100644 --- /dev/null +++ b/katip-effectful.cabal @@ -0,0 +1,113 @@ +cabal-version: 3.4 + +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'placeholder' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: katip-effectful + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +version: 0.0.1 + +-- A short (one-line) description of the package. +synopsis: Katip integration for Effectful + +-- A longer description of the package. +description: + Provides a Katip and KatipContext instance for the Eff Monad and re-exports all of Katip's API + +homepage: https://github.com/eldritch-cookie/katip-effectful + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Eldritch Cookie + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: eldritch.cookie@disroot.org + +-- A copyright notice. +-- copyright: +build-type: Simple +bug-reports: https://github.com/eldritch-cookie/katip-effectful/issues + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md +category: library, logging, data, bsd3 + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +common deps + ghc-options: -Wall + build-depends: + , base >=4.17.2 && <5 + , effectful-core >=2.2.2 && <3 + , effectful-plugin >=1.1.0.2 && <1.2 + , katip >=0.8.7 && <1 + , template-haskell >=2.19.0.0 && <2.20 + , text >=2.0.2 && <3 + + default-extensions: + DataKinds + DerivingStrategies + DerivingVia + DuplicateRecordFields + FunctionalDependencies + NoCUSKs + NoFieldSelectors + NoStarIsType + OverloadedRecordDot + OverloadedStrings + QuantifiedConstraints + ScopedTypeVariables + TypeFamilyDependencies + TypeOperators + + default-language: GHC2021 + +library + import: deps + exposed-modules: Effectful.Katip + hs-source-dirs: src + +test-suite katip-effectful-test + import: deps + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: OutputTest + ghc-options: -threaded + build-depends: + , containers >=0.6.7 && <1 + , katip-effectful + , QuickCheck >=2.14.3 && <3 + , quickcheck-instances >=0.3.29.1 && <0.4 + , tasty >=1.4.3 && <2 + , tasty-golden >=2.3.5 && <3 + , tasty-hunit >=0.10.1 && <1 + , tasty-quickcheck >=0.10.2 && <1 + , text >=2.0.2 && <3 + , time >=1.12.2 && <2 + , unix >=2.7.3 && <3 + + build-tool-depends: tasty-discover:tasty-discover + +source-repository head + type: git + location: https://github.com/eldritch-cookie/katip-effectful diff --git a/src/Effectful/Katip.hs b/src/Effectful/Katip.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Katip.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | +Module: Effectful.Katip +Description: Effect to use Katip +-} +module Effectful.Katip ( + -- * Framework Types + Namespace (..), + Environment (..), + Severity (..), + renderSeverity, + textToSeverity, + Verbosity (..), + ToObject (..), + LogItem (..), + Item (..), + ThreadIdText (..), + PayloadSelection (..), + Scribe (..), + LogEnv (..), + SimpleLogPayload, + sl, + defaultScribeSettings, + ScribeSettings, + scribeBufferSize, + _scribeBufferSize, + + -- ** @lens@-Compatible Lenses + itemApp, + itemEnv, + itemSeverity, + itemThread, + itemHost, + itemProcess, + itemPayload, + itemMessage, + itemTime, + itemNamespace, + itemLoc, + logEnvHost, + logEnvPid, + logEnvApp, + logEnvEnv, + logEnvTimer, + logEnvScribes, + + -- * Effect + KatipE, + + -- ** Running The Effect + runKatipE, + runKatipContextE, + startKatipE, + startKatipContextE, + + -- * Initializing Loggers + registerScribe, + + -- * Dropping Scribes Temporarily + unregisterScribe, + clearScribes, + + -- * Finalizing Scribes At Shutdown + closeScribe, + + -- * Logging Functions + LogStr (..), + logStr, + ls, + showLS, + + -- ** Katip Logging Functions + getLogEnv, + localLogEnv, + logF, + logMsg, + logT, + logLoc, + logItem, + logKatipItem, + logException, + + -- ** KatipContext Logging Functions + getKatipContext, + localKatipContext, + getKatipNamespace, + localKatipNamespace, + logFM, + logTM, + logLocM, + logItemM, + logExceptionM, + AnyLogContext, + LogContexts, + liftPayload, + + -- *** Temporarily Changing Log Behaviour + katipAddNamespace, + katipAddContext, + katipNoLogging, + + -- * Included Scribes + mkHandleScribe, + mkHandleScribeWithFormatter, + mkFileScribe, + ColorStrategy (..), + ItemFormatter, + bracketFormat, + jsonFormat, + + -- * Tools For Implementing Scribes + PermitFunc, + permitAND, + permitOR, + permitItem, + payloadObject, + itemJson, +) where + +import Effectful +import Effectful.Dispatch.Static +import Katip ( + -- logging + + -- logContext + AnyLogContext, + -- formatting + ColorStrategy (..), + Environment (..), + Item (..), + ItemFormatter, + LogContexts, + LogEnv (..), + LogItem (..), + LogStr (..), + Namespace (..), + PayloadSelection (..), + -- permission + PermitFunc, + Scribe (..), + ScribeSettings, + Severity (..), + SimpleLogPayload, + ThreadIdText (..), + ToObject (..), + Verbosity (..), + bracketFormat, + -- removing scribe + + clearScribes, + defaultScribeSettings, + itemApp, + itemEnv, + itemHost, + itemJson, + itemLoc, + itemMessage, + itemNamespace, + itemPayload, + itemProcess, + itemSeverity, + itemThread, + itemTime, + jsonFormat, + liftPayload, + logEnvApp, + logEnvEnv, + logEnvHost, + logEnvPid, + logEnvScribes, + logEnvTimer, + logStr, + ls, + payloadObject, + permitAND, + permitItem, + permitOR, + renderSeverity, + scribeBufferSize, + showLS, + sl, + textToSeverity, + unregisterScribe, + _scribeBufferSize, + ) + +import Data.Kind +import Data.Text (Text) +import Katip qualified as K +import Katip.Core (getLocTH) +import Language.Haskell.TH (Loc) +import Language.Haskell.TH.Lib +import System.IO (Handle) +import Unsafe.Coerce (unsafeCoerce) + +-- | A Effect you can use to run logging actions. there is only one effect as we can't have duplicated instances. +type KatipE :: Effect +data KatipE m a + +type instance DispatchOf KatipE = Static WithSideEffects + +data instance StaticRep KatipE = MkKatipE !LogEnv !LogContexts !Namespace + +-- | Run a KatipE Effect without a 'Namespace' or a 'LogContexts'. This also calls closeScribes +runKatipE :: forall es a. (IOE :> es) => LogEnv -> Eff (KatipE : es) a -> Eff es a +runKatipE l act = evalStaticRep (MkKatipE l mempty mempty) act <* liftIO (K.closeScribes l) + +-- | Run a KatipE Effect with a 'Namespace' and a 'LogContexts'. this also calls closeScribes +runKatipContextE :: forall es a a1. (LogItem a, IOE :> es) => LogEnv -> a -> Namespace -> Eff (KatipE : es) a1 -> Eff es a1 +runKatipContextE l pl ns act = evalStaticRep (MkKatipE l (liftPayload pl) ns) act <* liftIO (K.closeScribes l) + +instance forall es. (IOE :> es, KatipE :> es) => K.Katip (Eff es) where + getLogEnv :: (IOE :> es, KatipE :> es) => Eff es LogEnv + getLogEnv = getLogEnv + localLogEnv :: + (IOE :> es, KatipE :> es) => + (LogEnv -> LogEnv) -> + Eff es a -> + Eff es a + localLogEnv = localLogEnv +instance forall es. (IOE :> es, KatipE :> es) => K.KatipContext (Eff es) where + getKatipContext :: Eff es LogContexts + getKatipContext = getKatipContext + localKatipContext :: + (IOE :> es, KatipE :> es) => + (LogContexts -> LogContexts) -> + Eff es a -> + Eff es a + localKatipContext = localKatipContext + getKatipNamespace :: (IOE :> es, KatipE :> es) => Eff es Namespace + getKatipNamespace = getKatipNamespace + localKatipNamespace :: + (IOE :> es, KatipE :> es) => + (Namespace -> Namespace) -> + Eff es a -> + Eff es a + localKatipNamespace = localKatipNamespace + +-- | Run a KatipE Effect without a 'Namespace' or a 'LogContexts' and creating a 'LogEnv' +startKatipE :: (IOE :> es) => Namespace -> Environment -> Eff (KatipE : es) a -> Eff es a +startKatipE ns env act = liftIO (K.initLogEnv ns env) >>= \lenv -> runKatipE lenv act + +-- | Run a KatipE Effect with a 'Namespace' and a 'LogContexts' and creating a 'LogEnv' +startKatipContextE :: (IOE :> es, LogItem a) => Environment -> a -> Namespace -> Eff (KatipE : es) a1 -> Eff es a1 +startKatipContextE env a ns act = liftIO (K.initLogEnv ns env) >>= \e -> runKatipContextE e a ns act + +{- | Add a scribe to the list. +All future log calls will go to this scribe in addition to the others. +Writes will be buffered per the ScribeSettings to prevent slow scribes from slowing down logging. +Writes will be dropped if the buffer fills. +-} +registerScribe :: (KatipE :> es) => Text -> Scribe -> ScribeSettings -> Eff es () +registerScribe txt scrb scrbs = do + MkKatipE lenv lctx ns <- getStaticRep + nlenv <- unsafeEff_ $ K.registerScribe txt scrb scrbs lenv + putStaticRep $ MkKatipE nlenv lctx ns + +-- | Finalize a scribe early. Note that it isn't necessary to call this as both 'runKatipE' and 'runKatipContextE' call 'K.closeScribes' +closeScribe :: (KatipE :> es) => Text -> Eff es () +closeScribe name = do + MkKatipE le lc ns <- getStaticRep + newle <- unsafeEff_ $ K.closeScribe name le + putStaticRep $ MkKatipE newle lc ns +-- | get the 'KatipE' 'LogEnv' +getLogEnv :: forall es. (KatipE :> es) => Eff es LogEnv +getLogEnv = do + s <- getStaticRep @KatipE + case s of + MkKatipE le _ _ -> return le +-- | temporarily modify the 'LogEnv' +localLogEnv :: forall es a. (KatipE :> es) => (LogEnv -> LogEnv) -> Eff es a -> Eff es a +localLogEnv f = localStaticRep @KatipE $ \(MkKatipE le lc ns) -> MkKatipE (f le) lc ns +-- | get the 'KatipE' 'LogContexts' +getKatipContext :: (KatipE :> es) => Eff es LogContexts +getKatipContext = do + s <- getStaticRep @KatipE + case s of + MkKatipE _ lc _ -> return lc +-- | temporarily modify the 'LogContexts' +localKatipContext :: forall es a. (KatipE :> es) => (LogContexts -> LogContexts) -> Eff es a -> Eff es a +localKatipContext f = localStaticRep @KatipE $ \(MkKatipE le lc ns) -> MkKatipE le (f lc) ns +getKatipNamespace :: forall es. (KatipE :> es) => Eff es Namespace +-- | get the 'KatipE' 'Namespace' +getKatipNamespace = do + s <- getStaticRep @KatipE + case s of + MkKatipE _ _ ns -> return ns +-- | temporarily modify the 'Namespace' +localKatipNamespace :: forall es a. (KatipE :> es) => (Namespace -> Namespace) -> Eff es a -> Eff es a +localKatipNamespace f = localStaticRep @KatipE $ \(MkKatipE le lc ns) -> MkKatipE le lc $ f ns + +-- | escape hatch for implementing your own scribes +unsafeEmbedIOE :: forall es a. (KatipE :> es) => ((KatipE :> es, IOE :> es) => Eff es a) -> Eff es a +unsafeEmbedIOE act = useDict (unsafeCoerce (MkDict @(KatipE :> es)) :: Dict (KatipE :> es, IOE :> es)) act + +type Dict :: Constraint -> Type +data Dict a where + MkDict :: (a) => Dict a + +useDict :: forall a r. Dict a -> ((a) => r) -> r +useDict MkDict r = r +-- | Log with full context, but without any code location. +logF :: forall a es. (LogItem a, KatipE :> es) => a -> Namespace -> Severity -> LogStr -> Eff es () +logF a ns sev logs = unsafeEmbedIOE $ K.logF a ns sev logs + +-- | Log a message without any payload/context or code location. +logMsg :: forall es. (KatipE :> es) => Namespace -> Severity -> LogStr -> Eff es () +logMsg ns sev logs = unsafeEmbedIOE $ K.logMsg ns sev logs + +{-# INLINE logT #-} +-- | Loc-tagged logging when using template-haskell. +-- @ +-- $(logT) obj mempty InfoS "Hello world" +-- @ +logT :: ExpQ +logT = [|\a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg|] + +{-# INLINE logLoc #-} +-- | 'Loc'-tagged logging using 'GHC.Stack.Stack' when available. +-- This function does not require template-haskell as it automatically uses implicit-callstacks when the code is compiled using GHC > 7.8. +-- Using an older version of the compiler will result in the emission of a log line without any location information, so be aware of it. +-- @ +-- logLoc obj mempty InfoS "Hello world" +-- @ +logLoc :: (LogItem a, KatipE :> es, HasCallStack) => a -> Namespace -> Severity -> LogStr -> Eff es () +logLoc a ns sev logs = unsafeEmbedIOE $ K.logLoc a ns sev logs +-- | Log with everything, including a source code location. +-- This is very low level and you typically can use 'logT' in its place. +logItem :: (LogItem a, KatipE :> es) => a -> Namespace -> Maybe Loc -> Severity -> LogStr -> Eff es () +logItem a ns loc sev logs = unsafeEmbedIOE $ K.logItem a ns loc sev logs +-- | Log an already constructed 'Item'. +-- This is the lowest level function that other log* functions use. +-- It can be useful when implementing centralised logging services. +logKatipItem :: (LogItem a, KatipE :> es) => Item a -> Eff es () +logKatipItem item = unsafeEmbedIOE $ K.logKatipItem item +-- | Perform an action while logging any exceptions that may occur. +-- @ +-- >>> > logException () mempty ErrorS (error "foo") +-- @ +logException :: (LogItem a, KatipE :> es) => a -> Namespace -> Severity -> Eff es b -> Eff es b +logException a ns sev act = unsafeEmbedIOE $ K.logException a ns sev act +-- | Log with full context, but without any code location. +-- Automatically supplies payload and namespace. +logFM :: (KatipE :> es) => Severity -> LogStr -> Eff es () +logFM sev logs = unsafeEmbedIOE $ K.logFM sev logs + +{-# INLINE logTM #-} +-- | 'Loc'-tagged logging when using template-haskell. +-- Automatically supplies payload and namespace. +-- @ +-- $(logTM) InfoS "Hello world" +-- @ +logTM :: ExpQ +logTM = [|logItemM (Just $(getLocTH))|] +{-#INLINE logLocM #-} +-- | 'Loc'-tagged logging when using 'GHC.Stack.getCallStack' implicit-callstacks. +-- Automatically supplies payload and namespace. +-- Same consideration as 'logLoc' applies +-- By default, location will be logged from the module that invokes logLocM. +-- If you want to use logLocM in a helper, +-- wrap the entire helper in withFrozenCallStack to retain the callsite of the helper in the logs. +-- This function does not require template-haskell. +-- @ +-- logLocM InfoS "Hello world" +-- @ +logLocM :: (KatipE :> es, HasCallStack) => Severity -> LogStr -> Eff es () +logLocM sev logs = unsafeEmbedIOE $ K.logLocM sev logs +-- | Log with everything, including a source code location. +-- This is very low level and you typically can use 'logTM' in its place. +-- Automatically supplies payload and namespace. +logItemM :: (KatipE :> es, HasCallStack) => Maybe Loc -> Severity -> LogStr -> Eff es () +logItemM loc sev logs = unsafeEmbedIOE $ K.logItemM loc sev logs +-- | Perform an action while logging any exceptions that may occur. +-- @ +-- >>> > error "foo" `logExceptionM` ErrorS +-- @ +logExceptionM :: (KatipE :> es) => Eff es a -> Severity -> Eff es a +logExceptionM act sev = unsafeEmbedIOE $ K.logExceptionM act sev + +-- | Append a namespace segment to the current namespace for the given monadic action, +-- then restore the previous state afterwards. +katipAddNamespace :: (KatipE :> es) => Namespace -> Eff es a -> Eff es a +katipAddNamespace ns = localKatipNamespace (<> ns) +-- | Append some context to the current context for the given monadic action, +-- then restore the previous state afterwards. +-- Important note: be careful using this in a loop. +-- If you're using something like forever or replicateM_ that does explicit sharing to avoid a memory leak, +-- youll be fine as it will *sequence* calls to katipAddNamespace, +-- so each loop will get the same context added. +-- If you instead roll your own recursion and you're recursing in the action you provide, +-- you'll instead accumulate tons of redundant contexts and even if they all merge on log, +-- they are stored in a sequence and will leak memory. +katipAddContext :: (KatipE :> es, LogItem i) => i -> Eff es a -> Eff es a +katipAddContext ctx = localKatipContext (<> liftPayload ctx) +-- | Disable all scribes for the given monadic action, +-- then restore them afterwards. +katipNoLogging :: (KatipE :> es) => Eff es a -> Eff es a +katipNoLogging = localLogEnv $ \lenv -> lenv{_logEnvScribes = mempty} + +-- | 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 'System.IO.LineBuffering' automatically. +mkHandleScribe :: forall es. (KatipE :> es) => ColorStrategy -> Handle -> PermitFunc -> Verbosity -> Eff es Scribe +mkHandleScribe cs h pf v = unsafeEmbedIOE $ liftIO $ K.mkHandleScribe cs h pf v +-- | 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 'System.IO.LineBuffering' automatically. +mkHandleScribeWithFormatter :: forall es. (KatipE :> es) => (forall a. (LogItem a) => ItemFormatter a) -> ColorStrategy -> Handle -> PermitFunc -> Verbosity -> Eff es Scribe +mkHandleScribeWithFormatter ifa cs h pf v = unsafeEmbedIOE $ liftIO $ K.mkHandleScribeWithFormatter ifa cs h pf v +-- | A specialization of 'mkHandleScribe' that takes a 'FilePath' instead of a 'Handle'. It is responsible for opening the file in 'System.IO.AppendMode' and will close the file handle on closeScribe/closeScribes. Does not do log coloring. Sets handle to 'System.IO.LineBuffering' mode. +mkFileScribe :: forall es. (KatipE :> es) => FilePath -> PermitFunc -> Verbosity -> Eff es Scribe +mkFileScribe fp pf v = unsafeEmbedIOE $ liftIO $ K.mkFileScribe fp pf v diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/OutputTest.hs b/test/OutputTest.hs new file mode 100644 --- /dev/null +++ b/test/OutputTest.hs @@ -0,0 +1,111 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module OutputTest where + +import Control.Monad (replicateM) +import Data.Text.Lazy.Builder (Builder, fromText) +import Effectful (runEff) +import Effectful.Katip +import System.IO (Handle, IOMode (..), hGetContents', openFile) +import Test.QuickCheck.Instances () +import Test.Tasty.QuickCheck + +import Data.Text (Text) +import Katip (closeScribes, runKatipContextT) +import Katip qualified as K + +getInteger :: Int -> Gen Int +getInteger s = chooseInt (0, s) + +instance Arbitrary Namespace where + arbitrary = do + num <- sized getInteger + Namespace <$> replicateM num arbitrary + shrink = genericShrink +instance Arbitrary Environment where + arbitrary = Environment <$> arbitrary + shrink = genericShrink +instance Arbitrary Severity where + arbitrary = chooseEnum (minBound, maxBound) + shrink = genericShrink +instance Arbitrary Verbosity where + arbitrary = chooseEnum (minBound, maxBound) + shrink = genericShrink +instance Arbitrary LogStr where + arbitrary = LogStr <$> arbitrary + shrink = genericShrink +instance Arbitrary Builder where + arbitrary = fromText <$> arbitrary +instance Arbitrary SimpleLogPayload where + arbitrary = sl @Text <$> arbitrary <*> arbitrary + +instance Show SimpleLogPayload where + show = show . toObject + +prop_EqualOutputLFM :: Severity -> Namespace -> LogStr -> Property +prop_EqualOutputLFM severity ns str = ioProperty $ do + h1 <- openFile "scribeKCT.log" ReadWriteMode + le1 <- logEnvWithScribe h1 + runKatipContextT le1 () ns $ K.logFM severity str + _ <- closeScribes le1 + s1 <- hGetContents' h1 + h2 <- openFile "scribeEff.log" ReadWriteMode + le2 <- logEnvWithScribe h2 + runEff . runKatipContextE le2 () ns $ logFM severity str + _ <- closeScribes le2 + s2 <- hGetContents' h2 + cleanup + return $ s1 == s2 +prop_EqualOutputLF :: SimpleLogPayload -> Namespace -> Severity -> LogStr -> Property +prop_EqualOutputLF slp ns severity str = ioProperty $ do + h1 <- openFile "scribeKCT.log" ReadWriteMode + le1 <- logEnvWithScribe h1 + runKatipContextT le1 () ns $ K.logF slp ns severity str + _ <- closeScribes le1 + s1 <- hGetContents' h1 + h2 <- openFile "scribeEff.log" ReadWriteMode + le2 <- logEnvWithScribe h2 + runEff . runKatipContextE le2 () ns $ logF slp ns severity str + _ <- closeScribes le2 + s2 <- hGetContents' h2 + cleanup + return $ s1 == s2 + +prop_EqualOutputLMsg :: Namespace -> Severity -> LogStr -> Property +prop_EqualOutputLMsg ns severity str = ioProperty $ do + h1 <- openFile "scribeKCT.log" ReadWriteMode + le1 <- logEnvWithScribe h1 + runKatipContextT le1 () ns $ K.logMsg ns severity str + _ <- closeScribes le1 + s1 <- hGetContents' h1 + h2 <- openFile "scribeEff.log" ReadWriteMode + le2 <- logEnvWithScribe h2 + runEff . runKatipContextE le2 () ns $ logMsg ns severity str + _ <- closeScribes le2 + s2 <- hGetContents' h2 + cleanup + return $ s1 == s2 +prop_EqualOutputLLoc :: SimpleLogPayload -> Namespace -> Severity -> LogStr -> Property +prop_EqualOutputLLoc slp ns severity str = ioProperty $ do + h1 <- openFile "scribeKCT.log" ReadWriteMode + le1 <- logEnvWithScribe h1 + runKatipContextT le1 () ns $ K.logLoc slp ns severity str + _ <- closeScribes le1 + s1 <- hGetContents' h1 + h2 <- openFile "scribeEff.log" ReadWriteMode + le2 <- logEnvWithScribe h2 + runEff . runKatipContextE le2 () ns $ logLoc slp ns severity str + _ <- closeScribes le2 + s2 <- hGetContents' h2 + cleanup + return $ s1 == s2 +cleanup :: IO () +cleanup = do + writeFile "scribeKCT.log" [] + writeFile "scribeEff.log" [] + +logEnvWithScribe :: Handle -> IO LogEnv +logEnvWithScribe fp = do + initialLE <- K.initLogEnv "testing" "testing" + s <- K.mkHandleScribe ColorIfTerminal fp (\_ -> pure True) V3 + K.registerScribe "test" s defaultScribeSettings initialLE