goldplate 0.2.1.1 → 0.2.2.0
raw patch · 7 files changed
+665/−596 lines, 7 filesdep +goldplatedep ~aesondep ~basedep ~bytestring
Dependencies added: goldplate
Dependency ranges changed: aeson, base, bytestring
Files
- CHANGELOG.md +4/−0
- Main.hs +6/−0
- README.md +3/−3
- goldplate.cabal +36/−28
- src/Goldplate.hs +595/−0
- src/Main.hs +0/−562
- tests/Tests.hs +21/−3
CHANGELOG.md view
@@ -1,5 +1,9 @@ # CHANGELOG + - 0.2.2.0 (2024-09-30)+ * Expose `Options`, `defaultOptions` and `mainWith` from `Goldplate`+ module so it's easy to call from Haskell test suites.+ - 0.2.1.1 (2023-02-26) * Bump `aeson` dependency upper bound to 2.1. * Tested with GHC 8.4 - 9.6.1 alpha3.
+ Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Goldplate++main :: IO ()+main = Goldplate.main
README.md view
@@ -21,8 +21,8 @@ - The application is quick to start (a process is created for every test) - Your output is text-based and not huge in size -At [Fugue](https://fugue.co), we've been using internal versions of this tool-since 2016, so it should be pretty stable.+At [Fugue](https://www.fugue.co/), we've been using internal versions of this+tool since 2016, so it should be pretty stable. `goldplate` produces output compatible with the [Test Anything Protocol]. @@ -213,7 +213,7 @@ ## Installation Binaries for Mac OS and Linux are available on the-[releases page](https://github.com/fugue/goldplate/releases).+[releases page](https://github.com/jaspervdj/goldplate/releases). Installation from source is done using standard Haskell tooling -- [Cabal] and [stack] both work well.
goldplate.cabal view
@@ -1,22 +1,24 @@ Name: goldplate-Version: 0.2.1.1+Version: 0.2.2.0 Synopsis: A lightweight golden test runner License: Apache-2.0 License-file: LICENSE-Author: Jasper Van der Jeugt <jasper@fugue.co>-Maintainer: Jasper Van der Jeugt <jasper@fugue.co>, Andreas Abel+Author: Jasper Van der Jeugt <m@jaspervdj.be>+Maintainer: Jasper Van der Jeugt, Andreas Abel Copyright: 2019-2021 Fugue, Inc-Homepage: https://github.com/fugue/goldplate-Bug-reports: https://github.com/fugue/goldplate/issues+Homepage: https://github.com/jaspervdj/goldplate+Bug-reports: https://github.com/jaspervdj/goldplate/issues Category: Language Build-type: Simple Cabal-version: 1.18 Description: Language-agnostic golden test runner for command-line applications. Tested-with:- GHC == 9.6.0- GHC == 9.4.4- GHC == 9.2.6+ GHC == 9.10.1+ GHC == 9.8.2+ GHC == 9.6.5+ GHC == 9.4.8+ GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4@@ -29,18 +31,18 @@ Source-repository head type: git- location: git://github.com/fugue/goldplate.git+ location: https://github.com/jaspervdj/goldplate.git Source-repository this type: git- location: git://github.com/fugue/goldplate.git+ location: https://github.com/jaspervdj/goldplate.git tag: v0.2.1.1 -Executable goldplate+Library Hs-source-dirs: src- Main-is: Main.hs Default-language: Haskell2010- Ghc-options: -Wall -rtsopts -threaded+ Ghc-options: -Wall+ Exposed-modules: Goldplate Other-modules: Text.Regex.PCRE.Simple@@ -48,26 +50,32 @@ Paths_goldplate Build-depends:- aeson >= 1.4 && < 2.2,- aeson-pretty >= 0.8 && < 0.9,- async >= 2.2 && < 2.3,- base >= 4.11 && < 5,- bytestring >= 0.10 && < 0.12,- Diff >= 0.3 && < 0.5,- directory >= 1.3 && < 1.4,- filepath >= 1.4 && < 1.5,- Glob >= 0.10 && < 0.11,- optparse-applicative >= 0.14 && < 0.18,- process >= 1.6 && < 1.7,+ aeson >= 1.4 && < 2.3,+ aeson-pretty >= 0.8 && < 0.9,+ async >= 2.2 && < 2.3,+ base >= 4.11 && < 5,+ bytestring >= 0.10 && < 0.13,+ Diff >= 0.3 && < 0.6,+ directory >= 1.3 && < 1.4,+ filepath >= 1.4 && < 1.6,+ Glob >= 0.10 && < 0.11,+ optparse-applicative >= 0.14 && < 0.19,+ process >= 1.6 && < 1.7, regex-pcre-builtin >= 0.95.1.3 && < 0.96,- text >= 1.2 && < 2.1,- unordered-containers >= 0.2 && < 0.3+ text >= 1.2 && < 2.2,+ unordered-containers >= 0.2 && < 0.3 +Executable goldplate+ Main-is: Main.hs+ Default-language: Haskell2010+ Ghc-options: -Wall -rtsopts -threaded+ Build-depends: base, goldplate+ Test-suite tests Default-language: Haskell2010 Type: exitcode-stdio-1.0- Ghc-options: -threaded+ Ghc-options: -Wall -threaded Main-is: Tests.hs- Build-depends: base, process Build-tool-depends: goldplate:goldplate Hs-source-dirs: tests+ Build-depends: aeson, base, bytestring, goldplate, process
+ src/Goldplate.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Goldplate+ ( main++ , Options+ , defaultOptions+ , mainWith++ , Spec (..)+ , Assert (..)+ ) where++import Control.Applicative (optional, (<|>))+import qualified Control.Concurrent.Async as Async+import qualified Control.Concurrent.MVar as MVar+import Control.Exception (Exception, finally, throwIO)+import Control.Monad (forM, forM_, mzero, unless, when)+import qualified Data.Aeson as A+import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty+import Data.Algorithm.Diff+import Data.Algorithm.DiffOutput+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Foldable as F+import Data.Function (on)+import qualified Data.HashMap.Strict as HMS+import qualified Data.IORef as IORef+import qualified Data.List as List+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Version (showVersion)+import qualified Options.Applicative as OA+import Paths_goldplate (version)+import qualified System.Directory as Dir+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..), exitWith)+import qualified System.FilePath as FP+import qualified System.FilePath.Glob as Glob+import qualified System.IO as IO+import qualified System.Process as Process+import qualified Text.Regex.PCRE.Simple as Pcre+import Text.Splice++--------------------------------------------------------------------------------++-- | This is a little helper type that we use when we either support multiple+-- things (e.g. lines of stdin) or a single thing (e.g. a single string of+-- stdin).+data Multiple a = Multiple [a] | Single a+ deriving (Foldable, Functor, Traversable)++instance A.FromJSON a => A.FromJSON (Multiple a) where+ parseJSON v = (Multiple <$> A.parseJSON v) <|> (Single <$> A.parseJSON v)++multipleToList :: Multiple a -> [a]+multipleToList = F.toList++--------------------------------------------------------------------------------++-- | A specification that we parse from a JSON file.+-- The type parameter indicates the fields that we allow splicing over.+data Spec a = Spec+ { specInputFiles :: !(Maybe a)+ , specCommand :: !a+ , specArguments :: ![a]+ , specStdin :: !(Maybe (Multiple a))+ , specEnv :: ![(a, a)]+ , specWorkDir :: !(Maybe a)+ , specAsserts :: ![Assert a]+ } deriving (Foldable, Functor, Traversable)++instance A.FromJSON (Spec String) where+ parseJSON = A.withObject "FromJSON Spec" $ \o -> Spec+ <$> o A..:? "input_files"+ <*> o A..: "command"+ <*> o A..:? "arguments" A..!= []+ <*> o A..:? "stdin"+ <*> (maybe [] HMS.toList <$> o A..:? "environment")+ <*> o A..:? "working_directory"+ <*> o A..: "asserts"++--------------------------------------------------------------------------------++-- | Post processing of stdout or created files.+type PostProcess = [PostProcessStep]++data PostProcessStep+ = PrettifyJsonStep+ | ReplaceStep !Pcre.Regex !T.Text++instance A.FromJSON PostProcessStep where+ parseJSON = \case+ A.String "prettify_json" -> pure PrettifyJsonStep+ A.Object o -> ReplaceStep+ <$> (do+ p <- o A..: "pattern"+ either (fail . show) return (Pcre.compile copts eopts p))+ <*> o A..: "replacement"+ _ -> mzero+ where+ copts = Pcre.optionUtf8 <> Pcre.optionMultiline+ eopts = mempty++postProcess :: PostProcess -> B.ByteString -> B.ByteString+postProcess ps bs0 = List.foldl' (flip postProcessStep) bs0 ps++postProcessStep :: PostProcessStep -> B.ByteString -> B.ByteString+postProcessStep PrettifyJsonStep bs = maybe bs+ (BL.toStrict . Aeson.Pretty.encodePretty' prettyConfig)+ (A.decodeStrict bs :: Maybe A.Value)+ where+ prettyConfig = Aeson.Pretty.defConfig+ { Aeson.Pretty.confIndent = (Aeson.Pretty.Spaces 2)+ , Aeson.Pretty.confCompare = compare+ }++postProcessStep (ReplaceStep regex replacement) bs =+ either (const bs) T.encodeUtf8 .+ Pcre.replaceAll regex replacement $ T.decodeUtf8 bs++--------------------------------------------------------------------------------++-- | Asserts that can happen after an execution.+data Assert a+ = ExitCodeAssert !Int+ | StdoutAssert+ { stdoutFilePath :: !a+ , stdoutPostProcess :: !PostProcess+ }+ | StderrAssert+ { stderrFilePath :: !a+ , stderrPostProcess :: !PostProcess+ }+ | CreatedFileAssert+ { createdFilePath :: !a+ , createdFileContents :: !(Maybe a)+ , createdFilePostProcess :: !PostProcess+ }+ | CreatedDirectoryAssert+ { createdDirectoryPath :: !a+ }+ deriving (Foldable, Functor, Traversable)++instance A.FromJSON a => A.FromJSON (Assert a) where+ parseJSON = A.withObject "FromJSON Assert" $ \o -> do+ options <- sequenceA $ map optional+ [ ExitCodeAssert <$> o A..: "exit_code"+ , StdoutAssert <$> o A..: "stdout" <*> pp o+ , StderrAssert <$> o A..: "stderr" <*> pp o+ , CreatedFileAssert+ <$> o A..: "created_file" <*> o A..:? "contents" <*> pp o+ , CreatedDirectoryAssert <$> o A..: "created_directory"+ ]+ case catMaybes options of+ [opt] -> pure opt+ [] -> fail "no assert discriminator"+ opts -> fail $ "multiple assert discriminators: " +++ List.intercalate ", " (map assertDiscriminator opts)+ where+ pp o = maybe [] multipleToList <$> o A..:? "post_process"++assertDiscriminator :: Assert a -> String+assertDiscriminator (ExitCodeAssert _) = "exit_code"+assertDiscriminator (StdoutAssert _ _) = "stdout"+assertDiscriminator (StderrAssert _ _) = "stderr"+assertDiscriminator (CreatedFileAssert _ _ _) = "created_file"+assertDiscriminator (CreatedDirectoryAssert _) = "created_directory"++--------------------------------------------------------------------------------++data Logger = Logger+ { logDebug :: [String] -> IO ()+ , logError :: [String] -> IO ()+ , logOut :: [String] -> IO ()+ }++makeLogger :: Bool -> IO Logger+makeLogger verbose = do+ lock <- MVar.newMVar ()+ let writeLines h ls = MVar.withMVar lock $ \() -> mapM_ (IO.hPutStrLn h) ls+ return Logger+ { logDebug = if verbose then writeLines IO.stderr else \_ -> pure ()+ , logError = writeLines IO.stderr+ , logOut = writeLines IO.stdout+ }++--------------------------------------------------------------------------------++-- | A plain 'Spec' parsed from a JSON file usually gives us one more or+-- executions of a process. This contains more info than a plain 'Spec'.+data Execution = Execution+ { executionSpec :: Spec String+ , executionInputFile :: Maybe FilePath+ , executionSpecPath :: FilePath+ , executionSpecName :: String+ , executionDirectory :: FilePath+ }++specExecutions :: FilePath -> Spec String -> IO [Execution]+specExecutions specPath spec = do+ absoluteSpecPath <- Dir.makeAbsolute specPath+ let (specDirectory, specBaseName) = FP.splitFileName specPath+ specName = FP.dropExtension specBaseName++ mkAbsoluteWorkDir :: FilePath -> FilePath+ mkAbsoluteWorkDir dir | FP.isRelative dir = specDirectory FP.</> dir+ | otherwise = dir++ workDirectory = maybe specDirectory mkAbsoluteWorkDir (specWorkDir spec)++ -- Compute initial environment to get input files.+ env0 <- getEnvironment+ let env1 =+ List.nubBy ((==) `on` fst) $+ ("GOLDPLATE_NAME", specName) :+ ("GOLDPLATE_FILE", absoluteSpecPath) :+ ("GOLDPLATE_BASENAME", specBaseName) :+ specEnv spec ++ env0++ -- Get a list of concrete input files (a list maybes).+ concreteInputFiles <- case specInputFiles spec of+ Nothing -> return [Nothing]+ Just glob0 -> do+ glob <- hoistEither $ splice env1 glob0+ inputFiles <- Dir.withCurrentDirectory workDirectory $ do+ matches <- globCurrentDir glob+ length matches `seq` return matches+ return (map (Just . FP.normalise) inputFiles)++ -- Create an execution for every concrete input.+ forM concreteInputFiles $ \mbInputFile -> do+ -- Extend environment.+ let env2 = case mbInputFile of+ Nothing -> env1+ Just inputFile ->+ ("GOLDPLATE_INPUT_FILE", inputFile) :+ ("GOLDPLATE_INPUT_NAME", FP.dropExtension inputFile) :+ ("GOLDPLATE_INPUT_BASENAME", snd $ FP.splitFileName inputFile) :+ env1++ -- Return execution after doing some splicing.+ hoistEither $ do+ spec' <- traverse (splice env2) spec+ pure Execution+ { executionSpec = spec' {specEnv = env2}+ , executionInputFile = mbInputFile+ , executionSpecPath = specPath+ , executionSpecName = specName+ , executionDirectory = workDirectory+ }+ where+ hoistEither :: Either MissingEnvVar a -> IO a+ hoistEither = either throwIO return+++executionHeader :: Execution -> String+executionHeader execution =+ executionSpecPath execution +++ case executionInputFile execution of+ Nothing -> ": "+ Just fp -> " (" ++ fp ++ "): "++--------------------------------------------------------------------------------++data Env = Env+ { envLogger :: !Logger+ , envDiff :: !Bool+ , envPrettyDiff :: !Bool+ , envFix :: !Bool+ }++data ExecutionResult = ExecutionResult+ { erExitCode :: !ExitCode+ , erStdout :: !B.ByteString+ , erStderr :: !B.ByteString+ } deriving (Show)++runExecution+ :: Env -> Execution -> IO ExecutionResult+runExecution env execution@Execution {..} = do+ let Spec {..} = executionSpec+ logDebug (envLogger env) [executionHeader execution ++ "running..."]++ -- Create a "CreateProcess" description.+ let createProcess = (Process.proc specCommand specArguments)+ { Process.env = Just specEnv+ , Process.cwd = Just executionDirectory+ , Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.CreatePipe+ }++ -- Actually run the process.+ logDebug (envLogger env) [executionHeader execution +++ specCommand ++ " " ++ unwords specArguments]+ (Just hIn, Just hOut, Just hErr, hProc) <-+ Process.createProcess createProcess++ let writeStdin = (`finally` IO.hClose hIn) $ case specStdin of+ Nothing -> pure ()+ Just (Single str) -> IO.hPutStr hIn str+ Just (Multiple strs) -> mapM_ (IO.hPutStrLn hIn) strs+ Async.withAsync writeStdin $ \_ ->+ Async.withAsync (B.hGetContents hOut) $ \outAsync ->+ Async.withAsync (B.hGetContents hErr) $ \errAsync ->+ Async.withAsync (Process.waitForProcess hProc) $ \exitAsync -> do++ -- Get output.+ !exitCode <- Async.wait exitAsync+ !actualOut <- Async.wait outAsync+ !actualErr <- Async.wait errAsync+ logDebug (envLogger env)+ [ executionHeader execution ++ "finished"+ , "exit code: " ++ show exitCode+ , "stdout:", show actualOut+ , "stderr:", show actualErr+ ]+ pure ExecutionResult+ { erExitCode = exitCode+ , erStdout = actualOut+ , erStderr = actualErr+ }++--------------------------------------------------------------------------------++data AssertResult = AssertResult+ { arOk :: Bool+ , arHeader :: String+ , arMessage :: [String]+ } deriving (Show)++assertResultToTap :: AssertResult -> [String]+assertResultToTap ar =+ ((if arOk ar then "ok " else "not ok ") ++ arHeader ar) :+ map (" " ++) (concatMap lines $ arMessage ar)++-- | Check a single assertion.+runAssert+ :: Env -> Execution -> ExecutionResult -> Assert String -> IO AssertResult+runAssert env execution@Execution {..} ExecutionResult {..} assert =+ case assert of+ ExitCodeAssert expectedExitCode ->+ let actualExitCode = case erExitCode of+ ExitSuccess -> 0+ ExitFailure c -> c+ success = expectedExitCode == actualExitCode in+ pure $ makeAssertResult success+ ["expected " ++ show expectedExitCode +++ " but got " ++ show actualExitCode | not success]++ StdoutAssert {..} -> checkAgainstFile+ (inExecutionDir stdoutFilePath) stdoutPostProcess erStdout++ StderrAssert {..} -> checkAgainstFile+ (inExecutionDir stderrFilePath) stderrPostProcess erStderr++ CreatedFileAssert {..} -> do+ let path = inExecutionDir createdFilePath+ exists <- Dir.doesFileExist path+ case exists of+ False -> pure $ makeAssertResult False+ [createdFilePath ++ " was not created"]+ True -> case createdFileContents of+ Nothing -> pure $ makeAssertResult True []+ Just expectedPath -> do+ !actual <- readFileOrEmpty path+ ar <- checkAgainstFile+ (inExecutionDir expectedPath)+ createdFilePostProcess actual+ Dir.removeFile path+ logDebug (envLogger env)+ [executionHeader execution ++ "removed " ++ path]+ pure ar++ CreatedDirectoryAssert {..} -> do+ let path = inExecutionDir createdDirectoryPath+ exists <- Dir.doesDirectoryExist path+ case exists of+ False -> pure $ makeAssertResult False+ [createdDirectoryPath ++ " was not created"]+ True -> do+ Dir.removeDirectoryRecursive path+ logDebug (envLogger env)+ [executionHeader execution ++ "removed " ++ path]+ pure $ makeAssertResult True []+ where+ makeAssertResult ok = AssertResult ok+ (executionHeader execution ++ assertDiscriminator assert)++ inExecutionDir :: FilePath -> FilePath+ inExecutionDir fp =+ if FP.isAbsolute fp then fp else executionDirectory FP.</> fp++ checkAgainstFile+ :: FilePath -> PostProcess -> B.ByteString -> IO AssertResult+ checkAgainstFile expectedPath processor actual0 = do+ expected <- readFileOrEmpty expectedPath+ let !actual1 = postProcess processor actual0+ success = actual1 == expected+ shouldFix = envFix env && not success++ diff :: [Diff [String]] = either (const []) id $ do+ expected' <- T.unpack <$> T.decodeUtf8' expected+ actual1' <- T.unpack <$> T.decodeUtf8' actual1+ return $+ getGroupedDiff+ (lines expected')+ (lines actual1')++ when shouldFix $ B.writeFile expectedPath actual1+ pure . makeAssertResult success . concat $+ [ [ "expected:"+ , show expected+ , "actual:"+ , show actual1+ ]+ | not success && envDiff env+ ] +++ [ [ "diff:", ppDiff diff ]+ | not success && envPrettyDiff env+ ] +++ [ ["fixed " ++ expectedPath] | shouldFix ]+++--------------------------------------------------------------------------------++-- | Read a file if it exists, otherwise pretend it's empty.+readFileOrEmpty :: FilePath -> IO B.ByteString+readFileOrEmpty fp = do+ exists <- Dir.doesFileExist fp+ if exists then B.readFile fp else return B.empty++-- | Recursively finds all '.goldplate' files in bunch of files or directories.+findSpecs :: [FilePath] -> IO [FilePath]+findSpecs fps = fmap concat $ forM fps $ \fp -> do+ isDir <- Dir.doesDirectoryExist fp+ case isDir of+ False -> return [fp]+ True -> Glob.globDir1 (Glob.compile "**/*.goldplate") fp++-- | Perform a glob match in the current directory.+--+-- This is a drop-in replacement for `glob` from the `Glob` library, which has a+-- an annoying tendency to return absolute file paths.+globCurrentDir :: String -> IO [FilePath]+globCurrentDir pattern =+ map dropLeadingDot <$> Glob.globDir1 (Glob.compile pattern) "."+ where+ dropLeadingDot fp0 = case break FP.isPathSeparator fp0 of+ (".", fp1) -> drop 1 fp1+ _ -> fp0++--------------------------------------------------------------------------------++-- | Command-line options.+data Options = Options+ { oPaths :: [FilePath]+ , oVerbose :: Bool+ , oDiff :: Bool+ , oPrettyDiff :: Bool+ , oFix :: Bool+ , oJobs :: Int+ }++defaultOptions :: Options+defaultOptions = Options+ { oPaths = []+ , oVerbose = False+ , oDiff = False+ , oPrettyDiff = False+ , oFix = False+ , oJobs = 1+ }++parseOptions :: OA.Parser Options+parseOptions = Options+ <$> OA.some (OA.strArgument (+ OA.metavar "PATH" <>+ OA.help "Test files/directories"))+ <*> OA.switch (+ OA.short 'v' <>+ OA.help "Print debug info")+ <*> OA.switch (+ OA.long "diff" <>+ OA.help "Show differences in files")+ <*> OA.switch (+ OA.long "pretty-diff" <>+ OA.help "Show differences in files, output in patch format")+ <*> OA.switch (+ OA.long "fix" <>+ OA.help "Attempt to fix broken tests")+ <*> OA.option OA.auto (+ OA.long "jobs" <>+ OA.short 'j' <>+ OA.value (oJobs defaultOptions) <>+ OA.help "Number of worker jobs")++parserInfo :: OA.ParserInfo Options+parserInfo = OA.info (OA.helper <*> versionOption <*> parseOptions) $+ OA.fullDesc <>+ OA.header goldplateVersion+ where+ versionOption = OA.infoOption goldplateVersion $+ OA.long "version" <>+ OA.short 'V' <>+ OA.help "Show version info" <>+ OA.hidden+ goldplateVersion :: String+ goldplateVersion = "goldplate v" <> showVersion version++--------------------------------------------------------------------------------++-- | Spawn a worker thread that takes workloads from a shared pool.+worker+ :: IORef.IORef [a] -- ^ Ref to a pool of work+ -> (a -> IO ()) -- ^ Worker function+ -> IO ()+worker pool f = do+ mbWorkload <- IORef.atomicModifyIORef' pool $ \case+ [] -> ([], Nothing)+ (x : xs) -> (xs, Just x)+ case mbWorkload of+ Nothing -> return ()+ Just workload -> f workload >> worker pool f++--------------------------------------------------------------------------------++data InvalidSpec = InvalidSpec FilePath deriving (Show)++instance Exception InvalidSpec++mainWith :: Options -> IO ExitCode+mainWith options = do+ failed <- IORef.newIORef (0 :: Int)+ env <- Env+ <$> makeLogger (oVerbose options)+ <*> pure (oDiff options)+ <*> pure (oPrettyDiff options)+ <*> pure (oFix options)++ -- Find all specs and decode them.+ specPaths <- findSpecs (oPaths options)+ specs <- forM specPaths $ \specPath -> do+ !errOrSpec <- A.eitherDecodeStrict <$> B.readFile specPath+ case errOrSpec of+ Right !spec -> return (specPath, spec)+ Left !err -> do+ logError (envLogger env)+ [specPath ++ ": could not parse JSON: " ++ err]+ throwIO $ InvalidSpec specPath++ -- Each spec might produce a number of executions. We can't really+ -- parallelize this because 'specExecutions' needs to change the working+ -- directory all the time and that might mess with our tests.+ let numSpecs = length specs+ logDebug (envLogger env) ["Found " ++ show numSpecs ++ " specs"]+ executions <- fmap concat $ forM specs $+ \(specPath, spec) -> specExecutions specPath spec++ -- Create a pool full of executions.+ let numJobs = oJobs options+ numAsserts = sum $+ map (length . specAsserts . executionSpec) executions+ logOut (envLogger env) ["1.." ++ show numAsserts]+ pool <- IORef.newIORef executions++ -- Spawn some workers to run the executions.+ Async.replicateConcurrently_ numJobs $ worker pool $ \execution -> do+ executionResult <- runExecution env execution+ forM_ (specAsserts $ executionSpec execution) $ \assert -> do+ assertResult <- runAssert env execution executionResult assert+ unless (arOk assertResult) $ IORef.atomicModifyIORef' failed $+ \x -> (x + 1, ())+ logOut (envLogger env) $ assertResultToTap assertResult++ -- Report summary.+ numFailed <- IORef.readIORef failed+ logOut (envLogger env) . pure $+ "# goldplate ran " ++ show numAsserts ++ " asserts, " +++ (if numFailed > 0 then show numFailed ++ " failed" else "all OK")+ pure $ if numFailed > 0 then ExitFailure 1 else ExitSuccess++main :: IO ()+main = do+ options <- OA.execParser parserInfo+ mainWith options >>= exitWith
− src/Main.hs
@@ -1,562 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Main- ( main- ) where--import Control.Applicative ((<|>))-import qualified Control.Concurrent.Async as Async-import qualified Control.Concurrent.MVar as MVar-import Control.Exception (finally, throwIO)-import Control.Monad (forM, forM_, mzero, unless, when)-import qualified Data.Aeson as A-import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty-import Data.Algorithm.Diff-import Data.Algorithm.DiffOutput-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Foldable as F-import Data.Function (on)-import qualified Data.HashMap.Strict as HMS-import qualified Data.IORef as IORef-import qualified Data.List as List-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Version (showVersion)-import qualified Options.Applicative as OA-import Paths_goldplate (version)-import qualified System.Directory as Dir-import System.Environment (getEnvironment)-import System.Exit (ExitCode (..), exitFailure)-import qualified System.FilePath as FP-import qualified System.FilePath.Glob as Glob-import qualified System.IO as IO-import qualified System.Process as Process-import qualified Text.Regex.PCRE.Simple as Pcre-import Text.Splice-------------------------------------------------------------------------------------- | This is a little helper type that we use when we either support multiple--- things (e.g. lines of stdin) or a single thing (e.g. a single string of--- stdin).-data Multiple a = Multiple [a] | Single a- deriving (Foldable, Functor, Traversable)--instance A.FromJSON a => A.FromJSON (Multiple a) where- parseJSON v = (Multiple <$> A.parseJSON v) <|> (Single <$> A.parseJSON v)--multipleToList :: Multiple a -> [a]-multipleToList = F.toList-------------------------------------------------------------------------------------- | A specification that we parse from a JSON file.--- The type parameter indicates the fields that we allow splicing over.-data Spec a = Spec- { specInputFiles :: !(Maybe a)- , specCommand :: !a- , specArguments :: ![a]- , specStdin :: !(Maybe (Multiple a))- , specEnv :: ![(a, a)]- , specWorkDir :: !(Maybe a)- , specAsserts :: ![Assert a]- } deriving (Foldable, Functor, Traversable)--instance A.FromJSON (Spec String) where- parseJSON = A.withObject "FromJSON Spec" $ \o -> Spec- <$> o A..:? "input_files"- <*> o A..: "command"- <*> o A..:? "arguments" A..!= []- <*> o A..:? "stdin"- <*> (maybe [] HMS.toList <$> o A..:? "environment")- <*> o A..:? "working_directory"- <*> o A..: "asserts"-------------------------------------------------------------------------------------- | Post processing of stdout or created files.-type PostProcess = [PostProcessStep]--data PostProcessStep- = PrettifyJsonStep- | ReplaceStep !Pcre.Regex !T.Text--instance A.FromJSON PostProcessStep where- parseJSON = \case- A.String "prettify_json" -> pure PrettifyJsonStep- A.Object o -> ReplaceStep- <$> (do- p <- o A..: "pattern"- either (fail . show) return (Pcre.compile copts eopts p))- <*> o A..: "replacement"- _ -> mzero- where- copts = Pcre.optionUtf8 <> Pcre.optionMultiline- eopts = mempty--postProcess :: PostProcess -> B.ByteString -> B.ByteString-postProcess ps bs0 = List.foldl' (flip postProcessStep) bs0 ps--postProcessStep :: PostProcessStep -> B.ByteString -> B.ByteString-postProcessStep PrettifyJsonStep bs = maybe bs- (BL.toStrict . Aeson.Pretty.encodePretty' prettyConfig)- (A.decodeStrict bs :: Maybe A.Value)- where- prettyConfig = Aeson.Pretty.defConfig- { Aeson.Pretty.confIndent = (Aeson.Pretty.Spaces 2)- , Aeson.Pretty.confCompare = compare- }--postProcessStep (ReplaceStep regex replacement) bs =- either (const bs) T.encodeUtf8 .- Pcre.replaceAll regex replacement $ T.decodeUtf8 bs-------------------------------------------------------------------------------------- | Asserts that can happen after an execution.-data Assert a- = ExitCodeAssert !Int- | StdoutAssert- { stdoutFilePath :: !a- , stdoutPostProcess :: !PostProcess- }- | StderrAssert- { stderrFilePath :: !a- , stderrPostProcess :: !PostProcess- }- | CreatedFileAssert- { createdFilePath :: !a- , createdFileContents :: !(Maybe a)- , createdFilePostProcess :: !PostProcess- }- | CreatedDirectoryAssert- { createdDirectoryPath :: !a- }- deriving (Foldable, Functor, Traversable)--instance A.FromJSON a => A.FromJSON (Assert a) where- parseJSON = A.withObject "FromJSON Assert" $ \o ->- (ExitCodeAssert <$> o A..: "exit_code") <|>- (StdoutAssert <$> o A..: "stdout" <*> pp o) <|>- (StderrAssert <$> o A..: "stderr" <*> pp o) <|>- (CreatedFileAssert- <$> o A..: "created_file" <*> o A..:? "contents" <*> pp o) <|>- (CreatedDirectoryAssert <$> o A..: "created_directory")- where- pp o = maybe [] multipleToList <$> o A..:? "post_process"--describeAssert :: Assert a -> String-describeAssert (ExitCodeAssert _) = "exit_code"-describeAssert (StdoutAssert _ _) = "stdout"-describeAssert (StderrAssert _ _) = "stderr"-describeAssert (CreatedFileAssert _ _ _) = "created_file"-describeAssert (CreatedDirectoryAssert _) = "created_directory"------------------------------------------------------------------------------------data Logger = Logger- { logDebug :: [String] -> IO ()- , logError :: [String] -> IO ()- , logOut :: [String] -> IO ()- }--makeLogger :: Bool -> IO Logger-makeLogger verbose = do- lock <- MVar.newMVar ()- let writeLines h ls = MVar.withMVar lock $ \() -> mapM_ (IO.hPutStrLn h) ls- return Logger- { logDebug = if verbose then writeLines IO.stderr else \_ -> pure ()- , logError = writeLines IO.stderr- , logOut = writeLines IO.stdout- }-------------------------------------------------------------------------------------- | A plain 'Spec' parsed from a JSON file usually gives us one more or--- executions of a process. This contains more info than a plain 'Spec'.-data Execution = Execution- { executionSpec :: Spec String- , executionInputFile :: Maybe FilePath- , executionSpecPath :: FilePath- , executionSpecName :: String- , executionDirectory :: FilePath- }--specExecutions :: FilePath -> Spec String -> IO [Execution]-specExecutions specPath spec = do- absoluteSpecPath <- Dir.makeAbsolute specPath- let (specDirectory, specBaseName) = FP.splitFileName specPath- specName = FP.dropExtension specBaseName-- mkAbsoluteWorkDir :: FilePath -> FilePath- mkAbsoluteWorkDir dir | FP.isRelative dir = specDirectory FP.</> dir- | otherwise = dir-- workDirectory = maybe specDirectory mkAbsoluteWorkDir (specWorkDir spec)-- -- Compute initial environment to get input files.- env0 <- getEnvironment- let env1 =- List.nubBy ((==) `on` fst) $- ("GOLDPLATE_NAME", specName) :- ("GOLDPLATE_FILE", absoluteSpecPath) :- ("GOLDPLATE_BASENAME", specBaseName) :- specEnv spec ++ env0-- -- Get a list of concrete input files (a list maybes).- concreteInputFiles <- case specInputFiles spec of- Nothing -> return [Nothing]- Just glob0 -> do- glob <- hoistEither $ splice env1 glob0- inputFiles <- Dir.withCurrentDirectory workDirectory $ do- matches <- globCurrentDir glob- length matches `seq` return matches- return (map (Just . FP.normalise) inputFiles)-- -- Create an execution for every concrete input.- forM concreteInputFiles $ \mbInputFile -> do- -- Extend environment.- let env2 = case mbInputFile of- Nothing -> env1- Just inputFile ->- ("GOLDPLATE_INPUT_FILE", inputFile) :- ("GOLDPLATE_INPUT_NAME", FP.dropExtension inputFile) :- ("GOLDPLATE_INPUT_BASENAME", snd $ FP.splitFileName inputFile) :- env1-- -- Return execution after doing some splicing.- hoistEither $ do- spec' <- traverse (splice env2) spec- pure Execution- { executionSpec = spec' {specEnv = env2}- , executionInputFile = mbInputFile- , executionSpecPath = specPath- , executionSpecName = specName- , executionDirectory = workDirectory- }- where- hoistEither :: Either MissingEnvVar a -> IO a- hoistEither = either throwIO return---executionHeader :: Execution -> String-executionHeader execution =- executionSpecPath execution ++- case executionInputFile execution of- Nothing -> ": "- Just fp -> " (" ++ fp ++ "): "------------------------------------------------------------------------------------data Env = Env- { envLogger :: !Logger- , envDiff :: !Bool- , envPrettyDiff :: !Bool- , envFix :: !Bool- }--data ExecutionResult = ExecutionResult- { erExitCode :: !ExitCode- , erStdout :: !B.ByteString- , erStderr :: !B.ByteString- } deriving (Show)--runExecution- :: Env -> Execution -> IO ExecutionResult-runExecution env execution@Execution {..} = do- let Spec {..} = executionSpec- logDebug (envLogger env) [executionHeader execution ++ "running..."]-- -- Create a "CreateProcess" description.- let createProcess = (Process.proc specCommand specArguments)- { Process.env = Just specEnv- , Process.cwd = Just executionDirectory- , Process.std_in = Process.CreatePipe- , Process.std_out = Process.CreatePipe- , Process.std_err = Process.CreatePipe- }-- -- Actually run the process.- logDebug (envLogger env) [executionHeader execution ++- specCommand ++ " " ++ unwords specArguments]- (Just hIn, Just hOut, Just hErr, hProc) <-- Process.createProcess createProcess-- let writeStdin = (`finally` IO.hClose hIn) $ case specStdin of- Nothing -> pure ()- Just (Single str) -> IO.hPutStr hIn str- Just (Multiple strs) -> mapM_ (IO.hPutStrLn hIn) strs- Async.withAsync writeStdin $ \_ ->- Async.withAsync (B.hGetContents hOut) $ \outAsync ->- Async.withAsync (B.hGetContents hErr) $ \errAsync ->- Async.withAsync (Process.waitForProcess hProc) $ \exitAsync -> do-- -- Get output.- !exitCode <- Async.wait exitAsync- !actualOut <- Async.wait outAsync- !actualErr <- Async.wait errAsync- logDebug (envLogger env)- [ executionHeader execution ++ "finished"- , "exit code: " ++ show exitCode- , "stdout:", show actualOut- , "stderr:", show actualErr- ]- pure ExecutionResult- { erExitCode = exitCode- , erStdout = actualOut- , erStderr = actualErr- }------------------------------------------------------------------------------------data AssertResult = AssertResult- { arOk :: Bool- , arHeader :: String- , arMessage :: [String]- } deriving (Show)--assertResultToTap :: AssertResult -> [String]-assertResultToTap ar =- ((if arOk ar then "ok " else "not ok ") ++ arHeader ar) :- map (" " ++) (concatMap lines $ arMessage ar)---- | Check a single assertion.-runAssert- :: Env -> Execution -> ExecutionResult -> Assert String -> IO AssertResult-runAssert env execution@Execution {..} ExecutionResult {..} assert =- case assert of- ExitCodeAssert expectedExitCode ->- let actualExitCode = case erExitCode of- ExitSuccess -> 0- ExitFailure c -> c- success = expectedExitCode == actualExitCode in- pure $ makeAssertResult success- ["expected " ++ show expectedExitCode ++- " but got " ++ show actualExitCode | not success]-- StdoutAssert {..} -> checkAgainstFile- (inExecutionDir stdoutFilePath) stdoutPostProcess erStdout-- StderrAssert {..} -> checkAgainstFile- (inExecutionDir stderrFilePath) stderrPostProcess erStderr-- CreatedFileAssert {..} -> do- let path = inExecutionDir createdFilePath- exists <- Dir.doesFileExist path- case exists of- False -> pure $ makeAssertResult False- [createdFilePath ++ " was not created"]- True -> case createdFileContents of- Nothing -> pure $ makeAssertResult True []- Just expectedPath -> do- !actual <- readFileOrEmpty path- ar <- checkAgainstFile- (inExecutionDir expectedPath)- createdFilePostProcess actual- Dir.removeFile path- logDebug (envLogger env)- [executionHeader execution ++ "removed " ++ path]- pure ar-- CreatedDirectoryAssert {..} -> do- let path = inExecutionDir createdDirectoryPath- exists <- Dir.doesDirectoryExist path- case exists of- False -> pure $ makeAssertResult False- [createdDirectoryPath ++ " was not created"]- True -> do- Dir.removeDirectoryRecursive path- logDebug (envLogger env)- [executionHeader execution ++ "removed " ++ path]- pure $ makeAssertResult True []- where- makeAssertResult ok = AssertResult ok- (executionHeader execution ++ describeAssert assert)-- inExecutionDir :: FilePath -> FilePath- inExecutionDir fp =- if FP.isAbsolute fp then fp else executionDirectory FP.</> fp-- checkAgainstFile- :: FilePath -> PostProcess -> B.ByteString -> IO AssertResult- checkAgainstFile expectedPath processor actual0 = do- expected <- readFileOrEmpty expectedPath- let !actual1 = postProcess processor actual0- success = actual1 == expected- shouldFix = envFix env && not success-- diff :: [Diff [String]] = either (const []) id $ do- expected' <- T.unpack <$> T.decodeUtf8' expected- actual1' <- T.unpack <$> T.decodeUtf8' actual1- return $- getGroupedDiff- (lines expected')- (lines actual1')-- when shouldFix $ B.writeFile expectedPath actual1- pure . makeAssertResult success . concat $- [ [ "expected:"- , show expected- , "actual:"- , show actual1- ]- | not success && envDiff env- ] ++- [ [ "diff:", ppDiff diff ]- | not success && envPrettyDiff env- ] ++- [ ["fixed " ++ expectedPath] | shouldFix ]--------------------------------------------------------------------------------------- | Read a file if it exists, otherwise pretend it's empty.-readFileOrEmpty :: FilePath -> IO B.ByteString-readFileOrEmpty fp = do- exists <- Dir.doesFileExist fp- if exists then B.readFile fp else return B.empty---- | Recursively finds all '.goldplate' files in bunch of files or directories.-findSpecs :: [FilePath] -> IO [FilePath]-findSpecs fps = fmap concat $ forM fps $ \fp -> do- isDir <- Dir.doesDirectoryExist fp- case isDir of- False -> return [fp]- True -> Glob.globDir1 (Glob.compile "**/*.goldplate") fp---- | Perform a glob match in the current directory.------ This is a drop-in replacement for `glob` from the `Glob` library, which has a--- an annoying tendency to return absolute file paths.-globCurrentDir :: String -> IO [FilePath]-globCurrentDir pattern =- map dropLeadingDot <$> Glob.globDir1 (Glob.compile pattern) "."- where- dropLeadingDot fp0 = case break FP.isPathSeparator fp0 of- (".", fp1) -> drop 1 fp1- _ -> fp0-------------------------------------------------------------------------------------- | Command-line options.-data Options = Options- { oPaths :: [FilePath]- , oVerbose :: Bool- , oDiff :: Bool- , oPrettyDiff :: Bool- , oFix :: Bool- , oJobs :: Int- }--parseOptions :: OA.Parser Options-parseOptions = Options- <$> OA.some (OA.strArgument (- OA.metavar "PATH" <>- OA.help "Test files/directories"))- <*> OA.switch (- OA.short 'v' <>- OA.help "Print debug info")- <*> OA.switch (- OA.long "diff" <>- OA.help "Show differences in files")- <*> OA.switch (- OA.long "pretty-diff" <>- OA.help "Show differences in files, output in patch format")- <*> OA.switch (- OA.long "fix" <>- OA.help "Attempt to fix broken tests")- <*> OA.option OA.auto (- OA.long "jobs" <>- OA.short 'j' <>- OA.value 1 <>- OA.help "Number of worker jobs")--parserInfo :: OA.ParserInfo Options-parserInfo = OA.info (OA.helper <*> versionOption <*> parseOptions) $- OA.fullDesc <>- OA.header goldplateVersion- where- versionOption = OA.infoOption goldplateVersion $- OA.long "version" <>- OA.short 'V' <>- OA.help "Show version info" <>- OA.hidden- goldplateVersion :: String- goldplateVersion = "goldplate v" <> showVersion version-------------------------------------------------------------------------------------- | Spawn a worker thread that takes workloads from a shared pool.-worker- :: IORef.IORef [a] -- ^ Ref to a pool of work- -> (a -> IO ()) -- ^ Worker function- -> IO ()-worker pool f = do- mbWorkload <- IORef.atomicModifyIORef' pool $ \case- [] -> ([], Nothing)- (x : xs) -> (xs, Just x)- case mbWorkload of- Nothing -> return ()- Just workload -> f workload >> worker pool f------------------------------------------------------------------------------------main :: IO ()-main = do- options <- OA.execParser parserInfo- failed <- IORef.newIORef (0 :: Int)- env <- Env- <$> makeLogger (oVerbose options)- <*> pure (oDiff options)- <*> pure (oPrettyDiff options)- <*> pure (oFix options)-- -- Find all specs and decode them.- specPaths <- findSpecs (oPaths options)- specs <- forM specPaths $ \specPath -> do- !errOrSpec <- A.eitherDecodeStrict <$> B.readFile specPath- case errOrSpec of- Right !spec -> return (specPath, spec)- Left !err -> do- logError (envLogger env)- [specPath ++ ": could not parse JSON: " ++ err]- exitFailure-- -- Each spec might produce a number of executions. We can't really- -- parallelize this because 'specExecutions' needs to change the working- -- directory all the time and that might mess with our tests.- let numSpecs = length specs- logDebug (envLogger env) ["Found " ++ show numSpecs ++ " specs"]- executions <- fmap concat $ forM specs $- \(specPath, spec) -> specExecutions specPath spec-- -- Create a pool full of executions.- let numJobs = oJobs options- numAsserts = sum $- map (length . specAsserts . executionSpec) executions- logOut (envLogger env) ["1.." ++ show numAsserts]- pool <- IORef.newIORef executions-- -- Spawn some workers to run the executions.- Async.replicateConcurrently_ numJobs $ worker pool $ \execution -> do- executionResult <- runExecution env execution- forM_ (specAsserts $ executionSpec execution) $ \assert -> do- assertResult <- runAssert env execution executionResult assert- unless (arOk assertResult) $ IORef.atomicModifyIORef' failed $- \x -> (x + 1, ())- logOut (envLogger env) $ assertResultToTap assertResult-- -- Report summary.- numFailed <- IORef.readIORef failed- logOut (envLogger env) . pure $- "# goldplate ran " ++ show numAsserts ++ " asserts, " ++- (if numFailed > 0 then show numFailed ++ " failed" else "all OK")- when (numFailed > 0) exitFailure
tests/Tests.hs view
@@ -1,5 +1,23 @@-import System.Exit ( exitWith )-import System.Process ( system )+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where+import qualified Data.Aeson as A+import Data.ByteString.Char8 ()+import qualified Data.List as List+import Goldplate (Assert)+import System.Exit (exitWith)+import System.Process (system) +-- See https://github.com/jaspervdj/goldplate/issues/22+testAssertMultipleDiscriminator :: IO ()+testAssertMultipleDiscriminator =+ case A.eitherDecode bytes :: Either String (Assert String) of+ Left err | "discriminator" `List.isInfixOf` err -> pure ()+ _ -> fail $+ "testAssertMultipleDiscriminator: expected discriminator error"+ where+ bytes = "{\"exit_code\": 0, \"stdout\": \"stdout.txt\"}"+ main :: IO ()-main = exitWith =<< system ("goldplate tests")+main = do+ testAssertMultipleDiscriminator+ exitWith =<< system ("goldplate tests")