diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# CHANGELOG + + - 0.1.0 (2020-06-20) + * Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,199 @@ +# goldplate 🏅 + + $ goldplate -j2 tests/ + Found 32 specs + Running 49 executions in 2 jobs + Finished in 0.84s + Ran 32 specs, 49 executions, 146 asserts, all A-OK! + +`goldplate` is a cute and simple opaque [golden test] runner for CLI +applications. You place your test cases in a directory, annotate them with +`.goldplate` files, and that's it. It is completely language agnostic. And +perhaps its best feature is that it can automatically✨🪄 fix your tests outputs! + +Give `goldplate` a try if: + + - You are testing a CLI application + - The application produces deterministic output (e.g. compilers, prettifiers, + convertors) + - 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. + + +## Table of Contents + +- [Tutorial](#tutorial) + - [Simple asserts](#simple-asserts) + - [Feeding input on stdin](#feeding-input-on-stdin) + - [Setting environment + variables](#setting-environment-variables) + - [Globbing input files](#globbing-input-files) + - [Post processing: find and + replace](#post-processing-find-and-replace) + - [Post processing: prettify + JSON](#post-processing-prettify-json) + - [Created files and + directories](#created-files-and-directories) +- [Installation](#installation) + - [Using stack](#using-stack) + - [Using Cabal](#using-cabal) +- [Reference](#reference) + - [Syntax](#syntax) + - [Environment variables](#environment-variables) +- [Similar projects](#similar-projects) + +## Tutorial + +You can follow along with the tutorial by cloning the repository and running +this command: + + $ goldplate tests + +As you can see, `goldplate` itself is tested using `goldplate`. In this +tutorial, we'll walk through some examples. By the end, you should have a good +idea of how to test your CLI application using `goldplate`. + +### Simple asserts + +View example: [`tests/echo.goldplate`](tests/echo.goldplate) + +In this very simple example, we just run `echo "Hello, world!"`. This is +specified in the `command` and `arguments` fields. + +The actual tests that we're executing live in the `asserts` field. This simple +test has two asserts: + +1. We verify that the exit code is 0 (success). +2. We check the `stdout` (output) of the command against the file + `${GOLDPLATE_NAME}.stdout`. `GOLDPLATE_NAME` is the name of the + specification without the extension; so our expected output lives in + [`tests/echo.stdout`](tests/echo.stdout) in this case. + +We can check that our asserts are correct: + + $ goldplate tests/echo.goldplate + +If we want to regenerate the expected output, we can simply do: + + $ rm tests/echo.stdout + $ goldplate --fix --pretty-diff tests/echo.goldplate + +And `goldplate` will show you that it fixed one file. + +### Feeding input on stdin + +View example: [`tests/cat.goldplate`](tests/cat.goldplate) + +You can pass one or multiple lines of input to the command by using the `stdin` +field. + +### Setting environment variables + +View example: [`tests/env.goldplate`](tests/env.goldplate) + +The `environment` field can be used to set environment variables for the +program. + +### Globbing input files + +View example: [`tests/glob.goldplate`](tests/glob.goldplate) + +`.goldplate` files are fairly small but if you have a whole directory of files +that you just want to run the same command on, they can get very repetitive. +This is why `goldplate` provides a simple way to pull in multiple input files. + +If the `input_files` field is set to a glob, all asserts will be ran for _every_ +matching input file. `goldplate` will set the following variables: + + - `${GOLDPLATE_INPUT_FILE}`: the path to the input file + - `${GOLDPLATE_INPUT_NAME}`: the input file without extension + +### Post processing: find and replace + +View example: [`tests/replace.goldplate`](tests/replace.goldplate) + +Sometimes you may want to do a find-and-replace on the actual output, for +example to filter out timestamps or other information that you do not expect to +match up against the expected output. + +### Post processing: prettify JSON + +View example: [`tests/prettify-json.goldplate`](tests/prettify-json.goldplate) + +Many modern CLI tools output JSON. You can use the `prettify_json` post +processor to make sure the JSON is converted to a normalized form with sorted +keys and consistent indentation. + +### Created files and directories + +View example: [`tests/create.goldplate`](tests/create.goldplate) + +`goldplate` is geared towards checking the `stdout` and `stderr` outputs of a +program, but you can also check that files were created with specific contents. +If you do this, `goldplate` will remove these files and directories afterwards +to leave a clean repository behind. + +## Installation + +Installation through source is done using standard Haskell tooling -- [Cabal] +and [stack] both work well. + +### Using stack + +1. Install [stack] for your platform. +2. Clone this repository and `cd` into it. +3. Run `stack install`. +4. Make sure `$HOME/.local/bin` is in your `$PATH`. + +### Using Cabal + +1. Install [Cabal] for your platform. +2. Clone this repository and `cd` into it. +3. Run `cabal install`. +4. Make sure `$HOME/.cabal/bin` is in your `$PATH`. + +## Reference + +### Syntax + +Environment variables can be spliced into the configuration using `${VAR}` +syntax within strings. To escape this syntax, use `$${VAR}` to get a literal +`${VAR}`, `$$${VAR}` to get a literal `$${VAR}`, and so on. + +### Environment variables + +The test is always executed in the directory that holds the `.goldplate` file. +`goldplate` will always set the following environment variables: + + - `GOLDPLATE_FILE`: The filename of the `.goldplate` file, e.g. + `echo.goldplate`. + - `GOLDPLATE_NAME`: The filename of the `.goldplate` file without the + extension, e.g. `echo`. + +When dealing with [multiple input files](#globbing-input-files), the following +additional variables are set: + + - `GOLDPLATE_INPUT_FILE`: The input file name, relative to the current + directory. + - `GOLDPLATE_INPUT_NAME`: The same as `GOLDPLATE_INPUT_FILE` but without + any extensions. + +## Similar projects + +A similar project is [smoke]. I think `goldplate` has two major advantages +over smoke: + + - It can fix the output files automatically using `--fix`! This is very + useful if you make a change to your tool that affects _a lot_ of test + files. You still need to manually review the diff, but at least you don't + need to manually update the specs. + - You can avoid most repetitive configs by using + [simple globbing](#globbing-input-files). + +[Cabal]: https://www.haskell.org/cabal/ +[golden test]: https://ro-che.info/articles/2017-12-04-golden-tests +[stack]: https://docs.haskellstack.org/en/stable/README/ +[smoke]: https://github.com/SamirTalwar/smoke diff --git a/goldplate.cabal b/goldplate.cabal new file mode 100644 --- /dev/null +++ b/goldplate.cabal @@ -0,0 +1,43 @@ +Name: goldplate +Version: 0.1.0 +Synopsis: A lightweight golden test runner +License: Apache-2.0 +License-file: LICENSE +Author: Jasper Van der Jeugt +Maintainer: Jasper Van der Jeugt +Copyright: 2019-2020 Fugue, Inc +Category: Language +Build-type: Simple +Cabal-version: 1.18 + +Extra-source-files: + CHANGELOG.md + README.md + +Executable goldplate + Hs-source-dirs: src + Main-is: Main.hs + Default-language: Haskell2010 + Ghc-options: -Wall -rtsopts -threaded -O2 + + Other-modules: + Data.Aeson.Extended + Text.Regex.PCRE.Simple + Paths_goldplate + + Build-depends: + aeson >= 1.4 && < 1.5, + aeson-pretty >= 0.8 && < 0.9, + async >= 2.2 && < 2.3, + base >= 4.9 && < 5, + bytestring >= 0.10 && < 0.11, + 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.16, + process >= 1.6 && < 1.7, + regex-pcre-builtin >= 0.95 && < 0.96, + text >= 1.2 && < 1.3, + time >= 1.8 && < 1.10, + unordered-containers >= 0.2 && < 0.3 diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extended.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +module Data.Aeson.Extended + ( module Data.Aeson + , Multiple (..) + , multipleToList + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson + +data Multiple a + = Multiple [a] + | Single a + deriving (Foldable, Functor, Traversable) + +instance FromJSON a => FromJSON (Multiple a) where + parseJSON val = (Multiple <$> parseJSON val) <|> (Single <$> parseJSON val) + +multipleToList :: Multiple a -> [a] +multipleToList (Multiple xs) = xs +multipleToList (Single x) = [x] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,589 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main + ( main + ) where + + +import Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.MVar as MVar +import Control.Exception (Exception, throwIO) +import Control.Monad (forM, forM_, forever, mzero, unless, + when) +import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty +import qualified Data.Aeson.Extended as A +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +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.Time (NominalDiffTime, diffUTCTime, + getCurrentTime) +import Data.Typeable (Typeable) +import Data.Version (showVersion) +import qualified Options.Applicative as OA +import Paths_goldplate (version) +import System.Directory (doesDirectoryExist, doesFileExist, + removeDirectoryRecursive, + removeFile, withCurrentDirectory) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..), exitFailure) +import System.FilePath (dropExtension, isAbsolute, + isPathSeparator, normalise, + takeBaseName, takeDirectory, ()) +import qualified System.FilePath.Glob as Glob +import qualified System.IO as IO +import qualified System.Process as Process +import Text.Printf (printf) +import qualified Text.Regex.PCRE.Simple as Pcre + + +-- | Environment for splicing in things. +type SpliceEnv = [(String, String)] + +data MissingEnvVar = MissingEnvVar String + deriving (Typeable) + +instance Show MissingEnvVar where + show (MissingEnvVar k) = "Missing environment variable: " ++ k + +instance Exception MissingEnvVar + +-- | Splice in a string with "Hello ${FOO}" syntax. +splice :: SpliceEnv -> String -> Either MissingEnvVar String +splice env = go + where + go str = case break (== '$') str of + -- Splice + (xs, '$' : '{' : ys) -> case break (== '}') ys of + (key, '}' : zs) -> case lookup key env of + Nothing -> Left $ MissingEnvVar key + Just val -> fmap ((xs ++ val) ++) (go zs) + (_, _) -> fmap ((xs ++ "${") ++) (go ys) + -- Escape + (xs, '$' : '$' : ys) -> + let (dollars, zs) = break (== '{') ys in + if all (== '$') dollars && "{" `List.isPrefixOf` zs + then (xs ++) . (dollars ++) . ("${" ++) <$> go (drop 1 zs) + else (xs ++) . ("$$" ++) <$> go ys + (xs, []) -> Right xs + (xs, (y : ys)) -> (xs ++) . (y :) <$> (go ys) + + +-- | The type parameter indicates the fields that we allow splicing over. +data Spec a = Spec + { sInputFiles :: !(Maybe a) + , sCommand :: !a + , sArguments :: ![a] + , sStdin :: !(Maybe (A.Multiple a)) + , sEnv :: ![(a, a)] + , sAsserts :: ![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..: "asserts" + + +type PostProcess = [PostProcessStep] + +data PostProcessStep + = PrettifyJsonStep + | ReplaceStep !Pcre.Regex !T.Text + +instance A.FromJSON PostProcessStep where + parseJSON (A.String s) = case s of + "prettify_json" -> pure PrettifyJsonStep + _ -> fail $ "Unknown PostProcessStep: " ++ show s + + parseJSON (A.Object o) = ReplaceStep + <$> (do + p <- o A..: "pattern" + either (fail . show) return (Pcre.compile copts eopts p)) + <*> o A..: "replacement" + where + copts = Pcre.optionUtf8 <> Pcre.optionMultiline + eopts = mempty + + parseJSON _ = mzero + +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" + <*> parsePostProcess o) <|> + (StderrAssert + <$> o A..: "stderr" + <*> parsePostProcess o) <|> + (CreatedFileAssert + <$> o A..: "created_file" + <*> o A..:? "contents" + <*> parsePostProcess o) <|> + (CreatedDirectoryAssert + <$> o A..: "created_directory") + where + parsePostProcess o = + maybe [] A.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 Verbosity = Debug | Message | Error + deriving (Eq, Ord) + +type Logger = Verbosity -> [String] -> IO () + +makeLogger :: Bool -> IO Logger +makeLogger verbose = do + lock <- MVar.newMVar () + return $ \verbosity msgs -> + unless (not verbose && verbosity == Debug) $ + MVar.withMVar lock $ \() -> mapM_ (IO.hPutStrLn IO.stderr) msgs + +data Execution = Execution + { executionInputFile :: Maybe FilePath + , executionCommand :: FilePath + , executionArguments :: [String] + , executionStdin :: Maybe (A.Multiple String) + , executionAsserts :: [Assert String] + , executionEnv :: SpliceEnv + , executionSpecPath :: FilePath + , executionSpecName :: String + , executionDirectory :: FilePath + } + +specExecutions :: FilePath -> Spec String -> IO [Execution] +specExecutions specPath spec = do + let specBaseName = takeBaseName specPath + specDirectory = takeDirectory specPath + specName = dropExtension specBaseName + + -- Compute initial environment to get input files. + env0 <- getEnvironment + let env1 = + List.nubBy ((==) `on` fst) $ + ("GOLDPLATE_NAME", specName) : + ("GOLDPLATE_FILE", specBaseName) : + sEnv spec ++ env0 + + -- Get a list of concrete input files (a list maybes). + concreteInputFiles <- case sInputFiles spec of + Nothing -> return [Nothing] + Just glob0 -> do + glob <- hoistEither $ splice env1 glob0 + inputFiles <- withCurrentDirectory specDirectory $ do + matches <- globCurrentDir glob + length matches `seq` return matches + return (map (Just . 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", dropExtension inputFile) : + env1 + + -- Return execution after doing some splicing. + hoistEither $ do + spec' <- traverse (splice env2) spec + pure Execution + { executionInputFile = mbInputFile + , executionCommand = sCommand spec' + , executionArguments = sArguments spec' + , executionStdin = sStdin spec' + , executionAsserts = sAsserts spec' + , executionEnv = env2 + , executionSpecPath = specPath + , executionSpecName = specName + , executionDirectory = specDirectory + } + 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 + , envCountAsserts :: !(IORef.IORef Int) + , envCountFailures :: !(IORef.IORef Int) + } + +incrementCount :: IORef.IORef Int -> IO () +incrementCount ref = IORef.atomicModifyIORef' ref (\x -> (x + 1, ())) + +data ExecutionResult = ExecutionResult + { erExitCode :: !ExitCode + , erStdout :: !B.ByteString + , erStderr :: !B.ByteString + } deriving (Show) + +runExecution + :: Env -> Execution -> IO () +runExecution env execution@Execution {..} = do + envLogger env Debug [executionHeader execution ++ "running..."] + + -- Create a "CreateProcess" description. + let createProcess = (Process.proc executionCommand executionArguments) + { Process.env = Just executionEnv + , Process.cwd = Just executionDirectory + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + -- Actually run the process. + envLogger env Debug [executionHeader execution ++ + executionCommand ++ " " ++ unwords executionArguments] + (Just hIn, Just hOut, Just hErr, hProc) <- + Process.createProcess createProcess + + let writeStdin = do + case executionStdin of + Nothing -> pure () + Just (A.Single str) -> IO.hPutStr hIn str + Just (A.Multiple strs) -> mapM_ (IO.hPutStrLn hIn) strs + IO.hClose hIn + 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 + let executionResult = ExecutionResult + { erExitCode = exitCode + , erStdout = actualOut + , erStderr = actualErr + } + + -- Dump stderr/stdout if in debug. + envLogger env Debug [executionHeader execution ++ "finished"] + envLogger env Debug [executionHeader execution ++ "stdout:", show actualOut] + envLogger env Debug [executionHeader execution ++ "stderr:", show actualErr] + + -- Perform checks. + envLogger env Debug [executionHeader execution ++ "checking assertions..."] + forM_ executionAsserts $ runAssert env execution executionResult + envLogger env Debug [executionHeader execution ++ "done"] + + +-- | Check an assertion. +runAssert :: Env -> Execution -> ExecutionResult -> Assert String -> IO () +runAssert env execution@Execution {..} ExecutionResult {..} assert = + case assert of + ExitCodeAssert expectedExitCode -> do + let actualExitCode = case erExitCode of + ExitSuccess -> 0 + ExitFailure c -> c + assertTrue (actualExitCode == expectedExitCode) $ + "expected " ++ show expectedExitCode ++ + " but got " ++ show actualExitCode + + StdoutAssert {..} -> checkAgainstFile + (inExecutionDir stdoutFilePath) stdoutPostProcess erStdout + + StderrAssert {..} -> checkAgainstFile + (inExecutionDir stderrFilePath) stderrPostProcess erStderr + + CreatedFileAssert {..} -> do + let path = inExecutionDir createdFilePath + exists <- doesFileExist path + assertTrue exists $ createdFilePath ++ " was not created" + when exists $ do + case createdFileContents of + Nothing -> return () + Just expectedPath -> do + !actual <- readFileOrEmpty path + checkAgainstFile + (inExecutionDir expectedPath) + createdFilePostProcess actual + removeFile path + envLogger env Debug [executionHeader execution ++ + "removed " ++ createdFilePath] + + CreatedDirectoryAssert {..} -> do + let path = inExecutionDir createdDirectoryPath + exists <- doesDirectoryExist path + assertTrue exists $ createdDirectoryPath ++ " was not created" + when exists $ do + removeDirectoryRecursive path + envLogger env Debug [executionHeader execution ++ + "removed " ++ createdDirectoryPath] + where + inExecutionDir :: FilePath -> FilePath + inExecutionDir fp = if isAbsolute fp then fp else executionDirectory fp + + checkAgainstFile :: FilePath -> PostProcess -> B.ByteString -> IO () + checkAgainstFile expectedPath processor actual0 = do + expected <- readFileOrEmpty expectedPath + let !actual1 = postProcess processor actual0 + assertTrue (actual1 == expected) "does not match" + when (envDiff env && actual1 /= expected) $ do + envLogger env Message + [ executionHeader execution ++ "expected:" + , show expected + , executionHeader execution ++ "actual:" + , show actual1 + ] + let 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 (envPrettyDiff env && actual1 /= expected && not (null diff)) $ do + envLogger env Message + [ executionHeader execution ++ "diff:" + , ppDiff diff + ] + when (envFix env && actual1 /= expected) $ do + B.writeFile expectedPath actual1 + envLogger env Message + [executionHeader execution ++ "fixed " ++ expectedPath] + + assertTrue :: Bool -> String -> IO () + assertTrue test err = do + incrementCount (envCountAsserts env) + if test + then + envLogger env Debug [executionHeader execution ++ + describeAssert assert ++ ": OK"] + else do + envLogger env Error [executionHeader execution ++ + describeAssert assert ++ ": " ++ err] + incrementCount (envCountFailures env) + +readFileOrEmpty :: FilePath -> IO B.ByteString +readFileOrEmpty fp = do + exists <- 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 <- 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 isPathSeparator fp0 of + (".", fp1) -> drop 1 fp1 + _ -> fp0 + + +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 "Be more verbose") + <*> 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 <*> parseOptions) $ + OA.fullDesc <> + OA.header ("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 + startTime <- getCurrentTime + options <- OA.execParser parserInfo + env <- Env + <$> makeLogger (oVerbose options) + <*> pure (oDiff options) + <*> pure (oPrettyDiff options) + <*> pure (oFix options) + <*> IORef.newIORef 0 + <*> IORef.newIORef 0 + + -- 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 + envLogger env Error + [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 + envLogger env Message ["Found " ++ show numSpecs ++ " specs"] + executions <- fmap concat $ forM specs $ + \(specPath, spec) -> specExecutions specPath spec + + -- Create a pool full of executions. + let numExecutions = length executions + numJobs = oJobs options + envLogger env Message ["Running " ++ show numExecutions ++ + " executions in " ++ show numJobs ++ " jobs"] + pool <- IORef.newIORef executions + + -- Spawn a worker to report progress + progress <- Async.async $ forever $ do + threadDelay $ 10 * 1000 * 1000 + remaining <- length <$> IORef.readIORef pool + envLogger env Message $ return $ + "Progress: " ++ show (numExecutions - remaining) ++ "/" ++ + show numExecutions ++ "..." + + -- Spawn some workers to run the executions. + Async.replicateConcurrently_ numJobs $ worker pool (runExecution env) + Async.cancel progress + + -- Tell the time. + endTime <- getCurrentTime + envLogger env Message + ["Finished in " ++ showDiffTime (endTime `diffUTCTime` startTime)] + + -- Report summary. + asserts <- IORef.readIORef (envCountAsserts env) + failures <- IORef.readIORef (envCountFailures env) + if failures == 0 + then + envLogger env Message [ + "Ran " ++ show numSpecs ++ " specs, " ++ + show numExecutions ++ " executions, " ++ + show asserts ++ " asserts, all A-OK!"] + else do + envLogger env Error [ + "Ran " ++ show numSpecs ++ " specs, " ++ + show numExecutions ++ " executions, " ++ + show asserts ++ " asserts, " ++ show failures ++ " failed."] + exitFailure + + +showDiffTime :: NominalDiffTime -> String +showDiffTime dt = printf "%.2fs" (fromRational (toRational dt) :: Double) diff --git a/src/Text/Regex/PCRE/Simple.hs b/src/Text/Regex/PCRE/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Text/Regex/PCRE/Simple.hs @@ -0,0 +1,57 @@ +module Text.Regex.PCRE.Simple + ( CompileOptions + , optionUtf8 + , optionMultiline + + , ExecOptions + + , I.Regex + , compile + , replaceAll + ) where + +import Data.Bifunctor (first, second) +import Data.Bits ((.|.)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import System.IO.Unsafe (unsafePerformIO) +import qualified Text.Regex.PCRE.Text as I + +newtype CompileOptions = CompileOptions I.CompOption + +instance Semigroup CompileOptions where + CompileOptions x <> CompileOptions y = CompileOptions (x .|. y) + +instance Monoid CompileOptions where + mempty = CompileOptions I.compBlank + +optionUtf8 :: CompileOptions +optionUtf8 = CompileOptions I.compUTF8 + +optionMultiline :: CompileOptions +optionMultiline = CompileOptions I.compMultiline + +newtype ExecOptions = ExecOptions I.ExecOption + +instance Semigroup ExecOptions where + ExecOptions x <> ExecOptions y = ExecOptions (x .|. y) + +instance Monoid ExecOptions where + mempty = ExecOptions I.execBlank + +compile :: CompileOptions -> ExecOptions -> T.Text -> Either String I.Regex +compile (CompileOptions compOption) (ExecOptions execOption) = first snd . + unsafePerformIO . I.compile compOption execOption + +replaceAll :: I.Regex -> T.Text -> T.Text -> Either String T.Text +replaceAll regex replacement = + second (TL.toStrict . TLB.toLazyText) . unsafePerformIO . go mempty + where + go acc text = do + match <- I.regexec regex text + case match of + Left err -> pure . Left $ show err + Right Nothing -> pure $ Right acc + Right (Just (pre, _, post, _)) -> + go (acc <> TLB.fromText pre <> TLB.fromText replacement) post