From f6c3d5d819c8f593c85c4176a1c6c52733331ae8 Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Mon, 16 Jan 2023 15:27:55 +0100 Subject: [PATCH] Test a simple loop with a changing file --- feedback-test-harness/default.nix | 6 +- .../feedback-test-harness.cabal | 3 +- feedback-test-harness/package.yaml | 5 +- feedback-test-harness/test/FeedbackSpec.hs | 137 ++++++++++++++++-- feedback.yaml | 8 + feedback/src/Feedback/Loop.hs | 4 +- feedback/src/Feedback/Loop/Filter.hs | 4 +- nix/overlay.nix | 76 +++++----- 8 files changed, 182 insertions(+), 61 deletions(-) diff --git a/feedback-test-harness/default.nix b/feedback-test-harness/default.nix index d129dc2..5f0dab0 100644 --- a/feedback-test-harness/default.nix +++ b/feedback-test-harness/default.nix @@ -1,5 +1,5 @@ -{ mkDerivation, base, feedback, lib, path, path-io, sydtest -, sydtest-discover, typed-process +{ mkDerivation, base, bytestring, feedback, lib, path, path-io +, sydtest, sydtest-discover, typed-process, unix }: mkDerivation { pname = "feedback-test-harness"; @@ -7,7 +7,7 @@ mkDerivation { src = ./.; libraryHaskellDepends = [ base feedback path path-io ]; testHaskellDepends = [ - base feedback path path-io sydtest typed-process + base bytestring path path-io sydtest typed-process unix ]; testToolDepends = [ sydtest-discover ]; doHaddock = false; diff --git a/feedback-test-harness/feedback-test-harness.cabal b/feedback-test-harness/feedback-test-harness.cabal index c1c20ee..8a7b826 100644 --- a/feedback-test-harness/feedback-test-harness.cabal +++ b/feedback-test-harness/feedback-test-harness.cabal @@ -48,10 +48,11 @@ test-suite feedback-test sydtest-discover:sydtest-discover build-depends: base >=4.7 && <5 - , feedback + , bytestring , feedback-test-harness , path , path-io , sydtest , typed-process + , unix default-language: Haskell2010 diff --git a/feedback-test-harness/package.yaml b/feedback-test-harness/package.yaml index de39ef1..c0b98d5 100644 --- a/feedback-test-harness/package.yaml +++ b/feedback-test-harness/package.yaml @@ -13,9 +13,9 @@ dependencies: library: source-dirs: src dependencies: - - feedback - path - path-io + - feedback tests: feedback-test: @@ -28,9 +28,10 @@ tests: - -with-rtsopts=-N - -Wall dependencies: - - feedback + - bytestring - feedback-test-harness - path - path-io - sydtest - typed-process + - unix diff --git a/feedback-test-harness/test/FeedbackSpec.hs b/feedback-test-harness/test/FeedbackSpec.hs index 9f87f13..f71a576 100644 --- a/feedback-test-harness/test/FeedbackSpec.hs +++ b/feedback-test-harness/test/FeedbackSpec.hs @@ -1,35 +1,142 @@ {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} module FeedbackSpec (spec) where import Control.Concurrent +import qualified Data.ByteString as SB import Path import Path.IO +import System.IO +import System.Posix import System.Process.Typed import Test.Syd import Test.Syd.Path spec :: Spec -spec = sequential . tempDirSpec "feedback" $ do +spec = sequential . tempDirSpec "feedback" . coverageSpec $ do + let waitABit = threadDelay 250_000 -- Wait 250 ms it "can show help text" $ \tdir -> do - let cp = setStdout nullStream $ setWorkingDir (fromAbsDir tdir) $ proc "feedback" ["--help"] + let cp = + setStdout nullStream + . setWorkingDir (fromAbsDir tdir) + $ proc "feedback" ["--help"] runProcess_ cp :: IO () it "can start a loop and wait for input" $ \tdir -> do - let cp = setStdout nullStream $ setWorkingDir (fromAbsDir tdir) $ proc "feedback" ["echo", "hi"] + let cp = + setStdout nullStream + . setWorkingDir (fromAbsDir tdir) + $ proc "feedback" ["echo", "hi"] withProcessTerm cp $ \ph -> do - threadDelay 100_000 -- Wait 100 ms + waitABit -- If the program is still running after 100ms, we assume that it is waiting. mExitCode <- getExitCode ph mExitCode `shouldBe` Nothing - -- TODO get rid of the fatal. - it "can run a command once, wait for input" $ \tdir -> do - dateFile <- resolveFile tdir "datefile" - let cp = setStdout nullStream $ setWorkingDir (fromAbsDir tdir) $ proc "feedback" ["--", "bash", "-c", "date +%N >" <> fromAbsFile dateFile] - withProcessTerm cp $ \ph -> do - threadDelay 100_000 -- Wait 100 ms - -- If the program is still running after 100ms, we assume that it is waiting. - mExitCode <- getExitCode ph - mExitCode `shouldBe` Nothing - readFile (fromAbsFile dateFile) >>= print - pending "can run a command once, wait for input, and run it again upon input, and then still be running" + + it "can run a command once, wait for input" $ \tdir -> + withSystemTempDir "somewhere-else" $ \otherTDir -> do + resultFile <- resolveFile otherTDir "result" -- In another dir so the loop doesn't rerun automatically + let cp = + setStdout nullStream + . setWorkingDir (fromAbsDir tdir) + $ proc "feedback" ["--", "bash", "-c", "echo hi >" <> fromAbsFile resultFile] + withProcessTerm cp $ \ph -> do + waitABit + + result <- SB.readFile (fromAbsFile resultFile) + result `shouldBe` "hi\n" + + -- If the program is still running after 100ms, we assume that it is waiting. + mExitCode <- getExitCode ph + mExitCode `shouldBe` Nothing + + it "can run a command once, wait for manual input, and run it again upon input, and then still be running" $ \tdir -> + withSystemTempDir "somewhere-else" $ \otherTDir -> do + -- In another dir so the loop doesn't rerun automatically + dateFile <- resolveFile otherTDir "datefile" + + (masterFd, slaveFd) <- openPseudoTerminal + masterHandle <- fdToHandle masterFd + slaveHandle <- fdToHandle slaveFd + + let cp = + setStdout nullStream + . setStdin (useHandleOpen slaveHandle) + . setWorkingDir (fromAbsDir tdir) + $ proc "feedback" ["--", "bash", "-c", "date +%N >" <> fromAbsFile dateFile] + withProcessTerm cp $ \ph -> do + waitABit + + -- Feedback is running. + mExitCode <- getExitCode ph + mExitCode `shouldBe` Nothing + + beforeContents <- SB.readFile (fromAbsFile dateFile) + + hPutChar masterHandle 'r' + hFlush masterHandle + + waitABit + + afterContents <- SB.readFile (fromAbsFile dateFile) + afterContents `shouldNotBe` beforeContents + + it "can run a command once, wait for a file to change, and run it again upon input, and then still be running" $ \tdir -> + withSystemTempDir "somewhere-else" $ \otherTDir -> do + -- In another dir so the loop doesn't rerun automatically + dateFile <- resolveFile otherTDir "datefile" + + -- In the same dir so the loop reruns when we change it + triggerFile <- resolveFile tdir "trigger" + SB.writeFile (fromAbsFile triggerFile) "initial" + + (_, slaveFd) <- openPseudoTerminal + -- masterHandle <- fdToHandle masterFd + slaveHandle <- fdToHandle slaveFd + + let cp = + setStdout nullStream + . setStdin (useHandleOpen slaveHandle) + . setWorkingDir (fromAbsDir tdir) + $ proc "feedback" ["--no-clear", "--debug", "--", "bash", "-c", "date +%N >" <> fromAbsFile dateFile] + withProcessTerm cp $ \ph -> do + waitABit + + -- Feedback is running. + mExitCode <- getExitCode ph + mExitCode `shouldBe` Nothing + + -- Make sure the file exists now + beforeContents <- SB.readFile (fromAbsFile dateFile) + + -- Change the trigger file, this should cause the loop to rerun. + SB.writeFile (fromAbsFile triggerFile) "go go go" + + -- Make sure the loop is rerun + waitABit + + -- Make sure the loop is rerun + afterContents <- SB.readFile (fromAbsFile dateFile) + afterContents `shouldNotBe` beforeContents + + waitABit + +-- It's really annoying that this is necessary, but hear me out. +-- `feedback` is run in a tempdir. +-- When instrumented with coverage tooling, it will output 'coverage.dat' its +-- working dir. +-- We have to copy back the coverage info in order to make the coverage report. +-- +-- It's slow and dirty but it works. +coverageSpec :: SpecWith (Path Abs Dir) -> SpecWith (Path Abs Dir) +coverageSpec = after $ \tdir -> do + specificCoverageFile <- resolveFile tdir "coverage.dat" + topLevelCoverageFile <- resolveFile' "coverage.dat" + mSpecificCoverage <- forgivingAbsence $ SB.readFile (fromAbsFile specificCoverageFile) + mTopLevelCoverage <- forgivingAbsence $ SB.readFile (fromAbsFile topLevelCoverageFile) + SB.writeFile (fromAbsFile topLevelCoverageFile) $ case (mTopLevelCoverage, mSpecificCoverage) of + (Nothing, Nothing) -> mempty + (Just topLevelCoverage, Nothing) -> topLevelCoverage + (Nothing, Just specificCoverage) -> specificCoverage + (Just topLevelCoverage, Just specificCoverage) -> topLevelCoverage <> specificCoverage diff --git a/feedback.yaml b/feedback.yaml index 8105b61..ef6f104 100644 --- a/feedback.yaml +++ b/feedback.yaml @@ -10,3 +10,11 @@ loops: test: description: Work on `feedback-test` command: cabal run feedback:feedback-test + + test-harness: + description: Work on `feedback-test-harness` + script: | + cabal build feedback:exe:feedback + bindir=$(dirname $(cabal list-bin feedback:exe:feedback)) + export PATH="$bindir:$PATH" + cabal test feedback-test-harness diff --git a/feedback/src/Feedback/Loop.hs b/feedback/src/Feedback/Loop.hs index 1188875..aec3158 100644 --- a/feedback/src/Feedback/Loop.hs +++ b/feedback/src/Feedback/Loop.hs @@ -25,17 +25,17 @@ import System.FSNotify as FS import System.IO (hGetChar) import System.Mem (performGC) import System.Posix.Signals as Signal +import Text.Colour +import UnliftIO #ifdef MIN_VERSION_Win32 import System.Win32.MinTTY (isMinTTYHandle) import System.Win32.Types (withHandleToHANDLE) #endif -import Text.Colour #ifdef MIN_VERSION_safe_coloured_text_terminfo import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv) #else import Text.Colour.Capabilities (TerminalCapabilities(..)) #endif -import UnliftIO runFeedbackLoop :: IO () runFeedbackLoop = do diff --git a/feedback/src/Feedback/Loop/Filter.hs b/feedback/src/Feedback/Loop/Filter.hs index e13613d..e796d9e 100644 --- a/feedback/src/Feedback/Loop/Filter.hs +++ b/feedback/src/Feedback/Loop/Filter.hs @@ -92,7 +92,9 @@ mkGitFilter here FilterSettings {..} = do gitLsFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File))) gitLsFiles here = do - let processConfig = shell "git ls-files" + -- If there is no git directory, we'll get a 'fatal' message on stderr. + -- We don't need the user to see this, so we setStderr nullStream. + let processConfig = setStderr nullStream $ shell "git ls-files" (ec, out) <- readProcessStdout processConfig set <- bytesFileSet here out pure $ case ec of diff --git a/nix/overlay.nix b/nix/overlay.nix index 32bba98..2e34a79 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -13,44 +13,46 @@ with final.haskell.lib; haskellPackages = prev.haskellPackages.override (old: { overrides = composeExtensions (old.overrides or (_: _: { })) ( - self: super: - { - feedback-test-harness = addBuildDepend (self.callPackage ../feedback-test-harness { }) final.feedback; - feedback = generateOptparseApplicativeCompletion "feedback" ( - buildFromSdist (overrideCabal - ( - self.callPackage - ../feedback - { } - ) - (old: { - doBenchmark = true; - doHaddock = true; - doCoverage = false; - doHoogle = true; - hyperlinkSource = false; - enableLibraryProfiling = false; - enableExecutableProfiling = false; + self: super: { + feedback = generateOptparseApplicativeCompletion "feedback" ( + buildFromSdist (overrideCabal + ( + self.callPackage + ../feedback + { } + ) + (old: { + doBenchmark = true; + doHaddock = true; + doCoverage = false; + doHoogle = true; + doCheck = false; + hyperlinkSource = false; + enableLibraryProfiling = false; + enableExecutableProfiling = false; - configureFlags = (old.configureFlags or [ ]) ++ [ - # Optimisations - "--ghc-options=-O2" - # Extra warnings - "--ghc-options=-Wall" - "--ghc-options=-Wincomplete-uni-patterns" - "--ghc-options=-Wincomplete-record-updates" - "--ghc-options=-Wpartial-fields" - "--ghc-options=-Widentities" - "--ghc-options=-Wredundant-constraints" - "--ghc-options=-Wcpp-undef" - "--ghc-options=-Werror" - "--ghc-options=-optP-Wno-nonportable-include-path" # For macos - ]; - # Ugly hack because we can't just add flags to the 'test' invocation. - # Show test output as we go, instead of all at once afterwards. - testTarget = (old.testTarget or "") + " --show-details=direct"; - }))); - } + configureFlags = (old.configureFlags or [ ]) ++ [ + # Optimisations + "--ghc-options=-O2" + # Extra warnings + "--ghc-options=-Wall" + "--ghc-options=-Wincomplete-uni-patterns" + "--ghc-options=-Wincomplete-record-updates" + "--ghc-options=-Wpartial-fields" + "--ghc-options=-Widentities" + "--ghc-options=-Wredundant-constraints" + "--ghc-options=-Wcpp-undef" + "--ghc-options=-Werror" + "--ghc-options=-optP-Wno-nonportable-include-path" # For macos + ]; + }))); + feedback-test-harness = buildStrictly + (overrideCabal (self.callPackage ../feedback-test-harness { }) (old: { + # Ugly hack because we can't just add flags to the 'test' invocation. + # Show test output as we go, instead of all at once afterwards. + testTarget = (old.testTarget or "") + " --show-details=direct"; + })); + } ); }); }