Implement new --command-log-read-strategy option

tbidne · Jun 2, 2024 · 1d093a5 · 1d093a5
1 parent 008f8f9
commit 1d093a5
Show file tree

Hide file tree

Showing 34 changed files with 1,232 additions and 336 deletions.
diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml
@@ -43,7 +43,7 @@ jobs:
       - name: Integration Tests
         run: cabal test ${{ matrix.ghc.proj-file }} integration
       - name: Functional Tests
-        run: cabal test ${{ matrix.ghc.proj-file }} functional
+        run: cabal test ${{ matrix.ghc.proj-file }} functional --test-options '--read-strategy all'
       - name: Benchmarks
         if: ${{ matrix.os == 'ubuntu-latest' }}
         id: bench

diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -17,6 +17,8 @@ the major/minor/patch definitions apply to the application's interface / usage
 * Updated blessed GHC to 9.8.2.
 
 ### Added
+* Add `--command-log-read-strategy (command-log.read-strategy)` option that
+  allows for line buffering.
 * Added GHC 9.10 support.
 
 ### Fixed

diff --git a/configuration.md b/configuration.md
@@ -11,6 +11,7 @@
     - [Command Logging](#command-logging)
       - [Poll Interval](#poll-interval)
       - [Read Size](#read-size)
+      - [Read Strategy](#read-strategy)
     - [Console Logging](#console-logging)
       - [Command Log](#command-log)
       - [Command Name Truncation](#command-name-truncation)
@@ -202,6 +203,13 @@ Configuration for **command logs**, enabled by `console-log.command` and/or `fil
 <span style="color: #a3fefe">[Timer] 2 seconds</span></code>
 </pre>
 
+
+#### Read Strategy
+
+**Arg:** `--command-log-read-strategy (block | block-line-buffer)`
+
+**Description:** By default (strategy = block), we read read-size number of bytes at a time. The "block-line-buffer" strategy will buffer logs until a newline is found, or some size threshold is crossed. This can help preserve formatting in the file logs.
+
 ### Console Logging
 
 Config related to console logs.

diff --git a/docker/alpine_amd64/Dockerfile b/docker/alpine_amd64/Dockerfile
@@ -40,7 +40,7 @@ echo 'PATH=$PATH:$HOME/.ghcup/bin' >> $HOME/.bashrc
 . $HOME/.bashrc
 
 echo "*** Installing ghc ***"
-ghcup install ghc 9.6.4 --set
+ghcup install ghc 9.8.2 --set
 
 echo "*** Installing cabal ***"
 ghcup install cabal 3.10.3.0 --set

diff --git a/examples/config.toml b/examples/config.toml
@@ -88,6 +88,12 @@ poll-interval = 100
 # across lines. The default is "16 kb".
 read-size = "1 mb"
 
+# By default (strategy = block), we read read-size number of bytes at a time.
+# The "block-line-buffer" strategy will buffer logs until a newline is
+# found, or some size threshold is crossed. This can help preserve formatting
+# in the file logs.
+read-strategy = "block-line-buffer"
+
 # Configuration for console logging.
 [console-log]
 # If enabled, the output of the commands themselves will be logged. The

diff --git a/examples/config_osx.toml b/examples/config_osx.toml
@@ -88,6 +88,12 @@ poll-interval = 100
 # across lines. The default is "16 kb".
 read-size = "1 mb"
 
+# By default (strategy = block), we read read-size number of bytes at a time.
+# The "block-line-buffer" strategy will buffer logs until a newline is
+# found, or some size threshold is crossed. This can help preserve formatting
+# in the file logs.
+read-strategy = "block-line-buffer"
+
 # Configuration for console logging.
 [console-log]
 # If enabled, the output of the commands themselves will be logged. The

diff --git a/examples/default.toml b/examples/default.toml
@@ -88,6 +88,12 @@
 # # across lines. The default is "16 kb".
 # read-size = "1 mb"
 
+# # By default (strategy = block), we read read-size number of bytes at a time.
+# # The "block-line-buffer" strategy will buffer logs until a newline is
+# # found, or some size threshold is crossed. This can help preserve formatting
+# # in the file logs.
+# read-strategy = "block-line-buffer"
+
 # # Configuration for console logging.
 # [console-log]
 # # If enabled, the output of the commands themselves will be logged. The

diff --git a/shrun.cabal b/shrun.cabal
@@ -69,6 +69,7 @@ library
     Shrun.Configuration.Data.CommandLogging
     Shrun.Configuration.Data.CommandLogging.PollInterval
     Shrun.Configuration.Data.CommandLogging.ReadSize
+    Shrun.Configuration.Data.CommandLogging.ReadStrategy
     Shrun.Configuration.Data.CommonLogging
     Shrun.Configuration.Data.CommonLogging.KeyHideSwitch
     Shrun.Configuration.Data.ConfigPhase
@@ -251,15 +252,18 @@ test-suite functional
     Functional.Miscellaneous
     Functional.Notify
     Functional.Prelude
+    Functional.ReadStrategyTest
     Functional.TestArgs
 
   build-depends:
     , base
     , effects-fs
     , env-guard
     , fdo-notify
+    , optparse-applicative
     , shrun
     , shrun-verifier
+    , tagged                ^>=0.8.6
     , tasty
     , tasty-hunit
     , text

diff --git a/src/Shrun/Configuration/Args/Parsing/CommandLogging.hs b/src/Shrun/Configuration/Args/Parsing/CommandLogging.hs
@@ -14,13 +14,16 @@ import Shrun.Configuration.Data.CommandLogging
       ( MkCommandLoggingP,
         pollInterval,
         readSize,
+        readStrategy,
         reportReadErrors
       ),
   )
 import Shrun.Configuration.Data.CommandLogging.PollInterval (PollInterval)
 import Shrun.Configuration.Data.CommandLogging.PollInterval qualified as PollInterval
 import Shrun.Configuration.Data.CommandLogging.ReadSize (ReadSize)
 import Shrun.Configuration.Data.CommandLogging.ReadSize qualified as ReadSize
+import Shrun.Configuration.Data.CommandLogging.ReadStrategy (ReadStrategy)
+import Shrun.Configuration.Data.CommandLogging.ReadStrategy qualified as ReadStrategy
 import Shrun.Configuration.Data.WithDisabled (WithDisabled)
 import Shrun.Configuration.Default (Default (def))
 import Shrun.Prelude
@@ -29,12 +32,14 @@ commandLoggingParser :: Parser CommandLoggingArgs
 commandLoggingParser = do
   pollInterval <- pollIntervalParser
   readSize <- readSizeParser
+  readStrategy <- readStrategyParser
   reportReadErrors <- reportReadErrorsParser
 
   pure
     $ MkCommandLoggingP
       { pollInterval,
         readSize,
+        readStrategy,
         reportReadErrors
       }
 
@@ -94,6 +99,25 @@ readSizeParser = Utils.withDisabledParser mainParser "command-log-read-size"
           "broken across lines. The default is '16 kb'."
         ]
 
+readStrategyParser :: Parser (WithDisabled ReadStrategy)
+readStrategyParser = Utils.withDisabledParser mainParser "command-log-read-strategy"
+  where
+    mainParser =
+      OA.optional
+        $ OA.option (ReadStrategy.parseReadStrategy OA.str)
+        $ mconcat
+          [ OA.long "command-log-read-strategy",
+            Utils.mkHelp helpTxt,
+            OA.metavar ReadStrategy.readStrategyStr
+          ]
+    helpTxt =
+      mconcat
+        [ "By default (strategy = block), we read read-size number of bytes ",
+          "at a time. The block-line-buffer strategy will buffer logs until ",
+          "a newline is found, or some size threshold is crossed. This can ",
+          "help preserve formatting in the file logs."
+        ]
+
 reportReadErrorsParser :: Parser (WithDisabled ())
 reportReadErrorsParser =
   Utils.withDisabledParserOpts

diff --git a/src/Shrun/Configuration/Data/CommandLogging.hs b/src/Shrun/Configuration/Data/CommandLogging.hs
@@ -20,6 +20,7 @@ where
 
 import Shrun.Configuration.Data.CommandLogging.PollInterval (PollInterval)
 import Shrun.Configuration.Data.CommandLogging.ReadSize (ReadSize)
+import Shrun.Configuration.Data.CommandLogging.ReadStrategy (ReadStrategy)
 import Shrun.Configuration.Data.ConfigPhase
   ( ConfigPhase
       ( ConfigPhaseArgs,
@@ -71,6 +72,8 @@ data CommandLoggingP p = MkCommandLoggingP
     -- | Determines the max log size we read from commands in one go.
     -- Note this is not on commandLogging or fileLogging since it affects both.
     readSize :: ConfigPhaseF p ReadSize,
+    -- | Reading strategy.
+    readStrategy :: ConfigPhaseF p ReadStrategy,
     -- | Determines if we should log read errors.
     reportReadErrors :: SwitchF p ReportReadErrorsSwitch
   }
@@ -85,13 +88,15 @@ instance
          ( MkCommandLoggingP
              _pollInterval
              _readSize
+             _readStrategy
              _reportReadErrors
            ) ->
           fmap
             ( \pollInterval' ->
                 MkCommandLoggingP
                   pollInterval'
                   _readSize
+                  _readStrategy
                   _reportReadErrors
             )
             (f _pollInterval)
@@ -107,18 +112,44 @@ instance
          ( MkCommandLoggingP
              _pollInterval
              _readSize
+             _readStrategy
              _reportReadErrors
            ) ->
           fmap
             ( \readSize' ->
                 MkCommandLoggingP
                   _pollInterval
                   readSize'
+                  _readStrategy
                   _reportReadErrors
             )
             (f _readSize)
   {-# INLINE labelOptic #-}
 
+instance
+  (k ~ A_Lens, a ~ ConfigPhaseF p ReadStrategy, b ~ ConfigPhaseF p ReadStrategy) =>
+  LabelOptic "readStrategy" k (CommandLoggingP p) (CommandLoggingP p) a b
+  where
+  labelOptic =
+    lensVL
+      $ \f
+         ( MkCommandLoggingP
+             _pollInterval
+             _readSize
+             _readStrategy
+             _reportReadErrors
+           ) ->
+          fmap
+            ( \readStrategy' ->
+                MkCommandLoggingP
+                  _pollInterval
+                  _readSize
+                  readStrategy'
+                  _reportReadErrors
+            )
+            (f _readStrategy)
+  {-# INLINE labelOptic #-}
+
 instance
   (k ~ A_Lens, a ~ SwitchF p ReportReadErrorsSwitch, b ~ SwitchF p ReportReadErrorsSwitch) =>
   LabelOptic "reportReadErrors" k (CommandLoggingP p) (CommandLoggingP p) a b
@@ -129,12 +160,14 @@ instance
          ( MkCommandLoggingP
              _pollInterval
              _readSize
+             _readStrategy
              _reportReadErrors
            ) ->
           fmap
             ( MkCommandLoggingP
                 _pollInterval
                 _readSize
+                _readStrategy
             )
             (f _reportReadErrors)
   {-# INLINE labelOptic #-}
@@ -161,6 +194,7 @@ deriving stock instance Show (CommandLoggingP ConfigPhaseMerged)
 
 instance
   ( Default (ConfigPhaseF p PollInterval),
+    Default (ConfigPhaseF p ReadStrategy),
     Default (ConfigPhaseF p ReadSize),
     Default (SwitchF p ReportReadErrorsSwitch)
   ) =>
@@ -169,6 +203,7 @@ instance
   def =
     MkCommandLoggingP
       { pollInterval = def,
+        readStrategy = def,
         readSize = def,
         reportReadErrors = def
       }
@@ -182,6 +217,8 @@ mergeCommandLogging args mToml =
   MkCommandLoggingP
     { pollInterval =
         (args ^. #pollInterval) <>?. (toml ^. #pollInterval),
+      readStrategy =
+        (args ^. #readStrategy) <>?. (toml ^. #readStrategy),
       readSize =
         (args ^. #readSize) <>?. (toml ^. #readSize),
       reportReadErrors =
@@ -203,6 +240,7 @@ instance DecodeTOML CommandLoggingToml where
     MkCommandLoggingP
       <$> decodePollInterval
       <*> decodeReadSize
+      <*> decodeReadStrategy
       <*> decodeReportReadErrors
 
 decodePollInterval :: Decoder (Maybe PollInterval)
@@ -211,6 +249,9 @@ decodePollInterval = getFieldOptWith tomlDecoder "poll-interval"
 decodeReadSize :: Decoder (Maybe ReadSize)
 decodeReadSize = getFieldOptWith tomlDecoder "read-size"
 
+decodeReadStrategy :: Decoder (Maybe ReadStrategy)
+decodeReadStrategy = getFieldOptWith tomlDecoder "read-strategy"
+
 decodeReportReadErrors :: Decoder (Maybe Bool)
 decodeReportReadErrors = getFieldOptWith tomlDecoder "report-read-errors"
 
@@ -219,6 +260,7 @@ toEnv :: CommandLoggingMerged -> CommandLoggingEnv
 toEnv merged =
   MkCommandLoggingP
     { pollInterval = merged ^. #pollInterval,
+      readStrategy = merged ^. #readStrategy,
       readSize = merged ^. #readSize,
       reportReadErrors = merged ^. #reportReadErrors
     }
@@ -227,6 +269,7 @@ defaultToml :: CommandLoggingToml
 defaultToml =
   MkCommandLoggingP
     { pollInterval = Nothing,
+      readStrategy = Nothing,
       readSize = Nothing,
       reportReadErrors = Nothing
     }
@@ -235,6 +278,7 @@ defaultMerged :: CommandLoggingMerged
 defaultMerged =
   MkCommandLoggingP
     { pollInterval = def,
+      readStrategy = def,
       readSize = def,
       reportReadErrors = def
     }
diff --git a/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs b/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Shrun.Configuration.Data.CommandLogging.ReadStrategy
+  ( ReadStrategy (..),
+    parseReadStrategy,
+    readStrategyStr,
+  )
+where
+
+import Data.String (IsString)
+import Shrun.Configuration.Default (Default (def))
+import Shrun.Prelude
+
+-- | Different read strategies for simplicity vs. potential prettier
+-- formatting.
+data ReadStrategy
+  = -- | Default strategy. Reads N bytes at a time.
+    ReadBlock
+  | -- | Reads N bytes at a time but attempts to distinguish "complete" (newline
+    -- terminated) vs. "partial" (anything else) reads. We do this to make
+    -- the file log output prettier.
+    ReadBlockLineBuffer
+  deriving stock (Eq, Show)
+
+instance Default ReadStrategy where
+  def = ReadBlock
+
+instance DecodeTOML ReadStrategy where
+  tomlDecoder = parseReadStrategy tomlDecoder
+
+-- | Parses 'ReadStrategy'.
+parseReadStrategy :: (MonadFail m) => m Text -> m ReadStrategy
+parseReadStrategy getTxt =
+  getTxt >>= \case
+    "block" -> pure ReadBlock
+    "block-line-buffer" -> pure ReadBlockLineBuffer
+    other ->
+      fail
+        $ mconcat
+          [ "Unrecognized read strategy: '",
+            unpack other,
+            "'. Expected one of ",
+            readStrategyStr
+          ]
+
+-- | Available 'ReadStrategy' strings.
+readStrategyStr :: (IsString a) => a
+readStrategyStr = "(block | block-line-buffer)"
diff --git a/src/Shrun/Configuration/Env.hs b/src/Shrun/Configuration/Env.hs
@@ -95,7 +95,6 @@ withEnv onEnv = getMergedConfig >>= flip fromMergedConfig onEnv
 -- | Creates a 'MergedConfig' from CLI args and TOML config.
 getMergedConfig ::
   ( HasCallStack,
-    MonadDBus m,
     MonadFileReader m,
     MonadOptparse m,
     MonadPathReader m,