diff --git a/components/core/Effectful/Zoo/FileSystem.hs b/components/core/Effectful/Zoo/FileSystem.hs --- a/components/core/Effectful/Zoo/FileSystem.hs +++ b/components/core/Effectful/Zoo/FileSystem.hs @@ -2,6 +2,9 @@ ( FileSystem, JsonDecodeError(..), YamlDecodeError(..), + + appendStringFile, + createDirectoryIfMissing, readByteStringFile, readLazyByteStringFile, readStringFile, @@ -123,6 +126,19 @@ unsafeFileSystemEff_ (IO.writeFile filePath contents) & trapIO @IOException throw +appendStringFile :: () + => HasCallStack + => r <: Error IOException + => r <: FileSystem + => r <: Log Text + => FilePath + -> String + -> Eff r () +appendStringFile filePath contents = withFrozenCallStack do + info $ "Appending string to file: " <> T.pack filePath + unsafeFileSystemEff_ (IO.appendFile filePath contents) + & trapIO @IOException throw + getCanonicalTemporaryDirectory :: () => HasCallStack => r <: Error IOException @@ -218,3 +234,18 @@ unsafeFileSystemEff_ (D.listDirectory fp) & trapIO @IOException throw {-# INLINE listDirectory #-} + +createDirectoryIfMissing :: () + => HasCallStack + => r <: Error IOException + => r <: FileSystem + => r <: Log Text + => Bool + -> FilePath + -> Eff r () +createDirectoryIfMissing createParents fp = withFrozenCallStack do + info $ "Calling: createDirectoryIfMissing " <> tshow fp + + unsafeFileSystemEff_ (D.createDirectoryIfMissing createParents fp) + & trapIO @IOException throw +{-# INLINE createDirectoryIfMissing #-} diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs --- a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs @@ -63,8 +63,6 @@ => r <: Concurrent => r <: Environment => r <: Error Failure - => r <: Error GenericError - => r <: Error IOException => r <: FileSystem => r <: Hedgehog => r <: IOE @@ -80,8 +78,6 @@ => r <: Concurrent => r <: Environment => r <: Error Failure - => r <: Error GenericError - => r <: Error IOException => r <: FileSystem => r <: Hedgehog => r <: IOE @@ -111,8 +107,6 @@ => r <: Concurrent => r <: Environment => r <: Error Failure - => r <: Error GenericError - => r <: Error IOException => r <: FileSystem => r <: Hedgehog => r <: IOE @@ -130,14 +124,13 @@ RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args) readCreateProcessWithExitCode cp "" + & trapFail @IOException execDetailFlex :: () => HasCallStack => r <: Concurrent => r <: Environment => r <: Error Failure - => r <: Error GenericError - => r <: Error IOException => r <: FileSystem => r <: Hedgehog => r <: IOE @@ -154,6 +147,7 @@ ShellCommand cmd -> cmd RawCommand cmd args -> cmd <> " " <> L.unwords args readCreateProcessWithExitCode cp "" + & trapFail @IOException -- | Execute a process, returning '()'. execOk_ :: () @@ -268,10 +262,11 @@ -- configured and the executable has been built. procFlex :: () => HasCallStack + => r <: Concurrent => r <: Environment - => r <: Error GenericError - => r <: Error IOException + => r <: Error Failure => r <: FileSystem + => r <: Hedgehog => r <: IOE => r <: Log Text => String @@ -287,10 +282,11 @@ procFlex' :: () => HasCallStack + => r <: Concurrent => r <: Environment - => r <: Error GenericError - => r <: Error IOException + => r <: Error Failure => r <: FileSystem + => r <: Hedgehog => r <: IOE => r <: Log Text => ExecConfig @@ -305,6 +301,8 @@ procFlex' execConfig pkg binaryEnv arguments = withFrozenCallStack do bin <- binFlex pkg binaryEnv + & trapFail @GenericError + & trapFail @IOException return (proc bin arguments) { env = getLast execConfig.execConfigEnv , cwd = getLast execConfig.execConfigCwd diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Golden.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Golden.hs new file mode 100644 --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Golden.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE MultiWayIf #-} + +module Effectful.Zoo.Hedgehog.Golden + ( diffVsGoldenFile, + diffFileVsGoldenFile, + diffVsGoldenFileExcludeTrace, + ) where + +import Control.Applicative +import Control.Monad +import Data.Algorithm.Diff (PolyDiff (Both), getGroupedDiff) +import Data.Algorithm.DiffOutput (ppDiff) +import Data.Bool +import Data.Eq +import Data.Function +import Data.Maybe +import Data.Monoid +import Data.String +import Effectful +import Effectful.Concurrent.QSem +import Effectful.Exception +import Effectful.Zoo.Core +import Effectful.Zoo.Error.Static +import Effectful.Zoo.FileSystem +import Effectful.Zoo.Hedgehog.Api.Assert +import Effectful.Zoo.Hedgehog.Api.Journal +import Effectful.Zoo.Hedgehog.Effect.Hedgehog +import Effectful.Zoo.Log.Static +import GHC.Stack (callStack) +import HaskellWorks.Prelude +import Hedgehog (MonadTest) +import System.FilePath (takeDirectory) +import qualified Control.Concurrent.QSem as IO +import qualified System.Environment as IO +import qualified System.IO.Unsafe as IO + +import qualified Data.List as List +import qualified Data.Text as T +import qualified GHC.Stack as GHC +import qualified Hedgehog.Internal.Property as H + +sem :: IO.QSem +sem = IO.unsafePerformIO $ IO.newQSem 1 +{-# NOINLINE sem #-} + +semBracket :: () + => r <: Concurrent + => Eff r a + -> Eff r a +semBracket = bracket_ (waitQSem sem) (signalQSem sem) + +-- | The file to log whenever a golden file is referenced. +mGoldenFileLogFile :: Maybe FilePath +mGoldenFileLogFile = IO.unsafePerformIO $ + IO.lookupEnv "GOLDEN_FILE_LOG_FILE" + +-- | Whether the test should create the golden files if the files do not exist. +createGoldenFiles :: Bool +createGoldenFiles = IO.unsafePerformIO $ do + value <- IO.lookupEnv "CREATE_GOLDEN_FILES" + return $ value == Just "1" + +-- | Whether the test should recreate the golden files if the files already exist. +recreateGoldenFiles :: Bool +recreateGoldenFiles = IO.unsafePerformIO $ do + value <- IO.lookupEnv "RECREATE_GOLDEN_FILES" + return $ value == Just "1" + +writeGoldenFile :: () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Error IOException + => r <: FileSystem + => r <: Hedgehog + => r <: Log Text + => FilePath + -> String + -> Eff r () +writeGoldenFile goldenFile actualContent = GHC.withFrozenCallStack $ do + jot_ $ "Creating golden file " <> T.pack goldenFile + void $ createDirectoryIfMissing True (takeDirectory goldenFile) + writeStringFile goldenFile actualContent + +reportGoldenFileMissing :: () + => HasCallStack + => MonadIO m + => MonadTest m + => FilePath + -> m () +reportGoldenFileMissing goldenFile = GHC.withFrozenCallStack $ do + jot_ $ T.unlines + [ "Golden file " <> T.pack goldenFile <> " does not exist." + , "To create it, run with CREATE_GOLDEN_FILES=1." + , "To recreate it, run with RECREATE_GOLDEN_FILES=1." + ] + H.failure + +checkAgainstGoldenFile :: () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Error IOException + => r <: FileSystem + => r <: Hedgehog + => r <: Log Text + => FilePath + -> [String] + -> Eff r () +checkAgainstGoldenFile goldenFile actualLines = GHC.withFrozenCallStack $ do + referenceLines <- List.lines <$> readStringFile goldenFile + let difference = getGroupedDiff actualLines referenceLines + case difference of + [] -> pure () + [Both{}] -> pure () + _ -> do + jot_ $ T.unlines + [ "Golden test failed against the golden file." + , "To recreate golden file, run with RECREATE_GOLDEN_FILES=1." + ] + failMessage callStack $ ppDiff difference + +-- | Diff contents against the golden file. If CREATE_GOLDEN_FILES environment is +-- set to "1", then should the golden file not exist it would be created. If +-- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would +-- be recreated. If GOLDEN_FILE_LOG_FILE is set to a filename, then the golden file +-- path will be logged to the specified file. +-- +-- Set the environment variable when you intend to generate or re-generate the golden +-- file for example when running the test for the first time or if the golden file +-- genuinely needs to change. +-- +-- To re-generate a golden file you must also delete the golden file because golden +-- files are never overwritten. +-- +-- TODO: Improve the help output by saying the difference of +-- each input. +diffVsGoldenFile + :: HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: FileSystem + => r <: Log Text + => r <: Hedgehog + => r <: IOE + => String -- ^ Actual content + -> FilePath -- ^ Reference file + -> Eff r () +diffVsGoldenFile actualContent goldenFile = + GHC.withFrozenCallStack $ trapFail @IOException $ do + semBracket $ do + forM_ mGoldenFileLogFile $ \logFile -> + appendStringFile logFile $ goldenFile <> "\n" + + fileExists <- doesFileExist goldenFile + + if + | recreateGoldenFiles -> writeGoldenFile goldenFile actualContent + | fileExists -> checkAgainstGoldenFile goldenFile actualLines + | createGoldenFiles -> writeGoldenFile goldenFile actualContent + | otherwise -> reportGoldenFileMissing goldenFile + + where + actualLines = List.lines actualContent + +-- | Diff file against the golden file. If CREATE_GOLDEN_FILES environment is +-- set to "1", then should the gold file not exist it would be created. If +-- GOLDEN_FILE_LOG_FILE is set to a filename, then the golden file path will be +-- logged to the specified file. +-- +-- Set the environment variable when you intend to generate or re-generate the golden +-- file for example when running the test for the first time or if the golden file +-- genuinely needs to change. +-- +-- To re-generate a golden file you must also delete the golden file because golden +-- files are never overwritten. +diffFileVsGoldenFile + :: HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: FileSystem + => r <: Hedgehog + => r <: IOE + => r <: Log Text + => FilePath -- ^ Actual file + -> FilePath -- ^ Reference file + -> Eff r () +diffFileVsGoldenFile actualFile referenceFile = GHC.withFrozenCallStack $ do + contents <- readStringFile actualFile + & trapFail @IOException + + diffVsGoldenFile contents referenceFile + +diffVsGoldenFileExcludeTrace :: () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: FileSystem + => r <: Hedgehog + => r <: IOE + => r <: Log Text + => String + -> FilePath + -> Eff r () +diffVsGoldenFileExcludeTrace inputString refFile = + GHC.withFrozenCallStack $ do + case List.uncons $ T.splitOn "CallStack" $ T.pack inputString of + Just (stackTraceRemoved, _) -> + diffVsGoldenFile (T.unpack stackTraceRemoved) refFile + Nothing -> + H.failWith Nothing $ + List.unlines + [ "Input string was empty" + , "Reference file: " <> refFile + ] diff --git a/effectful-zoo.cabal b/effectful-zoo.cabal --- a/effectful-zoo.cabal +++ b/effectful-zoo.cabal @@ -1,7 +1,7 @@ cabal-version: 3.4 name: effectful-zoo -version: 0.0.5.2 +version: 0.0.6.0 synopsis: Effectful effects for testing description: See https://hackage.haskell.org/package/effectful-zoo/docs/effectful-zoo.html category: Development @@ -54,6 +54,7 @@ common blockfrost-api { build-depends: blockfrost-api >= 0.11 && < 0.13 } common blockfrost-client { build-depends: blockfrost-client >= 0.8 && < 0.10 } common bytestring { build-depends: bytestring >= 0.11 && < 1 } +common Diff { build-depends: Diff >= 1.0.2 && < 2 } common directory { build-depends: directory >= 1.2 && < 2 } common effectful { build-depends: effectful >= 2.5 && < 3 } common effectful-core { build-depends: effectful-core >= 2.5 && < 3 } @@ -329,6 +330,7 @@ aeson, binary, bytestring, + Diff, effectful-core, effectful-plugin, effectful-zoo-core, @@ -380,6 +382,7 @@ Effectful.Zoo.Hedgehog.Effect.Hedgehog Effectful.Zoo.Hedgehog.Effect.HedgehogGen Effectful.Zoo.Hedgehog.Effect.Run + Effectful.Zoo.Hedgehog.Golden ghc-options: -fplugin=Effectful.Plugin hs-source-dirs: components/hedgehog