From eb3e0ebbdce51bfdc767053aa39fd0b4bbff3514 Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Sat, 1 Jun 2024 00:56:18 -0400 Subject: [PATCH] Implement new --command-log-read-strategy option --- .github/workflows/ci.yaml | 2 +- docker/alpine_amd64/Dockerfile | 2 +- shrun.cabal | 4 + shrun.log | 4 + .../Args/Parsing/CommandLogging.hs | 25 ++ .../Configuration/Data/CommandLogging.hs | 44 +++ .../Data/CommandLogging/ReadStrategy.hs | 48 +++ src/Shrun/Configuration/Env.hs | 1 - src/Shrun/Data/Text.hs | 6 +- src/Shrun/IO.hs | 56 ++- src/Shrun/IO/Types.hs | 287 +++++++++++++- test/functional/Functional/Buffering.hs | 23 +- test/functional/Functional/Examples.hs | 47 ++- .../Functional/Examples/CommandLogging.hs | 63 ++- .../Functional/Examples/CommonLogging.hs | 30 +- .../Functional/Examples/ConsoleLogging.hs | 155 +++++--- .../Functional/Examples/FileLogging.hs | 366 ++++++++++-------- test/functional/Functional/Miscellaneous.hs | 88 +++-- test/functional/Functional/Prelude.hs | 21 +- .../functional/Functional/ReadStrategyTest.hs | 159 ++++++++ test/functional/Functional/TestArgs.hs | 2 +- test/functional/Main.hs | 17 +- test/integration/Integration/Defaults.hs | 6 + test/integration/Integration/Examples.hs | 7 + test/integration/Integration/Utils.hs | 9 +- .../Args/Parsing/CommandLogging.hs | 43 ++ 26 files changed, 1181 insertions(+), 334 deletions(-) create mode 100644 shrun.log create mode 100644 src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs create mode 100644 test/functional/Functional/ReadStrategyTest.hs diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 774a232b..948b7c47 100644 --- 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/docker/alpine_amd64/Dockerfile b/docker/alpine_amd64/Dockerfile index bac9a343..1082ed2c 100644 --- 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/shrun.cabal b/shrun.cabal index 4b3c08cf..2eacf6b2 100644 --- 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,6 +252,7 @@ test-suite functional Functional.Miscellaneous Functional.Notify Functional.Prelude + Functional.ReadStrategyTest Functional.TestArgs build-depends: @@ -258,8 +260,10 @@ test-suite functional , effects-fs , env-guard , fdo-notify + , optparse-applicative , shrun , shrun-verifier + , tagged ^>=0.8.6 , tasty , tasty-hunit , text diff --git a/shrun.log b/shrun.log new file mode 100644 index 00000000..0a91eed4 --- /dev/null +++ b/shrun.log @@ -0,0 +1,4 @@ +[2024-06-01 08:57:15][Command][cabal test f...] Starting... +[2024-06-01 08:57:16][Command][cabal test f...] Build profile: -w ghc-9.8.2 -O2 +[2024-06-01 08:57:16][Command][cabal test f...] In order, the following will be built (use -v for more details): +[2024-06-01 08:57:16][Command][cabal test f...] - shrun-0.9 (test:functional) (file /home/tommy/Dev/tommy/github/shrun/dist-newstyle/build/x86_64-linux/ghc-9.8.2/shrun-0.9/opt/cache/build changed) diff --git a/src/Shrun/Configuration/Args/Parsing/CommandLogging.hs b/src/Shrun/Configuration/Args/Parsing/CommandLogging.hs index b97219e7..54c03f39 100644 --- a/src/Shrun/Configuration/Args/Parsing/CommandLogging.hs +++ b/src/Shrun/Configuration/Args/Parsing/CommandLogging.hs @@ -14,6 +14,7 @@ import Shrun.Configuration.Data.CommandLogging ( MkCommandLoggingP, pollInterval, readSize, + readStrategy, reportReadErrors ), ) @@ -21,6 +22,8 @@ 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,26 @@ 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 + [ "Determines how we read command logs. The default, block, is ", + "simpler, but can cut split logs in some circumstances. The ", + "block-buffer-line strategy attempts to only log entire lines at ", + "a time, for the purposes of nicer output. The latter is ", + "experimental and subject to change." + ] + reportReadErrorsParser :: Parser (WithDisabled ()) reportReadErrorsParser = Utils.withDisabledParserOpts diff --git a/src/Shrun/Configuration/Data/CommandLogging.hs b/src/Shrun/Configuration/Data/CommandLogging.hs index b5ff487e..e425ddd3 100644 --- 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,6 +88,7 @@ instance ( MkCommandLoggingP _pollInterval _readSize + _readStrategy _reportReadErrors ) -> fmap @@ -92,6 +96,7 @@ instance MkCommandLoggingP pollInterval' _readSize + _readStrategy _reportReadErrors ) (f _pollInterval) @@ -107,6 +112,7 @@ instance ( MkCommandLoggingP _pollInterval _readSize + _readStrategy _reportReadErrors ) -> fmap @@ -114,11 +120,36 @@ instance 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 new file mode 100644 index 00000000..11810632 --- /dev/null +++ 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. + ReadBlockBufferLine + 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-buffer-line" -> pure ReadBlockBufferLine + other -> + fail + $ mconcat + [ "Unrecognized read strategy: '", + unpack other, + "'. Expected one of ", + readStrategyStr + ] + +-- | Available 'ReadStrategy' strings. +readStrategyStr :: (IsString a) => a +readStrategyStr = "(block |block-buffer-line)" diff --git a/src/Shrun/Configuration/Env.hs b/src/Shrun/Configuration/Env.hs index 10229c05..0e86a310 100644 --- 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, diff --git a/src/Shrun/Data/Text.hs b/src/Shrun/Data/Text.hs index 780c44fa..a9daeec0 100644 --- a/src/Shrun/Data/Text.hs +++ b/src/Shrun/Data/Text.hs @@ -12,6 +12,7 @@ module Shrun.Data.Text toText, -- * Functions + length, concat, intercalate, reallyUnsafeMap, @@ -20,7 +21,7 @@ where import Data.String (IsString (fromString)) import Data.Text qualified as T -import Shrun.Prelude +import Shrun.Prelude hiding (length) -- | Text after it has had all lines separated into different texts. We -- introduce a newtype for clarity. The idea is that when we read arbitrary @@ -99,3 +100,6 @@ intercalate (UnsafeUnlinedText d) = -- then this will silently succeed. This exists for performance. reallyUnsafeMap :: (Text -> Text) -> UnlinedText -> UnlinedText reallyUnsafeMap f (UnsafeUnlinedText t) = UnsafeUnlinedText (f t) + +length :: UnlinedText -> Int +length (UnsafeUnlinedText t) = T.length t diff --git a/src/Shrun/IO.hs b/src/Shrun/IO.hs index 49442657..b7248a24 100644 --- a/src/Shrun/IO.hs +++ b/src/Shrun/IO.hs @@ -18,6 +18,12 @@ import Shrun.Configuration.Data.CommandLogging ReportReadErrorsOn ), ) +import Shrun.Configuration.Data.CommandLogging.ReadStrategy + ( ReadStrategy + ( ReadBlock, + ReadBlockBufferLine + ), + ) import Shrun.Configuration.Data.ConsoleLogging ( ConsoleLogCmdSwitch ( ConsoleLogCmdOff, @@ -42,9 +48,8 @@ import Shrun.IO.Types ( CommandResult (CommandFailure, CommandSuccess), ReadHandleResult (ReadErr, ReadNoData, ReadSuccess), Stderr (MkStderr), - readHandle, - readHandleResultToStderr, ) +import Shrun.IO.Types qualified as IO.Types import Shrun.Logging.Formatting (formatConsoleLog, formatFileLog) import Shrun.Logging.MonadRegionLogger (MonadRegionLogger (Region, withRegion)) import Shrun.Logging.Types @@ -234,7 +239,7 @@ tryCommandStream logFn cmd = do pure $ case exitCode of ExitSuccess -> Nothing - ExitFailure _ -> Just $ readHandleResultToStderr finalData + ExitFailure _ -> Just $ IO.Types.readHandleResultToStderr finalData -- NOTE: This was an attempt to set the buffering so that we could use -- hGetLine. Unfortunately that failed, see Note @@ -276,6 +281,9 @@ streamOutput logFn cmd p = do lastReadErrRef <- newIORef ReadNoData commandLogging <- asks getCommandLogging + leftoverOutRef <- newIORef Nothing + leftoverErrRef <- newIORef Nothing + let reportReadErrors = commandLogging ^. #reportReadErrors pollInterval :: Natural @@ -290,15 +298,24 @@ streamOutput logFn cmd p = do $ commandLogging ^. (#readSize % #unReadSize % _MkBytes) - readBlock :: (HasCallStack) => Handle -> m ReadHandleResult - readBlock = readHandle blockSize + readBlockOut :: m ReadHandleResult + readBlockErr :: m ReadHandleResult + (readBlockOut, readBlockErr) = case commandLogging ^. #readStrategy of + ReadBlock -> + ( IO.Types.readHandle Nothing blockSize (P.getStdout p), + IO.Types.readHandle Nothing blockSize (P.getStderr p) + ) + ReadBlockBufferLine -> + ( IO.Types.readHandle (Just leftoverOutRef) blockSize (P.getStdout p), + IO.Types.readHandle (Just leftoverErrRef) blockSize (P.getStderr p) + ) exitCode <- U.untilJust $ do -- We need to read from both stdout and stderr -- regardless of if we -- created a single pipe in tryCommandStream -- or else we will miss -- messages - outResult <- readBlock (P.getStdout p) - errResult <- readBlock (P.getStderr p) + outResult <- readBlockOut + errResult <- readBlockErr writeLog logFn reportReadErrors cmd lastReadOutRef outResult writeLog logFn reportReadErrors cmd lastReadErrRef errResult @@ -315,8 +332,29 @@ streamOutput logFn cmd p = do -- Leftover data. We need this as the process can exit before everything -- is read. - remainingOut <- readBlock (P.getStdout p) - remainingErr <- readBlock (P.getStderr p) + (remainingOut, remainingErr) <- do + -- This branch is really a paranoid "ensure we didn't change anything" if + -- using the ReadBlock strategy. It is possible ReadBlockBufferLine behaves + -- the same most of the time; indeed, all of the tests pass with the + -- normal ReadBlock strategy above even if we use ReadBlockBufferLine + -- below. + case commandLogging ^. #readStrategy of + ReadBlock -> (,) <$> readBlockOut <*> readBlockErr + ReadBlockBufferLine -> do + let readRemaining toHandle ref = + IO.Types.readHandleRaw blockSize (toHandle p) >>= \case + -- Do not care about errors here, since we may still have leftover + -- data that we need to get. If we cared, we could log the errors + -- here, but it seems minor. + Left _ -> IO.Types.readAndUpdateRefFinal ref "" + Right bs -> IO.Types.readAndUpdateRefFinal ref bs + + (,) + <$> readRemaining P.getStdout leftoverOutRef + <*> readRemaining P.getStderr leftoverErrRef + + writeLog logFn reportReadErrors cmd lastReadOutRef remainingOut + writeLog logFn reportReadErrors cmd lastReadErrRef remainingErr -- NOTE: [Stderr reporting] -- diff --git a/src/Shrun/IO/Types.hs b/src/Shrun/IO/Types.hs index 12f81fe1..6c682088 100644 --- a/src/Shrun/IO/Types.hs +++ b/src/Shrun/IO/Types.hs @@ -1,13 +1,26 @@ +{-# LANGUAGE CPP #-} + -- | Provides types for typical "IO" processes. module Shrun.IO.Types - ( Stderr (..), + ( -- * Types + Stderr (..), CommandResult (..), + + -- * Read handle result ReadHandleResult (..), readHandleResultToStderr, + + -- * Reading readHandle, + readHandleRaw, + readAndUpdateRefFinal, ) where +import Data.ByteString qualified as BS +#if MIN_VERSION_base (4, 19, 0) +import Data.List qualified as L +#endif import Data.Time.Relative (RelativeTime) import Effects.FileSystem.HandleReader ( MonadHandleReader (hIsClosed), @@ -31,7 +44,7 @@ data CommandResult -- | Result from reading a handle. The ordering is based on: -- -- @ --- 'ReadErr' _ < 'ReadNoData' < 'ReadSuccess' +-- 'ReadNoData' < 'ReadErr' < 'ReadSuccess' -- @ -- -- The 'Semigroup' instance is based on this ordering, taking the greatest @@ -61,25 +74,106 @@ readHandleResultToStderr ReadNoData = MkStderr $ ShrunText.fromText "" readHandleResultToStderr (ReadErr errs) = MkStderr errs readHandleResultToStderr (ReadSuccess errs) = MkStderr errs +-- NOTE: [Completed vs. Partial Reads] +-- +-- readHandle implements "complete vs. partial read detection" for the purposes +-- of making the file output's prettier (i.e. formatting). What follows is an +-- explanation. +-- +-- First, we define a _complete_ read as a read that is newline terminated. +-- Otherwise we have a _partial_ read. Notice that we could have multiple +-- complete reads (i.e. multiple newlines in the same read) and a possible +-- partial read, if the entire result does not end in a newline. +-- +-- Second, readHandle only implements this strategy when it receives an IORef +-- to store the partial result i.e. if its first param is 'Just'. Otherwise, +-- if it is 'Nothing', we implement the normal strategy which just returns +-- exactly what it reads, up to blockSize bytes. +-- +-- Before we get to the implementation strategy, let's briefly look at what +-- we did _not_ do. +-- +-- 1. One strategy (and possibly the most natural) is to stop unconditionally +-- appending newlines in the file log formatting, and instead just send +-- what the handle gives us. This would automatically do what we want, so +-- why not? +-- +-- Consider what happens if the underlying program does not send _any_ +-- newlines (e.g. programs that overwrite the same line). We will end up +-- building a single extremely long line. For this to be reasonable, we'd +-- want to implement some sort of cutoff e.g. "if we haven't read a newline +-- in some time or some data size, insert one". +-- +-- 2. We also make no effort to make this sensible with multiple commands. +-- Because we log everything to a single file, there is no sensible way +-- to perform this formatting with multiple commands. To make this actually +-- work we would need to log each command to its own file, which is +-- possible, but would be a very invasive change, possibly with a +-- complicated implementation / interface. +-- +-- Onto the implementation. +-- +-- When we encounter a partial read, we save it in an IORef. In general, when +-- reading the handle, we check this ref, and if it is non-empty, we prepend +-- it to the first read in the handle. We implement a threshold cutoff, whereby +-- we print it anyway, so that we do not build up a massive string in memory. + -- | Attempts to read from the handle. readHandle :: ( HasCallStack, MonadCatch m, - MonadHandleReader m + MonadHandleReader m, + MonadIORef m ) => + Maybe (IORef (Maybe UnlinedText)) -> Int -> Handle -> m ReadHandleResult -readHandle blockSize handle = do +readHandle mPrevReadRef blockSize handle = do + readHandleRaw blockSize handle >>= \case + Left err -> pure $ ReadErr err + Right bs -> case mPrevReadRef of + Nothing -> pure $ case bs of + "" -> ReadNoData + cs -> ReadSuccess (ShrunText.fromText $ decodeUtf8Lenient cs) + Just prevReadRef -> readAndUpdateRef prevReadRef bs + +-- | Attempts to read from the handle. Returns Left error or Right +-- success. +readHandleRaw :: + ( HasCallStack, + MonadCatch m, + MonadHandleReader m + ) => + Int -> + Handle -> + m (Either (List UnlinedText) ByteString) +readHandleRaw blockSize handle = do -- The "nothingIfReady" check and reading step both need to go in the try as -- the former can also throw. tryAny readHandle' <&> \case - Left ex -> ReadErr $ ShrunText.fromText $ "HandleException: " <> displayExceptiont ex + -- FIXME: What do we do if we have leftover data? We probably do not want + -- to drop it. We should probably log it, so maybe we return both? + -- So maybe our return value is: + -- + -- data RawResult + -- = RawSuccess ByteString + -- | RawPartial (List UnlinedText) ByteString -- failure and prevResult + -- | RawFailure (List UnlinedText) + -- + -- Although, actually we need to answer the following question. What do + -- we get from here when there is no data? If we just receive an empty + -- bytestring, that's fine. But if there's an error like "is not ready", + -- then that's bad, because we wouldn't want normal behavior (no data in pipe) + -- to break up a continuous log. + -- + -- I think it's the former, so we should be fine, but check this. + Left ex -> Left $ ShrunText.fromText $ "HandleException: " <> displayExceptiont ex Right x -> x where readHandle' = nothingIfReady >>= \case - Just err -> pure $ ReadErr $ ShrunText.fromText err + Just err -> pure $ Left (ShrunText.fromText err) Nothing -> -- NOTE: [Blocking / Streaming output] -- @@ -92,9 +186,7 @@ readHandle blockSize handle = do -- properly, and manually split the lines ourselves. The block size -- should be large enough that we are not likely to cut off a line -- prematurely, but obviously this is best-effort. - hGetNonBlocking handle blockSize <&> \case - "" -> ReadNoData - bs -> ReadSuccess (ShrunText.fromText $ decodeUtf8Lenient bs) + Right <$> hGetNonBlocking handle blockSize nothingIfReady = do -- NOTE: This somewhat torturous logic exists for a reason. We want to @@ -123,3 +215,180 @@ readHandle blockSize handle = do -- causes errors at the end) and probably hReady as well, but these both -- block and I have not found a way to invoke them while also streaming -- the process output (blocks until everything gets dumped at the end). + +readAndUpdateRef :: + forall m. + ( HasCallStack, + MonadIORef m + ) => + IORef (Maybe UnlinedText) -> + ByteString -> + m ReadHandleResult +readAndUpdateRef prevReadRef = + readByteStringPrevHandler + onNoData + onPartialRead + onCompletedAndPartialRead + prevReadRef + where + onNoData :: m ReadHandleResult + onNoData = pure ReadNoData + + onPartialRead :: UnlinedText -> m ReadHandleResult + onPartialRead finalPartialRead = do + readIORef prevReadRef >>= \case + Nothing -> do + updateRef finalPartialRead + pure ReadNoData + Just prevRead -> do + let combinedRead = prevRead <> finalPartialRead + -- NOTE: Threshold check. If the size is > than some value, + -- send off the log anyway, so that we do not build up an arbitrarily + -- large string in memory. + if ShrunText.length combinedRead > 1_000 + then do + clearRef + pure $ ReadSuccess [combinedRead] + else do + updateRef combinedRead + pure ReadNoData + + onCompletedAndPartialRead :: List UnlinedText -> UnlinedText -> m ReadHandleResult + onCompletedAndPartialRead completedReads finalPartialRead = do + completedReads' <- mPrependPrevRead prevReadRef completedReads + updateRef finalPartialRead + pure $ ReadSuccess completedReads' + + clearRef = writeIORef prevReadRef Nothing + updateRef = writeIORef prevReadRef . Just + +-- | Intended for a final read that handles previous read data. +readAndUpdateRefFinal :: + forall m. + ( HasCallStack, + MonadIORef m + ) => + IORef (Maybe UnlinedText) -> + ByteString -> + m ReadHandleResult +readAndUpdateRefFinal prevReadRef = + readByteStringPrevHandler + onNoData + onPartialRead + onCompletedAndPartialRead + prevReadRef + where + onNoData :: m ReadHandleResult + onNoData = + readIORef prevReadRef >>= \case + Nothing -> clearRef $> ReadNoData + Just prevRead -> clearRef $> ReadSuccess [prevRead] + + onPartialRead :: UnlinedText -> m ReadHandleResult + onPartialRead finalPartialRead = do + readIORef prevReadRef >>= \case + Nothing -> clearRef $> ReadSuccess [finalPartialRead] + Just prevRead -> clearRef $> ReadSuccess [prevRead <> finalPartialRead] + + onCompletedAndPartialRead :: List UnlinedText -> UnlinedText -> m ReadHandleResult + onCompletedAndPartialRead completedReads finalPartialRead = do + completedReads' <- mPrependPrevRead prevReadRef completedReads + pure $ ReadSuccess $ completedReads' ++ [finalPartialRead] + + clearRef = writeIORef prevReadRef Nothing + +mPrependPrevRead :: + (HasCallStack, MonadIORef m, Semigroup a) => + IORef (Maybe a) -> + List a -> + m (List a) +mPrependPrevRead ref cr = + readIORef ref >>= \case + Nothing -> pure cr + Just prevRead -> case cr of + -- This _should_ be impossible, since this type should really be + -- Maybe (NonEmpty UnlinedText). But this would require some refactoring. + [] -> clearRef $> [prevRead] + (r : rs) -> clearRef $> prevRead <> r : rs + where + clearRef = writeIORef ref Nothing + +-- | Helper for reading a bytestring and handling a previous, partial read. +readByteStringPrevHandler :: + forall m. + ( HasCallStack, + MonadIORef m + ) => + -- | Callback for no data. + m ReadHandleResult -> + -- | Callback for a partial, final read. + (UnlinedText -> m ReadHandleResult) -> + -- | Callback for completed reads _and_ a partial, final read. + (List UnlinedText -> UnlinedText -> m ReadHandleResult) -> + -- | Reference that stores the previous, partial read. + IORef (Maybe UnlinedText) -> + -- | The bytestring for the current read. + ByteString -> + m ReadHandleResult +readByteStringPrevHandler + onNoData + onPartialRead + onCompletedAndPartialRead + prevReadRef + bs = case readByteString bs of + (Nothing, Nothing) -> onNoData + -- This case is always handled the same: Prepend the prevRead if it + -- exists, and send all. + (Just completedReads, Nothing) -> do + completedReads' <- mPrependPrevRead prevReadRef completedReads + pure $ ReadSuccess completedReads' + (Nothing, Just finalPartialRead) -> onPartialRead finalPartialRead + (Just completedReads, Just finalPartialRead) -> + onCompletedAndPartialRead completedReads finalPartialRead + +-- | Reads a bytestring, distinguishing between _complete_ and _partial_ +-- reads. A bytestring is considered _complete_ iff it is terminated with a +-- newline. Otherwise it is _partial_. +-- +-- The tuple's left element contains all completed reads. The right element +-- is the final, partial read, if it exists. +readByteString :: ByteString -> Tuple2 (Maybe (List UnlinedText)) (Maybe UnlinedText) +readByteString bs = case BS.unsnoc bs of + -- 1. Empty: No output + Nothing -> (Nothing, Nothing) + -- 2. Non-empty, ends with a newline: This means all reads end with a + -- newline i.e. are complete. + Just (_, 10) -> (Just $ decodeRead bs, Nothing) + -- 3. Non-empty, does not end with a newline: This means the last (and + -- possibly only) read is partial. + Just (_, _) -> + let allReads = decodeRead bs + in case unsnoc allReads of + -- 3.1: Only one read: It is partial. + Just ([], finalPartialRead) -> (Nothing, Just finalPartialRead) + -- 3.2: Multiple reads: Last is partial. + Just (completeReads@(_ : _), finalPartialRead) -> + (Just completeReads, Just finalPartialRead) + -- 3.3: allReads is empty: Should be impossible, T.lines (used in + -- fromText) only produces empty output when the input is empty, + -- but we have already confirmed the ByteString is non-empty. + Nothing -> (Nothing, Nothing) + where + decodeRead = ShrunText.fromText . decodeUtf8Lenient + +-- TODO: Remove once we are past GHC 9.6 +unsnoc :: List a -> Maybe (List a, a) + +#if MIN_VERSION_base (4, 19, 0) + +unsnoc = L.unsnoc + +#else + +-- The lazy pattern ~(a, b) is important to be productive on infinite lists +-- and not to be prone to stack overflows. +-- Expressing the recursion via 'foldr' provides for list fusion. +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing +{-# INLINEABLE unsnoc #-} + +#endif diff --git a/test/functional/Functional/Buffering.hs b/test/functional/Functional/Buffering.hs index f4c0aa3e..000882bf 100644 --- a/test/functional/Functional/Buffering.hs +++ b/test/functional/Functional/Buffering.hs @@ -11,19 +11,24 @@ specs :: TestTree specs = testGroup "Buffering" - [ logsNoBuffer - ] + (multiTestReadStrategy testsParams) + where + testsParams :: List ReadStrategyTestParams + testsParams = [logsNoBuffer] -- We want to ensure that command logs are correctly not buffered i.e. -- they are streamed, not dumped at the end. -logsNoBuffer :: TestTree +logsNoBuffer :: ReadStrategyTestParams logsNoBuffer = - testCase "Command logs should not buffer" $ do - results <- L.reverse <$> run args - - assertLogsEq expectedOrdered results - - V.verifyExpected results (MkExpectedText <$> allExpected) + ReadStrategyTestParametricSimple + "Command logs should not buffer" + run + args + ( \results -> do + let results' = L.reverse results + assertLogsEq expectedOrdered results' + V.verifyExpected results' (MkExpectedText <$> allExpected) + ) where -- NOTE: [Bash brace loop interpolation] -- diff --git a/test/functional/Functional/Examples.hs b/test/functional/Functional/Examples.hs index abb871ab..b53948eb 100644 --- a/test/functional/Functional/Examples.hs +++ b/test/functional/Functional/Examples.hs @@ -19,21 +19,32 @@ specs :: IO TestArgs -> TestTree specs args = testGroup "Configuration.md examples" - [ gif, - core, - Examples.Core.tests, - Examples.CommonLogging.tests, - Examples.CommandLogging.tests, - Examples.ConsoleLogging.tests, - Examples.FileLogging.tests args, - Examples.Notify.tests - ] + ( readStrategyTests + ++ [ Examples.Core.tests, + Examples.CommonLogging.tests, + Examples.CommandLogging.tests, + Examples.ConsoleLogging.tests, + Examples.FileLogging.tests args, + Examples.Notify.tests + ] + ) -gif :: TestTree +readStrategyTests :: List TestTree +readStrategyTests = multiTestReadStrategy testsParams + where + testsParams :: List ReadStrategyTestParams + testsParams = + [ gif, + core + ] + +gif :: ReadStrategyTestParams gif = - testCase "Runs gif example" $ do - results <- runExitFailure args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs gif example" + runExitFailure + args + (`V.verifyExpected` expected) where args = withBaseArgs @@ -57,11 +68,13 @@ gif = withTimerPrefix "8 seconds" ] -core :: TestTree +core :: ReadStrategyTestParams core = - testCase "Runs core example" $ do - results <- runExitFailure args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs core example" + runExitFailure + args + (`V.verifyExpected` expected) where args = withBaseArgs diff --git a/test/functional/Functional/Examples/CommandLogging.hs b/test/functional/Functional/Examples/CommandLogging.hs index dff606cf..b153fe3f 100644 --- a/test/functional/Functional/Examples/CommandLogging.hs +++ b/test/functional/Functional/Examples/CommandLogging.hs @@ -2,6 +2,7 @@ module Functional.Examples.CommandLogging (tests) where import Data.Text qualified as T import Functional.Prelude +import Test.Shrun.Verifier (ExpectedText) import Test.Shrun.Verifier qualified as V -- NOTE: If tests in this module fail, fix then update configuration.md! @@ -10,15 +11,22 @@ tests :: TestTree tests = testGroup "CommandLogging" - [ readSizeDefault, - readSize - ] + (multiTestReadStrategy testsParams) + where + testsParams :: List ReadStrategyTestParams + testsParams = + [ readSizeDefault, + readSize + ] -readSizeDefault :: TestTree +readSizeDefault :: ReadStrategyTestParams readSizeDefault = - testCase "Default --read-size splits 16,000" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestSimple + "Default --read-size splits 16,000" + run + args + blockAssertions + blockLineBufferAssertions where args = withNoConfig @@ -27,19 +35,35 @@ readSizeDefault = "5", cmd ] - commandLog = replicate 16_000 'a' cmd = "sleep 1 ; echo " ++ commandLog ++ "b; sleep 1" - cmdExpected = V.MkExpectedText . T.pack $ commandLog - expected = + + blockAssertions = (`V.verifyExpected` blockExpected) + + blockExpected = [ withCommandPrefix "sl..." cmdExpected, withCommandPrefix "sl..." "b" ] -readSize :: TestTree + blockLineBufferAssertions = (`V.verifyExpected` blockLineBufferExpected) + + blockLineBufferExpected = + [ withCommandPrefix "sl..." (cmdExpected <> "b") + ] + +cmdExpected :: ExpectedText +cmdExpected = V.MkExpectedText . T.pack $ commandLog + +commandLog :: String +commandLog = replicate 16_000 'a' + +readSize :: ReadStrategyTestParams readSize = - testCase "Runs --command-log-read-size example" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestSimple + "Runs --command-log-read-size example" + run + args + blockAssertions + blockLineBufferAssertions where args = withNoConfig @@ -52,7 +76,16 @@ readSize = ] cmd :: (IsString a) => a cmd = "echo abcdef && sleep 3" - expected = + + blockAssertions = (`V.verifyExpected` blockExpected) + + blockExpected = [ withCommandPrefix cmd "abcde", withCommandPrefix cmd "f" ] + + blockLineBufferAssertions = (`V.verifyExpected` blockLineBufferExpected) + + blockLineBufferExpected = + [ withCommandPrefix cmd "abcdef" + ] diff --git a/test/functional/Functional/Examples/CommonLogging.hs b/test/functional/Functional/Examples/CommonLogging.hs index 9c78c734..7bb2c490 100644 --- a/test/functional/Functional/Examples/CommonLogging.hs +++ b/test/functional/Functional/Examples/CommonLogging.hs @@ -9,15 +9,21 @@ tests :: TestTree tests = testGroup "CommonLogging" - [ keyHideOn, - keyHideOff - ] + (multiTestReadStrategy testsParams) + where + testsParams :: List ReadStrategyTestParams + testsParams = + [ keyHideOn, + keyHideOff + ] -keyHideOn :: TestTree +keyHideOn :: ReadStrategyTestParams keyHideOn = - testCase "Runs key hide example with --common-log-key-hide" $ do - results <- run args - V.verifyExpectedUnexpected results expected unexpected + ReadStrategyTestParametricSimple + "Runs key hide example with --common-log-key-hide" + run + args + (\results -> V.verifyExpectedUnexpected results expected unexpected) where args = withBaseArgs @@ -33,11 +39,13 @@ keyHideOn = withSuccessPrefix "some-key" ] -keyHideOff :: TestTree +keyHideOff :: ReadStrategyTestParams keyHideOff = - testCase "Runs key hide example without --common-log-key-hide" $ do - results <- run args - V.verifyExpectedUnexpected results expected unexpected + ReadStrategyTestParametricSimple + "Runs key hide example without --common-log-key-hide" + run + args + (\results -> V.verifyExpectedUnexpected results expected unexpected) where args = withBaseArgs diff --git a/test/functional/Functional/Examples/ConsoleLogging.hs b/test/functional/Functional/Examples/ConsoleLogging.hs index 8b206794..fecf54e7 100644 --- a/test/functional/Functional/Examples/ConsoleLogging.hs +++ b/test/functional/Functional/Examples/ConsoleLogging.hs @@ -9,25 +9,31 @@ tests :: TestTree tests = testGroup "ConsoleLogging" - [ commandLogOn, - commandLogOnDefault, - commandLogOff, - commandNameTruncN, - commandLogLineTruncN, - stripControlAll, - stripControlNone, - stripControlSmart, - timerFormatDigitalCompact, - timerFormatDigitalFull, - timerFormatProseCompact, - timerFormatProseFull - ] + (multiTestReadStrategy testsParams) + where + testsParams :: List ReadStrategyTestParams + testsParams = + [ commandLogOn, + commandLogOnDefault, + commandLogOff, + commandNameTruncN, + commandLogLineTruncN, + stripControlAll, + stripControlNone, + stripControlSmart, + timerFormatDigitalCompact, + timerFormatDigitalFull, + timerFormatProseCompact, + timerFormatProseFull + ] -commandLogOn :: TestTree +commandLogOn :: ReadStrategyTestParams commandLogOn = - testCase "Runs commandLog example with --console-log-command" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs commandLog example with --console-log-command" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -38,11 +44,13 @@ commandLogOn = [ withCommandPrefix "for i in 1 2; do echo hi; sleep 1; done" "hi" ] -commandLogOnDefault :: TestTree +commandLogOnDefault :: ReadStrategyTestParams commandLogOnDefault = - testCase "Runs --console-log-command with no output shows default message" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs --console-log-command with no output shows default message" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -53,11 +61,13 @@ commandLogOnDefault = [ withCommandPrefix "for i in 1 2; do sleep 1; done" "Starting..." ] -commandLogOff :: TestTree +commandLogOff :: ReadStrategyTestParams commandLogOff = - testCase "Runs commandLog example without --console-log-command" $ do - results <- run args - V.verifyUnexpected results unexpected + ReadStrategyTestParametricSimple + "Runs commandLog example without --console-log-command" + run + args + (`V.verifyUnexpected` unexpected) where args = withNoConfig @@ -65,10 +75,13 @@ commandLogOff = ] unexpected = [commandPrefix] -commandNameTruncN :: TestTree -commandNameTruncN = testCase "Runs --console-log-command-name-trunc 10 example" $ do - results <- run args - V.verifyExpected results expected +commandNameTruncN :: ReadStrategyTestParams +commandNameTruncN = + ReadStrategyTestParametricSimple + "Runs --console-log-command-name-trunc 10 example" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -82,10 +95,13 @@ commandNameTruncN = testCase "Runs --console-log-command-name-trunc 10 example" withSuccessPrefix "for i i..." ] -commandLogLineTruncN :: TestTree -commandLogLineTruncN = testCase "Runs --console-log-line-trunc 80 example" $ do - results <- run args - V.verifyExpected results expected +commandLogLineTruncN :: ReadStrategyTestParams +commandLogLineTruncN = + ReadStrategyTestParametricSimple + "Runs --console-log-line-trunc 80 example" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -98,10 +114,13 @@ commandLogLineTruncN = testCase "Runs --console-log-line-trunc 80 example" $ do [ "[Command][echo 'some ridiculously long command i mean is this really necessary' && sleep 2] ..." ] -stripControlAll :: TestTree -stripControlAll = testCase "Runs --console-log-strip-control all example" $ do - results <- run args - V.verifyExpected results expected +stripControlAll :: ReadStrategyTestParams +stripControlAll = + ReadStrategyTestParametricSimple + "Runs --console-log-strip-control all example" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -119,10 +138,13 @@ stripControlAll = testCase "Runs --console-log-strip-control all example" $ do [ withCommandPrefix "printf ..." "foo hello bye " ] -stripControlNone :: TestTree -stripControlNone = testCase "Runs --console-log-strip-control none example" $ do - results <- run args - V.verifyExpected results expected +stripControlNone :: ReadStrategyTestParams +stripControlNone = + ReadStrategyTestParametricSimple + "Runs --console-log-strip-control none example" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -137,10 +159,13 @@ stripControlNone = testCase "Runs --console-log-strip-control none example" $ do [ withCommandPrefix "printf ..." "foo \ESC[35m hello \ESC[3D bye" ] -stripControlSmart :: TestTree -stripControlSmart = testCase "Runs --console-log-strip-control smart example" $ do - results <- run args - V.verifyExpected results expected +stripControlSmart :: ReadStrategyTestParams +stripControlSmart = + ReadStrategyTestParametricSimple + "Runs --console-log-strip-control smart example" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -154,11 +179,13 @@ stripControlSmart = testCase "Runs --console-log-strip-control smart example" $ [ withCommandPrefix "printf ..." "foo \ESC[35m hello bye " ] -timerFormatDigitalCompact :: TestTree +timerFormatDigitalCompact :: ReadStrategyTestParams timerFormatDigitalCompact = - testCase "Runs timer format with digital_compact" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs timer format with digital_compact" + run + args + (`V.verifyExpected` expected) where args = withBaseArgs @@ -170,11 +197,13 @@ timerFormatDigitalCompact = [ withTimerPrefix "01" ] -timerFormatDigitalFull :: TestTree +timerFormatDigitalFull :: ReadStrategyTestParams timerFormatDigitalFull = - testCase "Runs timer format with digital_full" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs timer format with digital_full" + run + args + (`V.verifyExpected` expected) where args = withBaseArgs @@ -186,11 +215,13 @@ timerFormatDigitalFull = [ withTimerPrefix "00:00:00:01" ] -timerFormatProseCompact :: TestTree +timerFormatProseCompact :: ReadStrategyTestParams timerFormatProseCompact = - testCase "Runs timer format with prose_compact" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs timer format with prose_compact" + run + args + (`V.verifyExpected` expected) where args = withBaseArgs @@ -202,11 +233,13 @@ timerFormatProseCompact = [ withTimerPrefix "1 second" ] -timerFormatProseFull :: TestTree +timerFormatProseFull :: ReadStrategyTestParams timerFormatProseFull = - testCase "Runs timer format with prose_full" $ do - results <- run args - V.verifyExpected results expected + ReadStrategyTestParametricSimple + "Runs timer format with prose_full" + run + args + (`V.verifyExpected` expected) where args = withBaseArgs diff --git a/test/functional/Functional/Examples/FileLogging.hs b/test/functional/Functional/Examples/FileLogging.hs index 7142729a..6466e26e 100644 --- a/test/functional/Functional/Examples/FileLogging.hs +++ b/test/functional/Functional/Examples/FileLogging.hs @@ -15,34 +15,44 @@ tests :: IO TestArgs -> TestTree tests args = testGroup "FileLogging" - [ fileLog args, - fileLogCommandNameTruncN args, - fileLogDeleteOnSuccess args, - fileLogDeleteOnSuccessFail args, - fileLogLineTruncN args, - fileLogStripControlAll args, - fileLogStripControlNone args, - fileLogStripControlSmart args - ] - -fileLog :: IO TestArgs -> TestTree -fileLog testArgs = testCase "Runs file-log example" $ do - outFile <- ( [osp|readme-file-out.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "sleep 2", - "bad", - "for i in 1 2 3; do echo hi; sleep 1; done" - ] - - resultsConsole <- runExitFailure args - V.verifyExpected resultsConsole expectedConsole - - resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile - V.verifyExpected resultsFile expectedFile + (multiTestReadStrategy testsParams) + where + testsParams :: List ReadStrategyTestParams + testsParams = + [ fileLog args, + fileLogCommandNameTruncN args, + fileLogDeleteOnSuccess args, + fileLogDeleteOnSuccessFail args, + fileLogLineTruncN args, + fileLogStripControlAll args, + fileLogStripControlNone args, + fileLogStripControlSmart args + ] + +fileLog :: IO TestArgs -> ReadStrategyTestParams +fileLog testArgs = + ReadStrategyTestParametricSetup + "Runs file-log example" + runExitFailure + ( do + outFile <- ( [osp|readme-file-out.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "sleep 2", + "bad", + "for i in 1 2 3; do echo hi; sleep 1; done" + ] + pure (args, outFile) + ) + ( \(resultsConsole, outFile) -> do + V.verifyExpected resultsConsole expectedConsole + + resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile + V.verifyExpected resultsFile expectedFile + ) where expectedConsole = [ withErrorPrefix "bad", @@ -55,26 +65,32 @@ fileLog testArgs = testCase "Runs file-log example" $ do ++ [ withCommandPrefix "for i in 1 2 3; do echo hi; sleep 1; done" "hi" ] -fileLogCommandNameTruncN :: IO TestArgs -> TestTree -fileLogCommandNameTruncN testArgs = testCase desc $ do - outFile <- ( [osp|readme-file-log-command-name-trunc-out.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "--file-log-command-name-trunc", - "10", - "for i in 1 2 3; do echo hi; sleep 1; done" - ] - - resultsConsole <- run args - V.verifyExpected resultsConsole expectedConsole - - resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile - V.verifyExpected resultsFile expectedFile +fileLogCommandNameTruncN :: IO TestArgs -> ReadStrategyTestParams +fileLogCommandNameTruncN testArgs = + ReadStrategyTestParametricSetup + "Runs --file-log-command-name-trunc 10 example" + run + ( do + outFile <- ( [osp|readme-file-log-command-name-trunc-out.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "--file-log-command-name-trunc", + "10", + "for i in 1 2 3; do echo hi; sleep 1; done" + ] + + pure (args, outFile) + ) + ( \(resultsConsole, outFile) -> do + V.verifyExpected resultsConsole expectedConsole + + resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile + V.verifyExpected resultsFile expectedFile + ) where - desc = "Runs --file-log-command-name-trunc 10 example" expectedConsole = [ withSuccessPrefix "for i in 1 2 3; do echo hi; sleep 1; done", -- not truncated withFinishedPrefix "3 seconds" @@ -84,55 +100,65 @@ fileLogCommandNameTruncN testArgs = testCase desc $ do withFinishedPrefix "3 seconds" ] -fileLogDeleteOnSuccess :: IO TestArgs -> TestTree -fileLogDeleteOnSuccess testArgs = testCase desc $ do - outFile <- ( [osp|del-on-success.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "--file-log-delete-on-success", - "sleep 2" - ] - - resultsConsole <- run args - V.verifyExpected resultsConsole expectedConsole - - exists <- doesFileExist outFile - - assertBool "File should not exist" (not exists) +fileLogDeleteOnSuccess :: IO TestArgs -> ReadStrategyTestParams +fileLogDeleteOnSuccess testArgs = + ReadStrategyTestParametricSetup + "Runs file-log-delete-on-success example" + run + ( do + outFile <- ( [osp|del-on-success.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "--file-log-delete-on-success", + "sleep 2" + ] + pure (args, outFile) + ) + ( \(resultsConsole, outFile) -> do + V.verifyExpected resultsConsole expectedConsole + + exists <- doesFileExist outFile + + assertBool "File should not exist" (not exists) + ) where - desc = "Runs file-log-delete-on-success example" expectedConsole = [ withSuccessPrefix "sleep 2", finishedPrefix ] -fileLogDeleteOnSuccessFail :: IO TestArgs -> TestTree -fileLogDeleteOnSuccessFail testArgs = testCase desc $ do - outFile <- ( [osp|del-on-success-fail.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "--file-log-delete-on-success", - "bad", - "sleep 2" - ] - - resultsConsole <- runExitFailure args - V.verifyExpected resultsConsole expectedConsole - - exists <- doesFileExist outFile - - assertBool "File should exist" exists - - resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile - V.verifyExpected resultsFile expectedFile +fileLogDeleteOnSuccessFail :: IO TestArgs -> ReadStrategyTestParams +fileLogDeleteOnSuccessFail testArgs = + ReadStrategyTestParametricSetup + "Runs file-log-delete-on-success failure example" + runExitFailure + ( do + outFile <- ( [osp|del-on-success-fail.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "--file-log-delete-on-success", + "bad", + "sleep 2" + ] + pure (args, outFile) + ) + ( \(resultsConsole, outFile) -> do + V.verifyExpected resultsConsole expectedConsole + + exists <- doesFileExist outFile + + assertBool "File should exist" exists + + resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile + V.verifyExpected resultsFile expectedFile + ) where - desc = "Runs file-log-delete-on-success failure example" expectedConsole = [ withErrorPrefix "bad", withSuccessPrefix "sleep 2", @@ -140,71 +166,86 @@ fileLogDeleteOnSuccessFail testArgs = testCase desc $ do ] expectedFile = expectedConsole -fileLogLineTruncN :: IO TestArgs -> TestTree -fileLogLineTruncN testArgs = testCase "Runs --file-log-line-trunc 120 example" $ do - outFile <- ( [osp|line-trunc.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "--file-log-line-trunc", - "120", - "echo 'some ridiculously long command i mean is this really necessary' && sleep 2" - ] - - -- NOTE: We choose 120 so that we get _some_ chars rather than minimal ..., - -- so the test is more precise. - - _ <- run args - - resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile - V.verifyExpected resultsFile expectedFile +fileLogLineTruncN :: IO TestArgs -> ReadStrategyTestParams +fileLogLineTruncN testArgs = + ReadStrategyTestParametricSetup + "Runs --file-log-line-trunc 120 example" + run + ( do + outFile <- ( [osp|line-trunc.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "--file-log-line-trunc", + "120", + "echo 'some ridiculously long command i mean is this really necessary' && sleep 2" + ] + + -- NOTE: We choose 120 so that we get _some_ chars rather than minimal ..., + -- so the test is more precise. + pure (args, outFile) + ) + ( \(_, outFile) -> do + resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile + V.verifyExpected resultsFile expectedFile + ) where expectedFile = [ withCommandPrefix "echo 'some ridiculously long command i mean is this really necessary' && sleep 2" "Star...", withCommandPrefix "echo 'some ridiculously long command i mean is this really necessary' && sleep 2" "some..." ] -fileLogStripControlAll :: IO TestArgs -> TestTree -fileLogStripControlAll testArgs = testCase "Runs file-log strip-control all example" $ do - outFile <- ( [osp|readme-file-out-strip-control-all.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "--file-log-strip-control", - "all", - "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" - ] - - _ <- run args - - resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile - V.verifyExpected resultsFile expectedFile +fileLogStripControlAll :: IO TestArgs -> ReadStrategyTestParams +fileLogStripControlAll testArgs = + ReadStrategyTestParametricSetup + "Runs file-log strip-control all example" + run + ( do + outFile <- ( [osp|readme-file-out-strip-control-all.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "--file-log-strip-control", + "all", + "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" + ] + pure (args, outFile) + ) + ( \(_, outFile) -> do + resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile + V.verifyExpected resultsFile expectedFile + ) where expectedFile = [ withCommandPrefix "printf ' foo hello bye '; sleep 2" " foo hello bye " ] -fileLogStripControlNone :: IO TestArgs -> TestTree -fileLogStripControlNone testArgs = testCase "Runs file-log strip-control none example" $ do - outFile <- ( [osp|readme-file-out-strip-control-none.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "--file-log-strip-control", - "none", - "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" - ] - - _ <- run args - - resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile - V.verifyExpected resultsFile expectedFile +fileLogStripControlNone :: IO TestArgs -> ReadStrategyTestParams +fileLogStripControlNone testArgs = + ReadStrategyTestParametricSetup + "Runs file-log strip-control none example" + run + ( do + outFile <- ( [osp|readme-file-out-strip-control-none.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "--file-log-strip-control", + "none", + "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" + ] + pure (args, outFile) + ) + ( \(_, outFile) -> do + resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile + V.verifyExpected resultsFile expectedFile + ) where expectedFile = [ withCommandPrefix @@ -212,23 +253,28 @@ fileLogStripControlNone testArgs = testCase "Runs file-log strip-control none ex " foo \ESC[35m hello \ESC[3D bye" ] -fileLogStripControlSmart :: IO TestArgs -> TestTree -fileLogStripControlSmart testArgs = testCase "Runs file-log strip-control smart example" $ do - outFile <- ( [osp|readme-file-out-strip-control-smart.log|]) . view #tmpDir <$> testArgs - let outFileStr = FsUtils.unsafeDecodeOsToFp outFile - args = - withNoConfig - [ "--file-log", - outFileStr, - "--file-log-strip-control", - "smart", - "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" - ] - - _ <- run args - - resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile - V.verifyExpected resultsFile expectedFile +fileLogStripControlSmart :: IO TestArgs -> ReadStrategyTestParams +fileLogStripControlSmart testArgs = + ReadStrategyTestParametricSetup + "Runs file-log strip-control smart example" + run + ( do + outFile <- ( [osp|readme-file-out-strip-control-smart.log|]) . view #tmpDir <$> testArgs + let outFileStr = FsUtils.unsafeDecodeOsToFp outFile + args = + withNoConfig + [ "--file-log", + outFileStr, + "--file-log-strip-control", + "smart", + "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" + ] + pure (args, outFile) + ) + ( \(_, outFile) -> do + resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile + V.verifyExpected resultsFile expectedFile + ) where expectedFile = [ withCommandPrefix diff --git a/test/functional/Functional/Miscellaneous.hs b/test/functional/Functional/Miscellaneous.hs index e09349e9..d1f46d4a 100644 --- a/test/functional/Functional/Miscellaneous.hs +++ b/test/functional/Functional/Miscellaneous.hs @@ -8,17 +8,24 @@ specs :: TestTree specs = testGroup "Miscellaneous" - [ splitNewlineLogs, - spaceErrorLogs, - stripControlAlwaysCmdNames, - reportsStderr, - slowOutputBroken - ] - -splitNewlineLogs :: TestTree -splitNewlineLogs = testCase "Logs with newlines are split" $ do - results <- run args - V.verifyExpectedUnexpected results expected unexpected + (multiTestReadStrategy testsParams) + where + testsParams :: List ReadStrategyTestParams + testsParams = + [ splitNewlineLogs, + spaceErrorLogs, + stripControlAlwaysCmdNames, + reportsStderr, + slowOutputBroken + ] + +splitNewlineLogs :: ReadStrategyTestParams +splitNewlineLogs = + ReadStrategyTestParametricSimple + "Logs with newlines are split" + run + args + (\results -> V.verifyExpectedUnexpected results expected unexpected) where args = withNoConfig @@ -39,10 +46,13 @@ splitNewlineLogs = testCase "Logs with newlines are split" $ do [ withCommandPrefix printedCmd "line one line two" ] -spaceErrorLogs :: TestTree -spaceErrorLogs = testCase "Error Log with newlines is spaced" $ do - results <- runExitFailure args - V.verifyExpectedUnexpected results expected unexpected +spaceErrorLogs :: ReadStrategyTestParams +spaceErrorLogs = + ReadStrategyTestParametricSimple + "Error Log with newlines is spaced" + runExitFailure + args + (\results -> V.verifyExpectedUnexpected results expected unexpected) where args = withNoConfig @@ -74,10 +84,13 @@ spaceErrorLogs = testCase "Error Log with newlines is spaced" $ do -- as it fit in alongside the other tests. However, we prefer those tests to -- match Configuration.md as closely as possible, to make maintaining the -- markdown file as easy as possible. Thus we move it here. -stripControlAlwaysCmdNames :: TestTree -stripControlAlwaysCmdNames = testCase "Always strips command names" $ do - results <- run args - V.verifyExpected results expected +stripControlAlwaysCmdNames :: ReadStrategyTestParams +stripControlAlwaysCmdNames = + ReadStrategyTestParametricSimple + "Always strips command names" + run + args + (`V.verifyExpected` expected) where args = withNoConfig @@ -95,10 +108,13 @@ stripControlAlwaysCmdNames = testCase "Always strips command names" $ do -- Tests that we default to stderr when it exists. -- See NOTE: [Stderr reporting]. -reportsStderr :: TestTree -reportsStderr = testCase "Reports stderr" $ do - results <- runExitFailure args - V.verifyExpectedUnexpected results expected unexpected +reportsStderr :: ReadStrategyTestParams +reportsStderr = + ReadStrategyTestParametricSimple + "Reports stderr" + runExitFailure + args + (\results -> V.verifyExpectedUnexpected results expected unexpected) where scriptPath :: (IsString a) => a scriptPath = "./test/functional/Functional/stderr.sh" @@ -138,10 +154,14 @@ reportsStderr = testCase "Reports stderr" $ do -- We include this test for documenting the current behavior, and if we ever -- "fix" this -- see NOTE: [Command log splitting] --, then we can simply -- flip the expected/unexpected below. -slowOutputBroken :: TestTree -slowOutputBroken = testCase "Slow output is broken" $ do - results <- run args - V.verifyExpectedUnexpected results expected unexpected +slowOutputBroken :: ReadStrategyTestParams +slowOutputBroken = + ReadStrategyTestSimple + "Slow output is broken" + run + args + blockAssertions + blockLineBufferAssertions where scriptPath :: (IsString a) => a scriptPath = "./test/functional/Functional/slow_output_broken.sh" @@ -152,11 +172,21 @@ slowOutputBroken = testCase "Slow output is broken" $ do scriptPath ] - expected = + blockAssertions results = + V.verifyExpectedUnexpected results blockExpected blockUnexpected + + blockExpected = [ withCommandPrefix scriptPath "first: ", withCommandPrefix scriptPath "second" ] - unexpected = + blockUnexpected = + [ withCommandPrefix scriptPath "first: second" + ] + + blockLineBufferAssertions results = + V.verifyExpected results blockLineBufferExpected + + blockLineBufferExpected = [ withCommandPrefix scriptPath "first: second" ] diff --git a/test/functional/Functional/Prelude.hs b/test/functional/Functional/Prelude.hs index 1608fdc2..62a179a5 100644 --- a/test/functional/Functional/Prelude.hs +++ b/test/functional/Functional/Prelude.hs @@ -34,6 +34,11 @@ module Functional.Prelude runException, runExitFailure, + -- ** Read strategies + ReadStrategyTestParams (..), + ReadStrategyTest.testReadStrategy, + ReadStrategyTest.multiTestReadStrategy, + -- * Expectations -- ** Text @@ -64,6 +69,14 @@ import Effects.Exception (ExceptionCS) #endif import Effects.FileSystem.Utils (combineFilePaths) import Effects.FileSystem.Utils as X (unsafeDecodeOsToFp, (!)) +import Functional.ReadStrategyTest + ( ReadStrategyTestParams + ( ReadStrategyTestParametricSetup, + ReadStrategyTestParametricSimple, + ReadStrategyTestSimple + ), + ) +import Functional.ReadStrategyTest qualified as ReadStrategyTest import Shrun qualified as SR import Shrun.Configuration.Env qualified as Env import Shrun.Configuration.Env.Types @@ -91,7 +104,13 @@ import Shrun.Notify.MonadNotify (MonadNotify (notify), ShrunNote) import Shrun.Prelude as X import Shrun.ShellT (ShellT) import Test.Shrun.Verifier (ResultText (MkResultText)) -import Test.Tasty as X (TestTree, defaultMain, testGroup, withResource) +import Test.Tasty as X + ( TestTree, + askOption, + defaultMain, + testGroup, + withResource, + ) import Test.Tasty.HUnit as X ( Assertion, assertBool, diff --git a/test/functional/Functional/ReadStrategyTest.hs b/test/functional/Functional/ReadStrategyTest.hs new file mode 100644 index 00000000..2bf94bbc --- /dev/null +++ b/test/functional/Functional/ReadStrategyTest.hs @@ -0,0 +1,159 @@ +module Functional.ReadStrategyTest + ( ReadStrategyOpt (..), + ReadStrategyTestParams (..), + multiTestReadStrategy, + testReadStrategy, + ) +where + +import Data.Tagged (Tagged (Tagged)) +import Options.Applicative qualified as OA +import Shrun.Prelude +import Test.Tasty (TestTree, askOption, testGroup) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.Options + ( IsOption + ( defaultValue, + optionCLParser, + optionHelp, + optionName, + parseValue + ), + mkOptionCLParser, + ) + +-- | Test parameters, used for running tests against multiple read +-- strategies. +data ReadStrategyTestParams where + -- | Simple test that should be parametric over ReadStrategy. + ReadStrategyTestParametricSimple :: + -- | Test description + String -> + -- | Test runner + (List String -> IO a) -> + -- | Args + (List String) -> + -- | Assertions + (a -> IO ()) -> + ReadStrategyTestParams + -- | Simple test. + ReadStrategyTestSimple :: + -- | Test description + String -> + -- | Test runner + (List String -> IO a) -> + -- | Args + (List String) -> + -- | Block Assertions + (a -> IO ()) -> + -- | BlockLineBuffer assertions + (a -> IO ()) -> + ReadStrategyTestParams + -- | Test with more complicated setup that should be parametric over + -- ReadStrategy. + ReadStrategyTestParametricSetup :: + -- | Test description + String -> + -- | Test runner + (List String -> IO a) -> + -- | Args setup + (IO (List String, r)) -> + -- | Assertions + ((a, r) -> IO ()) -> + ReadStrategyTestParams + +-- | Runs multiple tests against one or more command-log read strategies. +multiTestReadStrategy :: + List ReadStrategyTestParams -> + List TestTree +multiTestReadStrategy xs = xs >>= testReadStrategy + +-- | Runs a test against one or more command-log read strategies. +testReadStrategy :: + ReadStrategyTestParams -> + List TestTree +testReadStrategy (ReadStrategyTestParametricSimple desc runner args assertResults) = + [ askOption $ \case + ReadStrategyBlock -> blockTest + ReadStrategyBlockLineBuffer -> bufferTest + ReadStrategyAll -> + testGroup + "All command-log read strategies" + [ blockTest, + bufferTest + ] + ] + where + blockTest = testCase desc $ do + results <- runner args + assertResults results + + bufferTest = testCase desc' $ do + results <- runner args' + assertResults results + + desc' = desc ++ " (block-buffer-line)" + args' = args ++ ["--command-log-read-strategy", "block-buffer-line"] +testReadStrategy (ReadStrategyTestSimple desc runner args blockAssertions blockLineBufferAssertions) = + [ askOption $ \case + ReadStrategyBlock -> blockTest + ReadStrategyBlockLineBuffer -> bufferTest + ReadStrategyAll -> + testGroup + "All command-log read strategies" + [ blockTest, + bufferTest + ] + ] + where + blockTest = testCase desc $ do + results <- runner args + blockAssertions results + + bufferTest = testCase desc' $ do + results <- runner args' + blockLineBufferAssertions results + + desc' = desc ++ " (block-buffer-line)" + args' = args ++ ["--command-log-read-strategy", "block-buffer-line"] +testReadStrategy (ReadStrategyTestParametricSetup desc runner mkArgs assertResults) = + [ askOption $ \case + ReadStrategyBlock -> blockTest + ReadStrategyBlockLineBuffer -> bufferTest + ReadStrategyAll -> + testGroup + "All command-log read strategies" + [ blockTest, + bufferTest + ] + ] + where + blockTest = testCase desc $ do + (args, extra) <- mkArgs + results <- runner args + assertResults (results, extra) + + bufferTest = testCase desc' $ do + (args, extra) <- mkArgs + let args' = args ++ ["--command-log-read-strategy", "block-buffer-line"] + results <- runner args' + assertResults (results, extra) + desc' = desc ++ " (block-buffer-line)" + +-- | Hedgehog option for ReadStrategy tests. +data ReadStrategyOpt + = ReadStrategyBlock + | ReadStrategyBlockLineBuffer + | ReadStrategyAll + deriving stock (Eq, Show) + +instance IsOption ReadStrategyOpt where + defaultValue = ReadStrategyBlock + parseValue "block" = pure ReadStrategyBlock + parseValue "block-line-buffer" = pure ReadStrategyBlockLineBuffer + parseValue "all" = pure ReadStrategyAll + parseValue other = fail $ "Unrecognized option: " ++ other + optionName = Tagged "read-strategy" + optionHelp = Tagged "Runs tests with specified command-log read strategy" + optionCLParser = + mkOptionCLParser (OA.metavar "(block|block-line-buffer|all)") diff --git a/test/functional/Functional/TestArgs.hs b/test/functional/Functional/TestArgs.hs index f82808af..a4439963 100644 --- a/test/functional/Functional/TestArgs.hs +++ b/test/functional/Functional/TestArgs.hs @@ -5,7 +5,7 @@ module Functional.TestArgs ) where -import Functional.Prelude +import Shrun.Prelude data TestArgs = MkTestArgs { rootDir :: OsPath, diff --git a/test/functional/Main.hs b/test/functional/Main.hs index 09cfed65..246ecf67 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -11,17 +11,30 @@ import Functional.Examples qualified as Examples import Functional.Miscellaneous qualified as Miscellaneous import Functional.Notify qualified as Notify import Functional.Prelude -import Functional.TestArgs (TestArgs (MkTestArgs, configPath, rootDir, tmpDir)) +import Functional.ReadStrategyTest (ReadStrategyOpt) +import Functional.TestArgs + ( TestArgs + ( MkTestArgs, + configPath, + rootDir, + tmpDir + ), + ) import GHC.Conc.Sync (setUncaughtExceptionHandler) import System.Environment.Guard (guardOrElse') import System.Environment.Guard.Lifted (ExpectEnv (ExpectEnvSet)) import Test.Tasty qualified as Tasty +import Test.Tasty.Options (OptionDescription (Option)) -- | Entry point for functional tests. main :: IO () main = do setUncaughtExceptionHandler (putStrLn . displayException) - defaultMain $ Tasty.withResource setup teardown specs + Tasty.defaultMainWithIngredients ingredients $ Tasty.withResource setup teardown specs + where + ingredients = + Tasty.includingOptions [Option @ReadStrategyOpt Proxy] + : Tasty.defaultIngredients specs :: IO TestArgs -> TestTree specs args = do diff --git a/test/integration/Integration/Defaults.hs b/test/integration/Integration/Defaults.hs index e3215c42..a56beb17 100644 --- a/test/integration/Integration/Defaults.hs +++ b/test/integration/Integration/Defaults.hs @@ -24,11 +24,15 @@ import Shrun.Configuration.Data.CommandLogging ( MkCommandLoggingP, pollInterval, readSize, + readStrategy, reportReadErrors ), ReportReadErrorsSwitch (ReportReadErrorsOff, ReportReadErrorsOn), ) import Shrun.Configuration.Data.CommandLogging.ReadSize (ReadSize (MkReadSize)) +import Shrun.Configuration.Data.CommandLogging.ReadStrategy + ( ReadStrategy (ReadBlock), + ) import Shrun.Configuration.Data.CommonLogging ( CommonLoggingP (MkCommonLoggingP, keyHide), ) @@ -189,6 +193,7 @@ usesDefaultConfigFile = testPropertyNamed desc "usesDefaultConfigFile" MkCommandLoggingP { pollInterval = 127, readSize = MkReadSize $ MkBytes 20, + readStrategy = ReadBlock, reportReadErrors = ReportReadErrorsOn }, fileLogging = @@ -291,6 +296,7 @@ cliOverridesConfigFile testArgs = testPropertyNamed desc "cliOverridesConfigFile MkCommandLoggingP { pollInterval = 127, readSize = MkReadSize $ MkBytes 512, + readStrategy = ReadBlock, reportReadErrors = ReportReadErrorsOn }, fileLogging = diff --git a/test/integration/Integration/Examples.hs b/test/integration/Integration/Examples.hs index 7acc137e..d33a5397 100644 --- a/test/integration/Integration/Examples.hs +++ b/test/integration/Integration/Examples.hs @@ -18,11 +18,17 @@ import Shrun.Configuration.Data.CommandLogging ( MkCommandLoggingP, pollInterval, readSize, + readStrategy, reportReadErrors ), ReportReadErrorsSwitch (ReportReadErrorsOff), ) import Shrun.Configuration.Data.CommandLogging.ReadSize (ReadSize (MkReadSize)) +import Shrun.Configuration.Data.CommandLogging.ReadStrategy + ( ReadStrategy + ( ReadBlock + ), + ) import Shrun.Configuration.Data.CommonLogging ( CommonLoggingP ( MkCommonLoggingP, @@ -115,6 +121,7 @@ examplesConfig = testPropertyNamed desc "examplesConfig" MkCommandLoggingP { pollInterval = 100, readSize = MkReadSize $ MkBytes 1_000_000, + readStrategy = ReadBlock, reportReadErrors = ReportReadErrorsOff }, fileLogging = Nothing, diff --git a/test/integration/Integration/Utils.hs b/test/integration/Integration/Utils.hs index 65762fbe..ac301617 100644 --- a/test/integration/Integration/Utils.hs +++ b/test/integration/Integration/Utils.hs @@ -161,8 +161,7 @@ deriving via ConfigIO instance MonadTerminal NoConfigIO -- the expectation. makeConfigAndAssertEq :: forall m. - ( MonadDBus m, - MonadEnv m, + ( MonadEnv m, MonadFileReader m, MonadMask m, MonadOptparse m, @@ -207,8 +206,7 @@ infix 1 ^?=@ -- | Like 'makeConfigAndAssertEq' except we only compare select fields. makeConfigAndAssertFieldEq :: forall m. - ( MonadDBus m, - MonadEnv m, + ( MonadEnv m, MonadFileReader m, MonadMask m, MonadOptparse m, @@ -231,8 +229,7 @@ makeConfigAndAssertFieldEq args toIO comparisons = do makeMergedConfig :: forall m. - ( MonadDBus m, - MonadEnv m, + ( MonadEnv m, MonadFileReader m, MonadMask m, MonadOptparse m, diff --git a/test/unit/Unit/Shrun/Configuration/Args/Parsing/CommandLogging.hs b/test/unit/Unit/Shrun/Configuration/Args/Parsing/CommandLogging.hs index 37cefb64..9a0a63bb 100644 --- a/test/unit/Unit/Shrun/Configuration/Args/Parsing/CommandLogging.hs +++ b/test/unit/Unit/Shrun/Configuration/Args/Parsing/CommandLogging.hs @@ -1,6 +1,9 @@ module Unit.Shrun.Configuration.Args.Parsing.CommandLogging (tests) where import Shrun.Configuration.Data.CommandLogging.ReadSize (ReadSize (MkReadSize)) +import Shrun.Configuration.Data.CommandLogging.ReadStrategy + ( ReadStrategy (ReadBlock, ReadBlockBufferLine), + ) import Unit.Prelude import Unit.Shrun.Configuration.Args.Parsing.TestUtils qualified as U @@ -11,6 +14,7 @@ tests = "Shrun.Configuration.Args.Parsing.CommandLogging" [ pollIntervalTests, readSizeTests, + readStrategyTests, reportReadErrorsTests ] @@ -75,6 +79,45 @@ testNoReadSize = argList = ["--no-command-log-read-size", "command"] expected = U.disableDefCoreArgs (#commandLogging % #readSize) +readStrategyTests :: TestTree +readStrategyTests = + testGroup + "--command-log-read-strategy" + [ testReadStrategyBlock, + testReadStrategyBlockBufferLine, + testNoReadStrategy + ] + +testReadStrategyBlock :: TestTree +testReadStrategyBlock = + testPropertyNamed + "Parses --command-log-read-strategy block" + "testReadStrategyBlock" + $ U.verifyResult argList expected + where + argList = ["--command-log-read-strategy", "block", "command"] + expected = U.updateDefCoreArgs (#commandLogging % #readStrategy) ReadBlock + +testReadStrategyBlockBufferLine :: TestTree +testReadStrategyBlockBufferLine = + testPropertyNamed + "Parses --command-log-read-strategy block-buffer-line" + "testReadStrategyBlockBufferLine" + $ U.verifyResult argList expected + where + argList = ["--command-log-read-strategy", "block-buffer-line", "command"] + expected = U.updateDefCoreArgs (#commandLogging % #readStrategy) ReadBlockBufferLine + +testNoReadStrategy :: TestTree +testNoReadStrategy = + testPropertyNamed + "Parses --no-command-log-read-strategy" + "testReadStrategyBlockBufferLine" + $ U.verifyResult argList expected + where + argList = ["--no-command-log-read-strategy", "command"] + expected = U.disableDefCoreArgs (#commandLogging % #readStrategy) + reportReadErrorsTests :: TestTree reportReadErrorsTests = testGroup