From a7ab193017508743832a4e991e52e939d7bbc749 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Oct 2025 14:29:22 +0200 Subject: [PATCH 1/4] Add tests for logging with log-base --- log-base/log-base.cabal | 57 ++++++++++----- log-base/src/Log/Data.hs | 2 +- log-base/tests/Driver.hs | 1 + log-base/tests/LoggerTest.hs | 130 +++++++++++++++++++++++++++++++++++ 4 files changed, 173 insertions(+), 17 deletions(-) create mode 100644 log-base/tests/Driver.hs create mode 100644 log-base/tests/LoggerTest.hs diff --git a/log-base/log-base.cabal b/log-base/log-base.cabal index bb75e1b..a82d4bd 100644 --- a/log-base/log-base.cabal +++ b/log-base/log-base.cabal @@ -20,14 +20,33 @@ maintainer: Andrzej Rybczak , copyright: Scrive AB category: System build-type: Simple -extra-source-files: CHANGELOG.md, README.md +extra-doc-files: CHANGELOG.md, README.md tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2 } source-repository head type: git location: https://github.com/scrive/log.git +common shared + ghc-options: -Wall + default-language: Haskell2010 + default-extensions: BangPatterns + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , LambdaCase + , MultiParamTypeClasses + , NumericUnderscores + , OverloadedStrings + , RankNTypes + , RecordWildCards + , ScopedTypeVariables + , TypeFamilies + , UndecidableInstances + + library + import: shared exposed-modules: Log, Log.Backend.LogList, Log.Backend.StandardOutput, @@ -39,6 +58,7 @@ library Log.Internal.Logger, Log.Logger, Log.Monad + build-depends: base >= 4.13 && <5, aeson >= 1.0, aeson-pretty >=0.8.2, @@ -57,18 +77,23 @@ library unordered-containers hs-source-dirs: src - ghc-options: -Wall - - default-language: Haskell2010 - default-extensions: BangPatterns - , FlexibleContexts - , FlexibleInstances - , GeneralizedNewtypeDeriving - , LambdaCase - , MultiParamTypeClasses - , OverloadedStrings - , RankNTypes - , RecordWildCards - , ScopedTypeVariables - , TypeFamilies - , UndecidableInstances +test-suite log-base-tests + import: shared + type: exitcode-stdio-1.0 + main-is: Driver.hs + hs-source-dirs: tests + ghc-options: -threaded -rtsopts + build-depends: + , base + , aeson + , log-base + , hedgehog + , tasty + , tasty-hedgehog + , tasty-hunit + , tasty-discover + , text + build-tool-depends: + tasty-discover:tasty-discover + other-modules: + LoggerTest diff --git a/log-base/src/Log/Data.hs b/log-base/src/Log/Data.hs index 6e82a79..65bbd2d 100644 --- a/log-base/src/Log/Data.hs +++ b/log-base/src/Log/Data.hs @@ -24,7 +24,7 @@ import qualified Data.Monoid as Monoid -- Note that ordering in this definintion determines what the maximum log level is. -- See 'Log.Monad.leMaxLogLevel'. data LogLevel = LogAttention | LogInfo | LogTrace - deriving (Bounded, Eq, Ord, Show) + deriving (Bounded, Enum, Eq, Ord, Show) -- | This function is partial. readLogLevel :: T.Text -> LogLevel diff --git a/log-base/tests/Driver.hs b/log-base/tests/Driver.hs new file mode 100644 index 0000000..70c55f5 --- /dev/null +++ b/log-base/tests/Driver.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/log-base/tests/LoggerTest.hs b/log-base/tests/LoggerTest.hs new file mode 100644 index 0000000..0bd758a --- /dev/null +++ b/log-base/tests/LoggerTest.hs @@ -0,0 +1,130 @@ +module LoggerTest where + +import Control.Concurrent +import Control.Monad.IO.Class +import Data.Foldable (for_, traverse_) +import Data.List +import qualified Data.Text as T +import qualified Hedgehog as H +import qualified Hedgehog.Gen as H +import qualified Hedgehog.Range as HR +import Log +import Log.Internal.Logger +import Test.Tasty +import Test.Tasty.Hedgehog + +test_logger :: [TestTree] +test_logger = + [ testProperty "Sends all messages in order" $ H.property $ do + inorderTest mkTestLogger + , testProperty "Drops messages after capacity is reached" $ H.property $ do + dropMessagesTest mkTestLogger + , testProperty "Obeys log levels" $ H.property $ do + inputs <- H.forAll $ H.list (HR.linear 0 1000) (H.int HR.linearBounded) + mask <- H.forAll $ H.list (HR.singleton (length inputs)) H.enumBounded + let logInputs = zip (fmap (T.pack . show) inputs) mask + + logTrail@LogTrail {..} <- liftIO mkLogTrail + logger <- liftIO $ mkTestLogger 1000 logTrail + runLogT "test" logger LogInfo $ do + for_ logInputs $ \(msg, level) -> do + case level of + LogAttention -> logAttention_ msg + LogInfo -> logInfo_ msg + LogTrace -> logTrace_ msg + + liftIO $ loggerWaitForWrite logger + let expectedOutput = map fst $ filter ((<= LogInfo) . snd) logInputs + let traceOutput = filter ((== LogTrace) . snd) logInputs + + outputs <- liftIO trail + expectedOutput H.=== fmap lmMessage (concat outputs) + length logInputs - length (concat outputs) H.=== length traceOutput + ] + +test_bulkLogger :: [TestTree] +test_bulkLogger = + [ testProperty "Sends all messages in order" $ H.property $ do + inorderTest $ \cap -> mkBulkTestLogger cap 10_000 + , testProperty "Drops messages after capacity is reached" $ H.property $ do + dropMessagesTest $ \cap -> mkBulkTestLogger cap 10_000 + , testProperty "Sends all messages in multiple bulks" $ H.property $ do + inputs <- H.forAll $ H.list (HR.singleton 70) (H.int HR.linearBounded) + bulkSizes <- H.forAll $ H.int (HR.linear 10 40) + let logInputs = fmap (T.pack . show) inputs + + logTrail@LogTrail {..} <- liftIO mkLogTrail + logger <- liftIO $ mkBulkTestLogger 1000 10_000 logTrail + let chunks = chunksOf bulkSizes logInputs + for_ chunks $ \chunk -> runLogT "test" logger LogInfo $ do + traverse_ logInfo_ chunk + liftIO $ loggerWaitForWrite logger + + outputs <- liftIO trail + logInputs H.=== fmap lmMessage (concat outputs) + (length outputs >= 2) H.=== True + ] + +inorderTest :: (Monad m, MonadIO m) => (Int -> LogTrail -> IO Logger) -> H.PropertyT m () +inorderTest mkTestLog = do + inputs <- H.forAll $ H.list (HR.linear 0 100) (H.int HR.linearBounded) + let logInputs = fmap (T.pack . show) inputs + + logTrail@LogTrail {..} <- liftIO mkLogTrail + logger <- liftIO $ mkTestLog 1000 logTrail + liftIO $ runLogT "test" logger LogInfo $ do + traverse_ logInfo_ logInputs + liftIO $ loggerWaitForWrite logger + + outputs <- liftIO trail + logInputs H.=== fmap lmMessage (concat outputs) + if null logInputs + then length outputs H.=== 0 + else not (null outputs) H.=== True + +dropMessagesTest :: (Monad m, MonadIO m) => (Int -> LogTrail -> IO Logger) -> H.PropertyT m () +dropMessagesTest mkTestLog = do + let capacity = 10 + inputs <- H.forAll $ H.list (HR.linear capacity 100) (H.int HR.linearBounded) + let logInputs = fmap (T.pack . show) inputs + + logTrail@LogTrail {..} <- liftIO mkLogTrail + logger <- liftIO $ mkTestLog 10 logTrail + liftIO $ runLogT "test" logger LogInfo $ do + traverse_ logInfo_ logInputs + liftIO $ loggerWaitForWrite logger + + outputs <- liftIO trail + fmap lmMessage (concat outputs) `isSubsequenceOf` logInputs H.=== True + (length outputs <= length logInputs) H.=== True + +-- | Test utility for tracking the calls the bulk logger makes in the background +-- grouping logmessages that were sent in the same action. +data LogTrail = LogTrail + { trail :: IO [[LogMessage]] + , trailAdd :: [LogMessage] -> IO () + } + +mkLogTrail :: IO LogTrail +mkLogTrail = do + logTrailRef <- newMVar [] + let addLogs new = modifyMVar_ logTrailRef (\logs -> pure (new : logs)) + pure $ + LogTrail + { trail = reverse <$> swapMVar logTrailRef [] + , trailAdd = addLogs + } + +mkBulkTestLogger :: Int -> Int -> LogTrail -> IO Logger +mkBulkTestLogger capacity delayUSec LogTrail {..} = do + mkBulkLogger' capacity delayUSec "testLogger" trailAdd (pure ()) + +mkTestLogger :: Int -> LogTrail -> IO Logger +mkTestLogger capacity LogTrail {..} = do + mkLogger' capacity "testLogger" (trailAdd . (: [])) + +-- | Test utility for tracking the calls the bulk logger makes in the background +-- grouping logmessages that were sent in the same action. +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf n xs = take n xs : chunksOf n (drop n xs) From 270cd515ea0c876aed1af47625697b7565bf1e2d Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Oct 2025 15:17:38 +0200 Subject: [PATCH 2/4] Add fourmolu file --- fourmolu.yaml | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 fourmolu.yaml diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..b47fe72 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,53 @@ +# Number of spaces per indentation step +indentation: 2 + +# Max line length for automatic line breaking +column-limit: none + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: leading + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: leading + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: leading + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: true + +# Whether to leave a space before an opening record brace +record-brace-space: true + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: single-line + +# How to print module docstring +haddock-style-module: null + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: inline + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: no-space + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: never + +# Whether to put parentheses around a single deriving class (choices: auto, always, or never) +single-deriving-parens: always + +# Output Unicode syntax (choices: detect, always, or never) +unicode: never + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] + +# Module reexports Fourmolu should know about +reexports: [] From 86081fe8cc8e3a854f6af6efd0b6c081b967f883 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Oct 2025 15:18:03 +0200 Subject: [PATCH 3/4] Add changelog entries --- log-base/CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/log-base/CHANGELOG.md b/log-base/CHANGELOG.md index f1b1539..1edad6b 100644 --- a/log-base/CHANGELOG.md +++ b/log-base/CHANGELOG.md @@ -1,3 +1,7 @@ +# log-base-0.xx.x.x (xxxx-xx-xx) +* Add base tests in log-base testing message ordering and dropping +* Add fourmolu config file + # log-base-0.12.1.0 (2025-06-26) * Add utility function to log unhandled exceptions. From 25df25be0f5684e00932645f4fef988c4720ece2 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 21 Oct 2025 10:49:47 +0200 Subject: [PATCH 4/4] Enable cabal test on CI --- .github/workflows/haskell-ci.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 9ec5805..7ea4d4a 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -233,6 +233,9 @@ jobs: ${CABAL} -vnormal check cd ${PKGDIR_log_postgres} || false ${CABAL} -vnormal check + - name: cabal tests + run: | + ${CABAL} test $ARG_COMPILER all - name: haddock run: | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all