diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,51 @@ +# Changelog + +All notable changes to hurl-workbench are recorded here. + +The format follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and +this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +## [Unreleased] + +## [0.1.0.0] - 2026-11-12 + +### Added + +- Versioned Dhall workspaces with compatible record completion, upward discovery, accumulated + semantic validation, and category-specific names. +- Byte-preserving fragment composition, source-mapped Hurlfmt validation, and inspectable rendering. +- Secure Hurl 8.x execution with separate plain/secret files, filtered ambient configuration, + exact child statuses, and typed Hurl option passthrough. +- Read-only/mutating recipes, bounded matrices, isolated client artifacts, managed services, suite + preflight, and isolated JUnit, HTML, JSON, and TAP reports. +- Revision-aware version output and generated Bash, Zsh, and Fish completions. +- Local vendor-exploration and managed integration-service examples. +- Per-execution UUID4, UUID7, TypeID, UTC timestamp, and alphanumeric generated parameters with + reproducible runtime overrides. +- Caller-owned Hurl file roots for file bodies, validated before subprocess work and protected from + output preparation. +- Ordered multi-service suites with bounded setup/teardown commands and named Stop/Start/Restart + barriers between Hurl batches; compatible old manifests and redacted ordered lifecycle results. +- Executable checks as ordered suite barriers, with workspace-contained executables, Plain argv + templates, bounded process groups, and private captures; checks-only suites with no Hurl cases. +- Process-group cleanup for Hurl and managed commands, including bounded capture cancellation, + plus production Rei/Hinagata command/read and lease-release acceptance drivers. +- Compatible suite isolation declarations, with a shared-state default and early refusal of + parallel mutation or unclassified suite runs; standalone mutating matrices require serial jobs. +- Private versioned per-scenario runtime inputs for caller-owned independent suites, with unique + fixture/origin assignments, channel/conflict validation, and individually resolved bindings. +- Safe isolation/scenario summaries for success, refusal, setup failure, and cancellation, plus + real two-database Hinagata acceptance covering fail-fast and caller-owned cleanup. +- Explicit inherited or clean environment policies for managed service and readiness commands, + with required-name preflight, compatible old manifests, and a caller-owned lease check driver. +- Local CLI/API parity examples and real application acceptance using executable checks. + +### Security + +- Secrets never enter child argv; temporary inputs and output artifacts use owner-only permissions. +- Managed services are cleaned up as POSIX process groups, including on timeout and interruption. + +### Compatibility + +- Hurl and Hurlfmt 8.0 or newer are required. Later major versions are reported as untested by + `doctor` rather than rejected automatically. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2026 Nadeem Bitar + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nadeem Bitar nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,113 @@ +# hurl-workbench + +`hurl-workbench` composes complete Hurl entries into reusable workflows, supplies plain and secret +parameters securely, and executes recipes, matrices, and integration suites through the official +Hurl binary. Suites can manage several services, generate fresh scenario inputs, read caller-owned +body files, and run application-owned executable assertions between Hurl batches. Hurl remains +responsible for HTTP, captures, assertions, cookies, retries, and reports. + +Suites default to shared application state: parallel Hurl runs require ReadOnly recipes, and shared +writes require `--jobs 1 --allow-mutating`. Independent suites validate caller-provisioned +fixture/endpoint assignments through `--scenario-inputs`; the caller establishes actual isolation. +See the [integration guide](docs/guides/integration-testing.md). + +## Five-minute quick start + +Enter the pinned development environment and inspect the interface: + +```bash +nix develop +cabal run hurl-workbench -- --help +cabal run hurl-workbench -- doctor +``` + +The small workspace in [`examples/quick-start/`](examples/quick-start/) defines one `health` +fragment and workflow against the bundled Dhall schema. Its token is a secret parameter sourced +from `QUICKSTART_TOKEN`; no credential is committed. Inspect, validate, and render it: + +```bash +sed -n '1,240p' examples/quick-start/hurl-workbench.dhall +cabal run hurl-workbench -- --workspace examples/quick-start/hurl-workbench.dhall validate +cabal run hurl-workbench -- --workspace examples/quick-start/hurl-workbench.dhall render workflow health +``` + +Start the local fixture API in one terminal: + +```bash +cabal run hurl-workbench-fixture-server -- --port 18080 +``` + +Run the workflow from another terminal with an environment-backed fixture secret: + +```bash +QUICKSTART_TOKEN=fixture-secret cabal run hurl-workbench -- \ + --workspace examples/quick-start/hurl-workbench.dhall \ + test workflow health +``` + +The expected result is a passing Hurl test summary. For full workflows, continue with: + +- [`examples/vendor-odata/`](examples/vendor-odata/) — one OAuth capture reused by OData-shaped + recipes and a bounded matrix, plus bespoke capture and raw-response investigations; +- [`examples/integration-service/`](examples/integration-service/) — managed fixture-service + lifecycle, safe and mutating suites, clean command environments, and isolated reports; +- [`examples/multi-service/`](examples/multi-service/) — ordered stub/API/worker startup, + setup/teardown, and worker restart barriers; +- [`examples/generated-parameters/`](examples/generated-parameters/) — fresh UUID, TypeID, + timestamp, and random inputs with reproducible overrides; +- [`examples/file-body/`](examples/file-body/) — caller-generated UTF-8/CRLF request bodies + passed unchanged through `--file-root`; +- [`examples/executable-checks/`](examples/executable-checks/) — CLI/API parity assertions + between Hurl runs, including a deliberately failing comparison. + +## Core model + +A `hurl-workbench.dhall` manifest imports [`schema/package.dhall`](schema/package.dhall). Fragments +are ordinary `.hurl` files containing one or more complete entries. A workflow names fragments in +order; rendering preserves their bytes and inserts only the line feeds needed between them. +Recipes add committed plain bindings and an explicit safety class. Matrices layer named cases over +a recipe. Suites execute bounded Hurl batches separated by executable checks or named service +Stop/Start/Restart barriers. Services become ready in declaration order and stop in reverse +acquisition order before bounded teardown, including on failure and cancellation. + +Plain, Secret, and Generated parameters have separate binding rules. Generated values resolve +once per prepared Hurl execution; explicit runtime values reproduce a prior run. Use Plain inputs +when setup, checks, and several Hurl runs must share an identity. Command environments can inherit +ambient variables or explicitly select names through `EnvironmentPolicy.Clean`. + +Execution commands accept `--file-root DIR`; suites can also name a Plain `fileRootParameter`. +The caller keeps body files alive until execution ends. Keep report and output trees outside an +explicit body root. A suite with executable checks requires `--report-dir`; captured check output +stays in private files while the summary records named outcomes and relative paths. + +Without `--workspace`, discovery starts at the current directory and walks upward looking for +`hurl-workbench.dhall`. See the [workspace reference](docs/reference/workspace.md), [CLI +reference](docs/reference/cli.md), [architecture](docs/architecture.md), and [security +model](docs/security.md). The [guide index](docs/guides/index.md) maps tasks to examples, and the +[OKF capability catalog](docs/capabilities/index.md) records implemented contracts, evidence, and +limits with stable `CAP-N` handles. These capabilities are currently unreleased and experimental. + +## Development + +The repository contains `hurl-workbench-core` and `hurl-workbench-cli`, targets GHC 9.12.4, and +uses a Nix flake for the complete toolchain. + +```bash +nix develop +just check +``` + +`just check` initializes Cabal's Hackage index, whose solver view is pinned by +`cabal.project`, then runs formatting, builds, tests, local examples, source-distribution +checks, and the Nix flake gate. On a Mac with Apple `container` installed and its system +service running, `just linux-check` runs that same gate in a disposable ARM64 Linux VM. +Local examples include multi-service orchestration, file-body byte preservation, generated-input +overrides, and matching/failing executable checks. Real application and database lease acceptance +uses opt-in caller harnesses documented in the integration guide. + +Release source archives use `bash scripts/build-sdist.sh`; this wrapper preserves executable modes +for the declared check helpers. `just sdist` verifies the unpacked archives and their examples. + +## License + +[BSD-3-Clause](LICENSE) — © 2026 Nadeem Bitar. diff --git a/hurl-workbench-core.cabal b/hurl-workbench-core.cabal new file mode 100644 --- /dev/null +++ b/hurl-workbench-core.cabal @@ -0,0 +1,157 @@ +cabal-version: 3.4 +name: hurl-workbench-core +version: 0.1.0.0 +synopsis: Core library for composing and executing reusable Hurl API workflows +description: + A Haskell-powered Hurl workbench for composing, exploring, executing, and + testing reusable API workflows without duplicating request templates. + . + This library provides the engine behind the @hurl-workbench@ command: typed, + versioned Dhall workspaces; byte-preserving Hurl fragment composition with + source-mapped validation; secure Hurl 8.x execution that keeps secrets out + of child argv; read-only and mutating recipes; bounded matrices; managed + services cleaned up as POSIX process groups; and ordered integration suites + with executable checks and isolated JUnit, HTML, JSON, and TAP reports. + +category: Web, Testing +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: (c) 2026 Nadeem Bitar +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +extra-source-files: + schema/*.dhall + test/fixtures/processes/*.c + test/fixtures/workspaces/**/*.dhall + test/fixtures/workspaces/**/*.hurl + test/fixtures/workspaces/**/*.txt + +common common-options + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields + -Wmissing-deriving-strategies + + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + +library + import: common-options + hs-source-dirs: src + exposed-modules: + HurlWorkbench.Check.Resolve + HurlWorkbench.Check.Run + HurlWorkbench.Hurl.Capabilities + HurlWorkbench.Hurl.Format + HurlWorkbench.Hurl.Run + HurlWorkbench.Parameter.Generate + HurlWorkbench.Parameter.Properties + HurlWorkbench.Parameter.Resolve + HurlWorkbench.Prelude + HurlWorkbench.Run.Artifact + HurlWorkbench.Run.Batch + HurlWorkbench.Run.FileRoot + HurlWorkbench.Run.Prepare + HurlWorkbench.Run.Selection + HurlWorkbench.Service.Environment + HurlWorkbench.Service.Group + HurlWorkbench.Service.Resolve + HurlWorkbench.Service.Run + HurlWorkbench.Suite.Isolation + HurlWorkbench.Suite.Resolve + HurlWorkbench.Suite.Run + HurlWorkbench.Suite.Scenario + HurlWorkbench.Workflow.Render + HurlWorkbench.Workflow.Resolve + HurlWorkbench.Workspace.Context + HurlWorkbench.Workspace.Decode + HurlWorkbench.Workspace.Discover + HurlWorkbench.Workspace.Error + HurlWorkbench.Workspace.Types + HurlWorkbench.Workspace.Validate + + other-modules: + HurlWorkbench.Check.Template + HurlWorkbench.Parameter.Resolve.Internal + HurlWorkbench.Process.Run + HurlWorkbench.Workspace.Context.Internal + + build-depends: + aeson >=2.2.5.1 && <2.3, + async ^>=2.2.6, + base >=4.20 && <5, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.8, + dhall ^>=1.42, + directory ^>=1.3, + filepath >=1.4 && <1.6, + generic-lens ^>=2.3, + http-client ^>=0.7.19, + http-types >=0.12 && <0.13, + lens ^>=5.3, + process >=1.6.3 && <1.7, + stm >=2.5 && <2.6, + temporary ^>=1.3, + text ^>=2.1, + time >=1.14 && <1.17, + typed-process ^>=0.2.13, + unix >=2.8.8 && <2.9, + +test-suite hurl-workbench-core-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + HurlWorkbench.Check.RunTest + HurlWorkbench.Hurl.RunTest + HurlWorkbench.Parameter.GenerateTest + HurlWorkbench.Parameter.ParameterTest + HurlWorkbench.Run.FileRootTest + HurlWorkbench.Run.SelectionTest + HurlWorkbench.Service.RunTest + HurlWorkbench.Suite.LifecycleTest + HurlWorkbench.Suite.RunTest + HurlWorkbench.Suite.ScenarioTest + HurlWorkbench.Workflow.WorkflowTest + HurlWorkbench.Workspace.NameSafetyTest + HurlWorkbench.Workspace.WorkspaceTest + + ghc-options: + -threaded + + build-depends: + aeson >=2.2.5.1 && <2.3, + async, + base >=4.20 && <5, + bytestring, + containers, + directory, + filepath, + generic-lens, + hurl-workbench-core, + lens, + stm, + tasty ^>=1.5, + tasty-hunit ^>=0.10, + temporary ^>=1.3, + text, + time >=1.14 && <1.17, + typed-process, + unix, diff --git a/schema/Binding.dhall b/schema/Binding.dhall new file mode 100644 --- /dev/null +++ b/schema/Binding.dhall @@ -0,0 +1,2 @@ +{- A plain value bound to a parameter declared by the selected workflow. -} +{ Type = { parameter : Text, value : Text }, default = {=} } diff --git a/schema/Check.dhall b/schema/Check.dhall new file mode 100644 --- /dev/null +++ b/schema/Check.dhall @@ -0,0 +1,16 @@ +{- A single application-owned executable assertion, run as a suite barrier. -} +let CommandSpec = ./CommandSpec.dhall + +in { Type = + { name : Text + , command : CommandSpec.Type + , expectedStatus : Natural + , timeoutSeconds : Optional Natural + , description : Optional Text + } + , default = + { expectedStatus = 0 + , timeoutSeconds = None Natural + , description = None Text + } + } diff --git a/schema/CommandReadiness.dhall b/schema/CommandReadiness.dhall new file mode 100644 --- /dev/null +++ b/schema/CommandReadiness.dhall @@ -0,0 +1,10 @@ +{- Run `command` until it exits successfully. -} +let CommandSpec = ./CommandSpec.dhall + +in { Type = + { command : CommandSpec.Type + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + , default = { intervalMilliseconds = 500, timeoutSeconds = 30 } + } diff --git a/schema/CommandSpec.dhall b/schema/CommandSpec.dhall new file mode 100644 --- /dev/null +++ b/schema/CommandSpec.dhall @@ -0,0 +1,21 @@ +{- A process invocation as an executable plus argv; there is no shell-string form. + `workingDirectory` is relative to the workspace root. +-} +let EnvironmentBinding = ./EnvironmentBinding.dhall + +let EnvironmentPolicy = ./EnvironmentPolicy.dhall + +in { Type = + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environmentPolicy : EnvironmentPolicy + , environment : List EnvironmentBinding.Type + } + , default = + { arguments = [] : List Text + , workingDirectory = None Text + , environmentPolicy = EnvironmentPolicy.Inherit + , environment = [] : List EnvironmentBinding.Type + } + } diff --git a/schema/EnvironmentBinding.dhall b/schema/EnvironmentBinding.dhall new file mode 100644 --- /dev/null +++ b/schema/EnvironmentBinding.dhall @@ -0,0 +1,2 @@ +{- Export the workspace parameter `parameter` to a child process as `variable`. -} +{ Type = { variable : Text, parameter : Text }, default = {=} } diff --git a/schema/EnvironmentPolicy.dhall b/schema/EnvironmentPolicy.dhall new file mode 100644 --- /dev/null +++ b/schema/EnvironmentPolicy.dhall @@ -0,0 +1,1 @@ +< Inherit | Clean : List Text > diff --git a/schema/Fragment.dhall b/schema/Fragment.dhall new file mode 100644 --- /dev/null +++ b/schema/Fragment.dhall @@ -0,0 +1,6 @@ +{- A file of one or more complete Hurl entries. + `path` is relative to the directory containing `hurl-workbench.dhall`. +-} +{ Type = { name : Text, path : Text, description : Optional Text } +, default.description = None Text +} diff --git a/schema/Generator.dhall b/schema/Generator.dhall new file mode 100644 --- /dev/null +++ b/schema/Generator.dhall @@ -0,0 +1,1 @@ +< Uuid4 | Uuid7 | TypeId : { prefix : Text } | Rfc3339Now | RandomAlphanumeric : { length : Natural } > diff --git a/schema/HttpReadiness.dhall b/schema/HttpReadiness.dhall new file mode 100644 --- /dev/null +++ b/schema/HttpReadiness.dhall @@ -0,0 +1,9 @@ +{- Poll `url` until it answers with `expectedStatus`. -} +{ Type = + { url : Text + , expectedStatus : Natural + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } +, default = { expectedStatus = 200, intervalMilliseconds = 500, timeoutSeconds = 30 } +} diff --git a/schema/IsolationPolicy.dhall b/schema/IsolationPolicy.dhall new file mode 100644 --- /dev/null +++ b/schema/IsolationPolicy.dhall @@ -0,0 +1,2 @@ +{- Whether expanded scenarios share application state. -} +< SharedState | IndependentState > diff --git a/schema/Matrix.dhall b/schema/Matrix.dhall new file mode 100644 --- /dev/null +++ b/schema/Matrix.dhall @@ -0,0 +1,12 @@ +{- A recipe applied to a non-empty list of uniquely named cases. -} +let MatrixCase = ./MatrixCase.dhall + +in { Type = + { name : Text + , recipe : Text + , cases : List MatrixCase.Type + , failFast : Bool + , description : Optional Text + } + , default = { failFast = False, description = None Text } + } diff --git a/schema/MatrixCase.dhall b/schema/MatrixCase.dhall new file mode 100644 --- /dev/null +++ b/schema/MatrixCase.dhall @@ -0,0 +1,6 @@ +{- One named set of bindings layered over a matrix's recipe. -} +let Binding = ./Binding.dhall + +in { Type = { name : Text, bindings : List Binding.Type } + , default.bindings = [] : List Binding.Type + } diff --git a/schema/Parameter.dhall b/schema/Parameter.dhall new file mode 100644 --- /dev/null +++ b/schema/Parameter.dhall @@ -0,0 +1,21 @@ +{- An externally injected Hurl variable. + + `defaultValue` is a committed plain value and is rejected for secrets. + `environment` names an environment variable that supplies the value at run time. +-} +let ParameterKind = ./ParameterKind.dhall + +in { Type = + { name : Text + , description : Optional Text + , kind : ParameterKind + , defaultValue : Optional Text + , environment : Optional Text + } + , default = + { description = None Text + , kind = ParameterKind.Plain + , defaultValue = None Text + , environment = None Text + } + } diff --git a/schema/ParameterKind.dhall b/schema/ParameterKind.dhall new file mode 100644 --- /dev/null +++ b/schema/ParameterKind.dhall @@ -0,0 +1,2 @@ +let Generator = ./Generator.dhall +in < Plain | Secret | Generated : Generator > diff --git a/schema/Readiness.dhall b/schema/Readiness.dhall new file mode 100644 --- /dev/null +++ b/schema/Readiness.dhall @@ -0,0 +1,6 @@ +{- How to decide that a service is ready, for example + `Schema.Readiness.Http Schema.HttpReadiness::{ url = "http://127.0.0.1:8080/health" }`. +-} +< Http : (./HttpReadiness.dhall).Type +| Command : (./CommandReadiness.dhall).Type +> diff --git a/schema/Recipe.dhall b/schema/Recipe.dhall new file mode 100644 --- /dev/null +++ b/schema/Recipe.dhall @@ -0,0 +1,16 @@ +{- A workflow plus committed plain bindings and an explicit safety class. + `safety` has no default so that a mutating recipe is never silently read-only. +-} +let Binding = ./Binding.dhall + +let Safety = ./Safety.dhall + +in { Type = + { name : Text + , workflow : Text + , bindings : List Binding.Type + , safety : Safety + , description : Optional Text + } + , default = { bindings = [] : List Binding.Type, description = None Text } + } diff --git a/schema/RunReference.dhall b/schema/RunReference.dhall new file mode 100644 --- /dev/null +++ b/schema/RunReference.dhall @@ -0,0 +1,4 @@ +{- Hurl runs and named service lifecycle barriers. -} +let ServiceStep = ./ServiceStep.dhall + +in < Workflow : Text | Recipe : Text | Matrix : Text | Check : Text | Service : ServiceStep > diff --git a/schema/Safety.dhall b/schema/Safety.dhall new file mode 100644 --- /dev/null +++ b/schema/Safety.dhall @@ -0,0 +1,4 @@ +{- Whether running a recipe may change remote state. + `Mutating` recipes only run when explicitly allowed at execution time. +-} +< ReadOnly | Mutating > diff --git a/schema/Service.dhall b/schema/Service.dhall new file mode 100644 --- /dev/null +++ b/schema/Service.dhall @@ -0,0 +1,14 @@ +{- A managed process that suites can start, wait for, and stop. -} +let CommandSpec = ./CommandSpec.dhall + +let Readiness = ./Readiness.dhall + +in { Type = + { name : Text + , command : CommandSpec.Type + , readiness : Readiness + , shutdownTimeoutSeconds : Natural + , description : Optional Text + } + , default = { shutdownTimeoutSeconds = 10, description = None Text } + } diff --git a/schema/ServiceStep.dhall b/schema/ServiceStep.dhall new file mode 100644 --- /dev/null +++ b/schema/ServiceStep.dhall @@ -0,0 +1,2 @@ +{- An ordered lifecycle barrier for a service belonging to this suite. -} +< Stop : Text | Start : Text | Restart : Text > diff --git a/schema/Suite.dhall b/schema/Suite.dhall new file mode 100644 --- /dev/null +++ b/schema/Suite.dhall @@ -0,0 +1,34 @@ +{- A non-empty collection of runs, optionally against a managed service. -} +let RunReference = ./RunReference.dhall + +let CommandSpec = ./CommandSpec.dhall + +let IsolationPolicy = ./IsolationPolicy.dhall + +in { Type = + { name : Text + , runs : List RunReference + , fileRootParameter : Optional Text + , service : Optional Text + , services : List Text + , setup : List CommandSpec.Type + , teardown : List CommandSpec.Type + , commandTimeoutSeconds : Natural + , cleanupTimeoutSeconds : Natural + , isolation : IsolationPolicy + , failFast : Bool + , description : Optional Text + } + , default = + { fileRootParameter = None Text + , service = None Text + , services = [] : List Text + , setup = [] : List CommandSpec.Type + , teardown = [] : List CommandSpec.Type + , commandTimeoutSeconds = 60 + , cleanupTimeoutSeconds = 30 + , isolation = IsolationPolicy.SharedState + , failFast = False + , description = None Text + } + } diff --git a/schema/Workflow.dhall b/schema/Workflow.dhall new file mode 100644 --- /dev/null +++ b/schema/Workflow.dhall @@ -0,0 +1,9 @@ +{- An ordered, non-empty list of fragment names and the parameters they consume. -} +{ Type = + { name : Text + , fragments : List Text + , parameters : List Text + , description : Optional Text + } +, default = { parameters = [] : List Text, description = None Text } +} diff --git a/schema/Workspace.dhall b/schema/Workspace.dhall new file mode 100644 --- /dev/null +++ b/schema/Workspace.dhall @@ -0,0 +1,44 @@ +{- The top-level value of `hurl-workbench.dhall`. + + `schemaVersion` is required and has no default: a manifest states the schema + version it was written for, and the workbench rejects versions it does not know. + Every list defaults to empty so new categories never break existing manifests. +-} +let Parameter = ./Parameter.dhall + +let Fragment = ./Fragment.dhall + +let Workflow = ./Workflow.dhall + +let Recipe = ./Recipe.dhall + +let Matrix = ./Matrix.dhall + +let Check = ./Check.dhall + +let Service = ./Service.dhall + +let Suite = ./Suite.dhall + +in { Type = + { schemaVersion : Natural + , parameters : List Parameter.Type + , fragments : List Fragment.Type + , workflows : List Workflow.Type + , recipes : List Recipe.Type + , matrices : List Matrix.Type + , checks : List Check.Type + , services : List Service.Type + , suites : List Suite.Type + } + , default = + { parameters = [] : List Parameter.Type + , fragments = [] : List Fragment.Type + , workflows = [] : List Workflow.Type + , recipes = [] : List Recipe.Type + , matrices = [] : List Matrix.Type + , checks = [] : List Check.Type + , services = [] : List Service.Type + , suites = [] : List Suite.Type + } + } diff --git a/schema/package.dhall b/schema/package.dhall new file mode 100644 --- /dev/null +++ b/schema/package.dhall @@ -0,0 +1,36 @@ +{- The hurl-workbench workspace schema, version 1. + + Import it by relative path from a workspace manifest: + + let Schema = ../schema/package.dhall + in Schema.Workspace::{ schemaVersion = Schema.schemaVersion, ... } + + Record modules expose `Type` and `default` for record completion (`::`). + Union modules (`ParameterKind`, `Safety`, `Readiness`, `RunReference`) are the + union types themselves. +-} +{ schemaVersion = 1 +, Workspace = ./Workspace.dhall +, Parameter = ./Parameter.dhall +, Generator = ./Generator.dhall +, ParameterKind = ./ParameterKind.dhall +, Fragment = ./Fragment.dhall +, Workflow = ./Workflow.dhall +, Binding = ./Binding.dhall +, Safety = ./Safety.dhall +, Recipe = ./Recipe.dhall +, MatrixCase = ./MatrixCase.dhall +, Matrix = ./Matrix.dhall +, EnvironmentBinding = ./EnvironmentBinding.dhall +, EnvironmentPolicy = ./EnvironmentPolicy.dhall +, CommandSpec = ./CommandSpec.dhall +, HttpReadiness = ./HttpReadiness.dhall +, CommandReadiness = ./CommandReadiness.dhall +, Readiness = ./Readiness.dhall +, Check = ./Check.dhall +, Service = ./Service.dhall +, ServiceStep = ./ServiceStep.dhall +, RunReference = ./RunReference.dhall +, IsolationPolicy = ./IsolationPolicy.dhall +, Suite = ./Suite.dhall +} diff --git a/src/HurlWorkbench/Check/Resolve.hs b/src/HurlWorkbench/Check/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Check/Resolve.hs @@ -0,0 +1,54 @@ +-- | Suite-wide inputs only; argv templates never accept Secret or Generated. +module HurlWorkbench.Check.Resolve (ResolvedCheck (..), CheckResolutionError (..), prepareCheck, renderCheckResolutionError) where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime) +import HurlWorkbench.Check.Template +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Service.Resolve +import HurlWorkbench.Service.Run (prepareCommand) +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types + +-- The command's Show instance redacts all resolved values. +data ResolvedCheck = ResolvedCheck + { name :: !CheckName, + processConfig :: !ResolvedCommand, + expectedStatus :: !Int, + timeout :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + +data CheckResolutionError = CheckBindingFailed !BindingError | CheckCommandFailed !ServiceError | CheckTemplateInvalid | CheckDefinitionMissing + deriving stock (Generic, Eq, Show) + +prepareCheck :: [(String, String)] -> ValidatedWorkspace -> BindingInput -> CheckName -> IO (Either CheckResolutionError ResolvedCheck) +prepareCheck ambient workspace input name = case (lookupCheck name workspace, lookupCheckExecutable name workspace) of + (Just check, Just executable) -> case traverse parseTemplate (check ^. #command . #arguments) of + Left _ -> pure (Left CheckTemplateInvalid) + Right templates -> do + let required = Set.fromList ([p | templateParts <- templates, Placeholder p <- templateParts] <> map (view #parameter) (check ^. #command . #environment)) + resolveParameterSubsetInEnvironment ambient workspace required input <&> \case + Left err -> Left (CheckBindingFailed err) + Right bindings -> do + let render (Literal value) = Right value + render (Placeholder parameter) = case lookupParameter parameter workspace of + Just definition | definition ^. #kind == Plain -> maybe (Left CheckTemplateInvalid) (Right . hurlValueLiteralText) (Map.lookup parameter (bindings ^. #variables)) + _ -> Left CheckTemplateInvalid + arguments <- traverse (fmap Text.unpack . fmap Text.concat . traverse render) templates + command <- either (Left . CheckCommandFailed) Right (resolveCommand workspace bindings (check ^. #command)) + frozen <- either (Left . CheckCommandFailed) Right (prepareCommand ambient (ServiceName (unCheckName name)) "check" (command & #executable .~ executable & #arguments .~ arguments)) + pure (ResolvedCheck name frozen (fromIntegral (check ^. #expectedStatus)) (maybe 60 fromIntegral (check ^. #timeoutSeconds))) + _ -> pure (Left CheckDefinitionMissing) + +renderCheckResolutionError :: CheckResolutionError -> Text +renderCheckResolutionError = \case + CheckBindingFailed err -> renderBindingError err + CheckCommandFailed (ServiceEnvironmentMissing _ _ names) -> "check requires missing environment variables: " <> Text.intercalate ", " names + CheckCommandFailed _ -> "check command preparation failed" + CheckTemplateInvalid -> "invalid check argument template" + CheckDefinitionMissing -> "check definition unavailable" diff --git a/src/HurlWorkbench/Check/Run.hs b/src/HurlWorkbench/Check/Run.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Check/Run.hs @@ -0,0 +1,148 @@ +-- | One execution with file captures and bounded process-group cleanup. +module HurlWorkbench.Check.Run + ( CheckOutcome (..), + CheckResult (..), + runCheck, + runCheckObserved, + runCheckObservedWith, + checkPassed, + checkExitCode, + checkStatus, + skippedCheck, + ) +where + +import Control.Applicative ((<|>)) +import Control.Concurrent.Async (async, wait) +import Control.Exception (IOException, SomeException, mask, throwIO, try, uninterruptibleMask_) +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) +import HurlWorkbench.Check.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Process.Run +import HurlWorkbench.Service.Resolve (ServiceError) +import HurlWorkbench.Workspace.Types (CheckName (..), ServiceName (..)) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO (hClose) +import System.Posix.Files (ownerReadMode, ownerWriteMode, setFileMode, unionFileModes) +import System.Posix.IO (OpenFileFlags (..), OpenMode (WriteOnly), defaultFileFlags, fdToHandle, openFd) +import System.Process qualified as Process +import System.Timeout qualified as Timeout + +data CheckOutcome = CheckPassed | CheckMismatch | CheckTimedOut | CheckSignalled | CheckCancelled | CheckStartFailed | CheckSkipped !Text + deriving stock (Generic, Eq, Show) + +data CheckResult = CheckResult + { name :: !CheckName, + outcome :: !CheckOutcome, + expectedStatus :: !Int, + actualStatus :: !(Maybe Int), + elapsed :: !(Maybe NominalDiffTime), + stdoutPath :: !(Maybe FilePath), + stderrPath :: !(Maybe FilePath), + cleanupDiagnostics :: ![Text] + } + deriving stock (Generic, Eq, Show) + +-- | Paths are suite-relative; no output, argv, environments or exception text. +skippedCheck :: Text -> ResolvedCheck -> CheckResult +skippedCheck reason check = CheckResult (check ^. #name) (CheckSkipped reason) (check ^. #expectedStatus) Nothing Nothing Nothing Nothing [] + +checkPassed :: CheckResult -> Bool +checkPassed result = result ^. #outcome == CheckPassed && null (result ^. #cleanupDiagnostics) + +checkStatus :: CheckResult -> Text +checkStatus result = case result ^. #outcome of + CheckPassed | not (null (result ^. #cleanupDiagnostics)) -> "cleanup-failed" + CheckPassed -> "passed" + CheckMismatch -> "failed" + CheckTimedOut -> "timed-out" + CheckSignalled -> "signalled" + CheckCancelled -> "cancelled" + CheckStartFailed -> "start-failed" + CheckSkipped reason -> reason + +checkExitCode :: CheckResult -> ExitCode +checkExitCode result = case result ^. #outcome of + CheckPassed -> if null (result ^. #cleanupDiagnostics) then ExitSuccess else ExitFailure 3 + CheckMismatch -> ExitFailure (max 1 (fromMaybe 1 (result ^. #actualStatus))) + CheckTimedOut -> ExitFailure 124 + CheckSignalled -> ExitFailure (128 + abs (fromMaybe 0 (result ^. #actualStatus))) + CheckCancelled -> ExitFailure 130 + CheckStartFailed -> ExitFailure 3 + CheckSkipped _ -> ExitSuccess + +runCheck :: FilePath -> ResolvedCheck -> IO CheckResult +runCheck root check = runCheckObserved root check (const (pure ())) + +runCheckObserved :: FilePath -> ResolvedCheck -> (CheckResult -> IO ()) -> IO CheckResult +runCheckObserved root check = runCheckObservedWith (terminateGroup (ServiceName (unCheckName (check ^. #name))) 10) root check + +-- | The cleanup action is injectable for fault tests. Production always uses +-- the common ten-second TERM/KILL/reap policy, also after normal leader exit. +runCheckObservedWith :: (OwnedProcess -> IO (Either ServiceError ())) -> FilePath -> ResolvedCheck -> (CheckResult -> IO ()) -> IO CheckResult +runCheckObservedWith cleanup root check observe = mask $ \restore -> do + began <- getCurrentTime + let relative = "checks" unpackName (check ^. #name) + out = relative "stdout" + err = relative "stderr" + initial = (skippedCheck "cancelled" check) {outcome = CheckCancelled} + finish outcome actual diagnostics artifacts = do + ended <- getCurrentTime + let result = initial {outcome, actualStatus = actual, elapsed = Just (diffUTCTime ended began), stdoutPath = if artifacts then Just out else Nothing, stderrPath = if artifacts then Just err else Nothing, cleanupDiagnostics = diagnostics} + observe result + pure result + -- O_EXCL creates 0600 files atomically and refuses a replaced capture path. + allocated <- try @IOException $ do + stdout <- capture (root out) + stderr <- capture (root err) `onIoFailure` hClose stdout + pure (stdout, stderr) + case allocated of + Left _ -> finish CheckStartFailed Nothing [] False + Right (stdout, stderr) -> do + let close = hClose stdout >> hClose stderr + spawnBegan <- getCurrentTime + started <- spawnGroup (ServiceName (unCheckName (check ^. #name))) (commandConfig (check ^. #processConfig)) {Process.std_out = Process.UseHandle stdout, Process.std_err = Process.UseHandle stderr} + case started of + Left _ -> close >> finish CheckStartFailed Nothing [] True + Right owned -> do + now <- getCurrentTime + let remaining = floor (((check ^. #timeout) - diffUTCTime now spawnBegan) * 1000000) + executed <- try @SomeException (restore (if remaining <= 0 then pure Nothing else Timeout.timeout remaining (waitExitCode owned))) + -- Cancellation can arrive after leader exit while TERM grace is + -- running. Join the independently bounded cleanup task before allowing + -- that exception to propagate; do not cancel the cleanup itself. + cleaning <- async (try @SomeException (cleanup owned)) + joined <- try @SomeException (wait cleaning) + (cleaned, interrupted) <- case joined of + Right result -> pure (result, Nothing) + Left exception -> (,Just exception) <$> uninterruptibleMask_ (wait cleaning) + closed <- try @IOException close + let diagnostics = (case cleaned of Right (Right ()) -> []; _ -> ["process-group-cleanup-failed"]) <> ["capture-close-failed" | Left _ <- [closed]] + exception = either Just (const Nothing) executed <|> interrupted + case exception of + Just exception_ -> do + _ <- finish CheckCancelled Nothing diagnostics True + throwIO exception_ + Nothing -> case executed of + Left exception_ -> throwIO exception_ + Right Nothing -> finish CheckTimedOut Nothing diagnostics True + Right (Just status) -> + let actual = case status of ExitSuccess -> 0; ExitFailure code -> code + outcome + | actual < 0 = CheckSignalled + | actual == check ^. #expectedStatus = CheckPassed + | otherwise = CheckMismatch + in finish outcome (Just actual) diagnostics True + where + unpackName = Text.unpack . unCheckName + capture path = do + fd <- openFd path WriteOnly defaultFileFlags {creat = Just (ownerReadMode `unionFileModes` ownerWriteMode), exclusive = True, nofollow = True} + handle <- fdToHandle fd + setFileMode path (ownerReadMode `unionFileModes` ownerWriteMode) + pure handle + onIoFailure action cleanupAction = do + result <- try @IOException action + case result of Left exception -> cleanupAction >> throwIO exception; Right value -> pure value diff --git a/src/HurlWorkbench/Check/Template.hs b/src/HurlWorkbench/Check/Template.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Check/Template.hs @@ -0,0 +1,23 @@ +-- | Exact {{parameter}} placeholders. Substitution preserves argv boundaries. +module HurlWorkbench.Check.Template (TemplatePart (..), parseTemplate) where + +import Data.Text qualified as Text +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Types (ParameterName (..)) + +data TemplatePart = Literal !Text | Placeholder !ParameterName + deriving stock (Eq, Show) + +parseTemplate :: Text -> Either Text [TemplatePart] +parseTemplate = go + where + go remaining = case Text.breakOn "{{" remaining of + (prefix, rest) + | "}}" `Text.isInfixOf` prefix -> malformed + | Text.null rest -> Right [Literal prefix] + | otherwise -> + let (name, close) = Text.breakOn "}}" (Text.drop 2 rest) + in if Text.null close || Text.null name || Text.any (`elem` ['{', '}']) name + then malformed + else (Literal prefix :) . (Placeholder (ParameterName name) :) <$> go (Text.drop 2 close) + malformed = Left "malformed parameter placeholder" diff --git a/src/HurlWorkbench/Hurl/Capabilities.hs b/src/HurlWorkbench/Hurl/Capabilities.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Hurl/Capabilities.hs @@ -0,0 +1,63 @@ +-- | Detection of the external Hurl toolchain used by execution commands. +module HurlWorkbench.Hurl.Capabilities + ( HurlCapabilities (..), + detectHurlCapabilities, + parseHurlVersion, + hurlCapabilityWarnings, + ) +where + +import Control.Exception (IOException, displayException, try) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Text.Encoding.Error (lenientDecode) +import Data.Version (Version, makeVersion, versionBranch) +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Prelude +import System.Directory (findExecutable) +import System.Exit (ExitCode (..)) +import System.Process.Typed (proc, readProcess) + +data HurlCapabilities = HurlCapabilities + { hurlExecutable :: !FilePath, + hurlVersion :: !Version, + hurlfmt :: !HurlfmtCapabilities + } + deriving stock (Generic, Eq, Show) + +detectHurlCapabilities :: IO (Either DependencyError HurlCapabilities) +detectHurlCapabilities = do + located <- findExecutable "hurl" + case located of + Nothing -> pure (Left (DependencyNotFound "hurl" "hurl")) + Just executable -> do + probed <- try @IOException (readProcess (proc executable ["--version"])) + case probed of + Left err -> pure (Left (DependencyNotFound "hurl" (executable <> ": " <> displayException err))) + Right (exitCode, stdout, stderr) + | exitCode /= ExitSuccess -> pure (Left (DependencyProbeFailed "hurl" exitCode (decodeOutput stderr))) + | otherwise -> case parseHurlVersion (decodeOutput stdout) of + Nothing -> pure (Left (DependencyVersionUnrecognized "hurl" (decodeOutput stdout))) + Just version + | version < makeVersion [8, 0, 0] -> pure (Left (DependencyVersionUnsupported "hurl" version (makeVersion [8, 0, 0]))) + | otherwise -> + detectHurlfmtCapabilities <&> fmap (HurlCapabilities executable version) + +parseHurlVersion :: Text -> Maybe Version +parseHurlVersion = parseHurlfmtVersion + +hurlCapabilityWarnings :: HurlCapabilities -> [Text] +hurlCapabilityWarnings capabilities = + [ "warning: Hurl major version " + <> Text.pack (show major) + <> " is newer than the tested Hurl 8.x adapter" + | let major = case versionBranch (capabilities ^. #hurlVersion) of + value : _ -> value + [] -> 0, + major > 8 + ] + +decodeOutput :: LazyByteString.ByteString -> Text +decodeOutput = Text.Encoding.decodeUtf8With lenientDecode . LazyByteString.toStrict diff --git a/src/HurlWorkbench/Hurl/Format.hs b/src/HurlWorkbench/Hurl/Format.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Hurl/Format.hs @@ -0,0 +1,241 @@ +-- | Hurlfmt capability detection and syntax validation. Hurlfmt remains the +-- parser oracle; this module does not interpret Hurl grammar. +module HurlWorkbench.Hurl.Format + ( HurlfmtExecutable (..), + HurlfmtCapabilities (..), + DependencyError (..), + HurlfmtError (..), + WorkflowSyntaxError (..), + detectHurlfmtCapabilities, + parseHurlfmtVersion, + validateRenderedWorkflow, + validateWorkspaceSyntax, + renderDependencyError, + renderHurlfmtError, + renderWorkflowSyntaxError, + ) +where + +import Control.Exception (IOException, displayException, try) +import Data.ByteString qualified as ByteString +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Char (isDigit) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Text.Encoding.Error (lenientDecode) +import Data.Version (Version, makeVersion) +import HurlWorkbench.Prelude +import HurlWorkbench.Workflow.Render +import HurlWorkbench.Workflow.Resolve +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import System.Directory (findExecutable) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process.Typed (proc, readProcess) +import Text.Read (readMaybe) + +newtype HurlfmtExecutable = HurlfmtExecutable {unHurlfmtExecutable :: FilePath} + deriving stock (Generic, Eq, Ord, Show) + +data HurlfmtCapabilities = HurlfmtCapabilities + { executable :: !HurlfmtExecutable, + version :: !Version + } + deriving stock (Generic, Eq, Show) + +data DependencyError + = DependencyNotFound !Text !FilePath + | DependencyProbeFailed !Text !ExitCode !Text + | DependencyVersionUnrecognized !Text !Text + | DependencyVersionUnsupported !Text !Version !Version + deriving stock (Generic, Eq, Show) + +data HurlfmtError + = HurlfmtNotFound !FilePath + | InvalidHurl !WorkflowName !(Maybe RenderedFragmentSpan) !Text + | HurlfmtFailed !ExitCode !Text + deriving stock (Generic, Eq, Show) + +data WorkflowSyntaxError + = SyntaxResolutionFailed !WorkflowError + | SyntaxRenderFailed !WorkflowName !RenderError + | SyntaxFormatFailed !HurlfmtError + deriving stock (Generic, Eq, Show) + +detectHurlfmtCapabilities :: IO (Either DependencyError HurlfmtCapabilities) +detectHurlfmtCapabilities = do + located <- findExecutable "hurlfmt" + case located of + Nothing -> pure (Left (DependencyNotFound "hurlfmt" "hurlfmt")) + Just path -> do + probe <- try (readProcess (proc path ["--version"])) + pure $ case probe of + Left (err :: IOException) -> Left (DependencyNotFound "hurlfmt" (path <> ": " <> displayException err)) + Right (exitCode, stdout, stderr) + | exitCode /= ExitSuccess -> + Left (DependencyProbeFailed "hurlfmt" exitCode (decodeOutput stderr)) + | otherwise -> case parseHurlfmtVersion (decodeOutput stdout) of + Nothing -> Left (DependencyVersionUnrecognized "hurlfmt" (decodeOutput stdout)) + Just detected -> + Right + HurlfmtCapabilities + { executable = HurlfmtExecutable path, + version = detected + } + +parseHurlfmtVersion :: Text -> Maybe Version +parseHurlfmtVersion output = + makeVersion <$> firstJust (map parseCandidate (Text.words output)) + where + parseCandidate token = + let candidate = Text.takeWhile (\c -> isDigit c || c == '.') (Text.dropWhile (not . isDigit) token) + components = Text.splitOn "." candidate + in if null components || any Text.null components + then Nothing + else traverse (readMaybe . Text.unpack) components + + firstJust = \case + [] -> Nothing + Nothing : remaining -> firstJust remaining + Just value : _ -> Just value + +validateRenderedWorkflow :: HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ()) +validateRenderedWorkflow capabilities rendered = + withSystemTempDirectory "hurl-workbench-hurlfmt" $ \directory -> do + let temporaryFile = directory "workflow.hurl" + HurlfmtExecutable executablePath = capabilities ^. #executable + writeResult <- try (ByteString.writeFile temporaryFile (Text.Encoding.encodeUtf8 (rendered ^. #contents))) + case writeResult of + Left (err :: IOException) -> + pure (Left (HurlfmtFailed (ExitFailure 1) (Text.pack (displayException err)))) + Right () -> do + processResult <- + try + ( readProcess + (proc executablePath ["--no-color", "--out", "json", temporaryFile]) + ) + pure $ case processResult of + Left (_err :: IOException) -> Left (HurlfmtNotFound executablePath) + Right (ExitSuccess, _stdout, _stderr) -> Right () + Right (exitCode, _stdout, stderr) -> + let diagnostics = decodeOutput stderr + in case diagnosticLine diagnostics of + Just line -> + Left + ( InvalidHurl + (rendered ^. #workflowName) + (spanForLine line (rendered ^. #fragmentSpans)) + diagnostics + ) + Nothing -> Left (HurlfmtFailed exitCode diagnostics) + +validateWorkspaceSyntax :: + HurlfmtCapabilities -> + ValidatedWorkspace -> + IO (Either DependencyError [WorkflowSyntaxError]) +validateWorkspaceSyntax capabilities validated = + go [] (Map.keys (validatedWorkflows validated)) + where + HurlfmtExecutable executablePath = capabilities ^. #executable + + go issues [] = pure (Right (reverse issues)) + go issues (name : remaining) = + case resolveWorkflow validated name of + Left err -> go (SyntaxResolutionFailed err : issues) remaining + Right resolved -> + renderWorkflow resolved >>= \case + Left err -> go (SyntaxRenderFailed name err : issues) remaining + Right rendered -> + validateRenderedWorkflow capabilities rendered >>= \case + Left (HurlfmtNotFound _) -> pure (Left (DependencyNotFound "hurlfmt" executablePath)) + Left err -> go (SyntaxFormatFailed err : issues) remaining + Right () -> go issues remaining + +spanForLine :: Int -> NonEmpty RenderedFragmentSpan -> Maybe RenderedFragmentSpan +spanForLine line = + findFirst + (\span_ -> line >= span_ ^. #firstLine && line <= span_ ^. #lastLine) + . NonEmpty.toList + where + findFirst _ [] = Nothing + findFirst predicate (value : remaining) + | predicate value = Just value + | otherwise = findFirst predicate remaining + +diagnosticLine :: Text -> Maybe Int +diagnosticLine diagnostics = + firstJust (map parseLocation (Text.lines diagnostics)) + where + parseLocation raw = do + location <- Text.stripPrefix "--> " (Text.strip raw) + let (throughLine, columnText) = Text.breakOnEnd ":" location + withoutColumn = Text.dropEnd 1 throughLine + (throughPath, lineText) = Text.breakOnEnd ":" withoutColumn + if Text.null throughPath || Text.null columnText + then Nothing + else readMaybe (Text.unpack lineText) + + firstJust = \case + [] -> Nothing + Nothing : remaining -> firstJust remaining + Just value : _ -> Just value + +decodeOutput :: LazyByteString.ByteString -> Text +decodeOutput = Text.Encoding.decodeUtf8With lenientDecode . LazyByteString.toStrict + +renderDependencyError :: DependencyError -> Text +renderDependencyError = \case + DependencyNotFound name path -> + "required dependency " + <> quote name + <> " was not found or could not be started at " + <> Text.pack path + <> ". Install Hurl 8.0 or newer and ensure both hurl and hurlfmt are on PATH" + DependencyProbeFailed name exitCode message -> + "dependency " <> quote name <> " failed its version probe with " <> Text.pack (show exitCode) <> detail message + DependencyVersionUnrecognized name output -> + "could not parse the version reported by dependency " <> quote name <> detail output + DependencyVersionUnsupported name detected minimumVersion -> + "dependency " <> quote name <> " is version " <> Text.pack (show detected) <> "; version " <> Text.pack (show minimumVersion) <> " or newer is required" + +renderHurlfmtError :: HurlfmtError -> Text +renderHurlfmtError = \case + HurlfmtNotFound path -> + "hurlfmt could not be started at " + <> Text.pack path + <> ". Install Hurl 8.0 or newer and ensure both hurl and hurlfmt are on PATH" + InvalidHurl name sourceSpan diagnostics -> + "workflow " + <> quote (unWorkflowName name) + <> maybe "" renderSpan sourceSpan + <> " is not valid Hurl:\n" + <> Text.stripEnd diagnostics + HurlfmtFailed exitCode diagnostics -> + "hurlfmt failed with " <> Text.pack (show exitCode) <> detail diagnostics + where + renderSpan span_ = + " (fragment " + <> quote (unFragmentName (span_ ^. #fragmentName)) + <> " at " + <> Text.pack (span_ ^. #fragmentPath) + <> ")" + +renderWorkflowSyntaxError :: WorkflowSyntaxError -> Text +renderWorkflowSyntaxError = \case + SyntaxResolutionFailed err -> renderWorkflowError err + SyntaxRenderFailed name err -> + "workflow " <> quote (unWorkflowName name) <> ": " <> renderRenderError err + SyntaxFormatFailed err -> renderHurlfmtError err + +detail :: Text -> Text +detail value + | Text.null (Text.strip value) = "" + | otherwise = ": " <> Text.strip value + +quote :: Text -> Text +quote value = "\"" <> value <> "\"" diff --git a/src/HurlWorkbench/Hurl/Run.hs b/src/HurlWorkbench/Hurl/Run.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Hurl/Run.hs @@ -0,0 +1,376 @@ +-- | Secure execution of one rendered workflow through Hurl. This is the only +-- production module which constructs Hurl argv. +module HurlWorkbench.Hurl.Run + ( HurlRunMode (..), + RunOutputPolicy (..), + HurlReportTarget (..), + HurlVerbosity (..), + AllowedHurlArgument, + HurlOptionError (..), + HurlOptions (..), + defaultHurlOptions, + mkAllowedHurlArgument, + RunRequest (..), + RunStartError (..), + CapturedRunOutput (..), + RunResult (..), + HurlRunner (..), + mkHurlRunner, + renderRunStartError, + ) +where + +import Control.Exception (IOException, SomeException, displayException, mask, onException, throwIO, try) +import Data.Bits ((.&.)) +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.List (nub) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) +import HurlWorkbench.Hurl.Capabilities +import HurlWorkbench.Parameter.Resolve (ResolvedBindings (..)) +import HurlWorkbench.Parameter.Resolve.Internal (secretValueText) +import HurlWorkbench.Prelude +import HurlWorkbench.Process.Run +import HurlWorkbench.Run.FileRoot +import HurlWorkbench.Workflow.Render +import HurlWorkbench.Workspace.Types +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, removeFile) +import System.Environment (getEnvironment) +import System.Exit (ExitCode) +import System.FilePath (takeDirectory) +import System.IO (IOMode (WriteMode), hClose, hFlush, withBinaryFile) +import System.IO.Temp (openBinaryTempFile, withSystemTempDirectory) +import System.Posix.Files + ( accessModes, + fileMode, + getFileStatus, + ownerExecuteMode, + ownerReadMode, + ownerWriteMode, + setFileMode, + unionFileModes, + ) +import System.Posix.IO (OpenFileFlags (..), OpenMode (WriteOnly), defaultFileFlags, fdToHandle, openFd) +import System.Posix.Types (FileMode) +import System.Process qualified as Process + +data HurlRunMode = ClientMode | TestMode + deriving stock (Generic, Eq, Show) + +data RunOutputPolicy + = InheritRunOutput + | CaptureRunOutput + | ResponseFile !FilePath + deriving stock (Generic, Eq, Show) + +data HurlReportTarget + = JUnitReport !FilePath + | HtmlReport !FilePath + | JsonReport !FilePath + | TapReport !FilePath + deriving stock (Generic, Eq, Show) + +data HurlVerbosity = Verbose | VeryVerbose + deriving stock (Generic, Eq, Show) + +newtype AllowedHurlArgument = AllowedHurlArgument Text + deriving stock (Generic, Eq, Ord, Show) + +data HurlOptionError + = NegativeOption !Text !Int + | UnsupportedHurlArgument !Text + | DuplicateReportFormat !Text + deriving stock (Generic, Eq, Show) + +data HurlOptions = HurlOptions + { connectTimeoutSeconds :: !(Maybe Int), + maxTimeSeconds :: !(Maybe Int), + retryCount :: !(Maybe Int), + retryIntervalMilliseconds :: !(Maybe Int), + insecureTls :: !Bool, + includeHeaders :: !Bool, + jsonOutput :: !Bool, + verbosity :: !(Maybe HurlVerbosity), + curlExportPath :: !(Maybe FilePath), + additionalArguments :: ![AllowedHurlArgument] + } + deriving stock (Generic, Eq, Show) + +defaultHurlOptions :: HurlOptions +defaultHurlOptions = + HurlOptions + { connectTimeoutSeconds = Nothing, + maxTimeSeconds = Nothing, + retryCount = Nothing, + retryIntervalMilliseconds = Nothing, + insecureTls = False, + includeHeaders = False, + jsonOutput = False, + verbosity = Nothing, + curlExportPath = Nothing, + additionalArguments = [] + } + +mkAllowedHurlArgument :: Text -> Either HurlOptionError AllowedHurlArgument +mkAllowedHurlArgument rawArgument + | rawArgument `elem` allowedArguments = Right (AllowedHurlArgument rawArgument) + | otherwise = Left (UnsupportedHurlArgument rawArgument) + where + allowedArguments = ["--compressed", "--location", "--location-trusted", "--no-color", "--path-as-is"] + +data RunRequest = RunRequest + { renderedWorkflow :: !RenderedWorkflow, + fileRoot :: !FileRoot, + mode :: !HurlRunMode, + bindings :: !ResolvedBindings, + options :: !HurlOptions, + outputPolicy :: !RunOutputPolicy, + reportTargets :: ![HurlReportTarget] + } + deriving stock (Generic, Eq) + +instance Show RunRequest where + show request = + "RunRequest {workflow=" + <> show (request ^. #renderedWorkflow . #workflowName) + <> ", mode=" + <> show (request ^. #mode) + <> ", bindings=}" + +data RunStartError + = InvalidFileRootLayout !FileRootError + | InvalidRunOptions !(NonEmpty HurlOptionError) + | SecureRunFileError !FilePath !Text + | HurlSpawnFailed !FilePath !Text + deriving stock (Generic, Eq, Show) + +data CapturedRunOutput = CapturedRunOutput + { stdout :: !ByteString.ByteString, + stderr :: !ByteString.ByteString + } + deriving stock (Generic, Eq, Show) + +data RunResult = RunResult + { exitCode :: !ExitCode, + elapsed :: !NominalDiffTime, + capturedOutput :: !(Maybe CapturedRunOutput) + } + deriving stock (Generic, Eq, Show) + +newtype HurlRunner = HurlRunner + { runHurl :: RunRequest -> IO (Either RunStartError RunResult) + } + +mkHurlRunner :: HurlCapabilities -> HurlRunner +mkHurlRunner capabilities = HurlRunner (runRequest capabilities) + +runRequest :: HurlCapabilities -> RunRequest -> IO (Either RunStartError RunResult) +runRequest capabilities request = case validateRequest request of + Just issues -> pure (Left (InvalidRunOptions issues)) + Nothing -> + checkFileRootOutputs (request ^. #fileRoot) outputPaths >>= \case + Left err -> pure (Left (InvalidFileRootLayout err)) + Right () -> do + attempted <- try @IOException (withSystemTempDirectory "hurl-workbench-run" (prepareAndRun capabilities request)) + pure $ case attempted of + Left err -> Left (SecureRunFileError "temporary execution directory" (Text.pack (displayException err))) + Right result -> result + where + outputPaths = maybe [] pure (responseTarget (request ^. #outputPolicy)) <> maybe [] pure (request ^. #options . #curlExportPath) <> map (\case JUnitReport p -> p; HtmlReport p -> p; JsonReport p -> p; TapReport p -> p) (request ^. #reportTargets) + +prepareAndRun :: HurlCapabilities -> RunRequest -> FilePath -> IO (Either RunStartError RunResult) +prepareAndRun capabilities request directory = do + renderedPath <- writeSecureTemporary directory "workflow.hurl" (Text.Encoding.encodeUtf8 (request ^. #renderedWorkflow . #contents)) + variablesPath <- writeBindings directory "variables.env" renderVariable (request ^. #bindings . #variables) + secretsPath <- writeBindings directory "secrets.env" renderSecret (request ^. #bindings . #secrets) + traverse_ prepareReportTarget (request ^. #reportTargets) + traverse_ prepareResponseTarget (responseTarget (request ^. #outputPolicy)) + traverse_ prepareSecureFile (request ^. #options . #curlExportPath) + environment <- filter (not . Text.isPrefixOf "HURL_" . Text.pack . fst) <$> getEnvironment + let arguments = buildArguments request renderedPath variablesPath secretsPath + spawn capabilities request environment arguments directory + where + renderVariable name value = unParameterName name <> "=" <> hurlValueLiteralText value + renderSecret name value = unParameterName name <> "=" <> secretValueText value + +writeBindings :: FilePath -> FilePath -> (ParameterName -> value -> Text) -> Map ParameterName value -> IO (Maybe FilePath) +writeBindings _directory _template _render values | Map.null values = pure Nothing +writeBindings directory template render values = + Just <$> writeSecureTemporary directory template (Text.Encoding.encodeUtf8 (Text.unlines [render name value | (name, value) <- Map.toAscList values])) + +writeSecureTemporary :: FilePath -> FilePath -> ByteString.ByteString -> IO FilePath +writeSecureTemporary directory template bytes = do + (path, handle) <- openBinaryTempFile directory template + let cleanup = do + _ <- try @IOException (hClose handle) + _ <- try @IOException (removeFile path) + pure () + ( do + verifyMode secureFileMode path + ByteString.hPut handle bytes + hFlush handle + hClose handle + pure path + ) + `onException` cleanup + +prepareResponseTarget :: FilePath -> IO () +prepareResponseTarget = prepareSecureFile + +prepareReportTarget :: HurlReportTarget -> IO () +prepareReportTarget = \case + JUnitReport path -> prepareSecureFileWith path "\n\n" + TapReport path -> prepareSecureFileWith path "TAP version 13\n1..0\n" + HtmlReport path -> prepareSecureDirectory path + JsonReport path -> prepareSecureDirectory path + +prepareSecureFile :: FilePath -> IO () +prepareSecureFile path = prepareSecureFileWith path "" + +-- Hurl 8 appends to JUnit and TAP files by parsing any existing target. Seed +-- those owner-only files with valid empty documents rather than zero bytes; +-- File.create then preserves the secure mode when Hurl replaces the content. +prepareSecureFileWith :: FilePath -> ByteString.ByteString -> IO () +prepareSecureFileWith path initialContent = do + createDirectoryIfMissing True (takeDirectory path) + handle <- fdToHandle =<< openFd path WriteOnly defaultFileFlags {creat = Just secureFileMode, trunc = True, nofollow = True} + ByteString.hPut handle initialContent + hClose handle + setFileMode path secureFileMode + verifyMode secureFileMode path + +prepareSecureDirectory :: FilePath -> IO () +prepareSecureDirectory path = do + exists <- doesDirectoryExist path + unless exists (createDirectoryIfMissing True path) + setFileMode path secureDirectoryMode + verifyMode secureDirectoryMode path + +verifyMode :: FileMode -> FilePath -> IO () +verifyMode expected path = do + actual <- (.&. accessModes) . fileMode <$> getFileStatus path + unless (actual == expected) (ioError (userError ("insecure permissions on " <> path))) + +secureFileMode :: FileMode +secureFileMode = ownerReadMode `unionFileModes` ownerWriteMode + +secureDirectoryMode :: FileMode +secureDirectoryMode = secureFileMode `unionFileModes` ownerExecuteMode + +-- Private files avoid closing a live output pipe before signalling its writer. +-- That pipe-close ordering can block cancellation inside typed-process cleanup. +spawn :: HurlCapabilities -> RunRequest -> [(String, String)] -> [String] -> FilePath -> IO (Either RunStartError RunResult) +spawn capabilities request environment arguments directory = case request ^. #outputPolicy of + InheritRunOutput -> runOwned config + CaptureRunOutput -> capture + ResponseFile _ -> capture + where + config = (Process.proc (capabilities ^. #hurlExecutable) arguments) {Process.env = Just environment, Process.create_group = True} + runOwned processConfig = mask $ \restore -> do + began <- getCurrentTime + spawnGroup (ServiceName "hurl") processConfig >>= \case + Left _ -> pure (Left (HurlSpawnFailed (capabilities ^. #hurlExecutable) "process launch failed")) + Right owned -> do + execution <- try @SomeException (restore (waitExitCode owned)) + cleanup <- terminateGroup (ServiceName "hurl") 2 owned + ended <- getCurrentTime + case execution of + Left err -> throwIO err + Right exit -> pure $ case cleanup of + Left _ -> Left (SecureRunFileError "Hurl process group" "cleanup failed") + Right () -> Right (RunResult exit (diffUTCTime ended began) Nothing) + capture = do + stdoutPath <- writeSecureTemporary directory "stdout" "" + stderrPath <- writeSecureTemporary directory "stderr" "" + result <- withBinaryFile stdoutPath WriteMode $ \stdout -> + withBinaryFile stderrPath WriteMode $ \stderr -> + runOwned config {Process.std_in = Process.NoStream, Process.std_out = Process.UseHandle stdout, Process.std_err = Process.UseHandle stderr} + case result of + Left err -> pure (Left err) + Right finished -> do + stdout <- ByteString.readFile stdoutPath + stderr <- ByteString.readFile stderrPath + pure (Right (finished & #capturedOutput .~ Just (CapturedRunOutput stdout stderr))) + +buildArguments :: RunRequest -> FilePath -> Maybe FilePath -> Maybe FilePath -> [String] +buildArguments request renderedPath variablesPath secretsPath = + ["--file-root", root] + <> maybe [] (\path -> ["--variables-file", path]) variablesPath + <> maybe [] (\path -> ["--secrets-file", path]) secretsPath + <> ["--test" | request ^. #mode == TestMode] + <> renderOptions (request ^. #options) + <> concatMap renderReportTarget (request ^. #reportTargets) + <> maybe [] (\path -> ["--output", path]) (responseTarget (request ^. #outputPolicy)) + <> [renderedPath] + where + root = fileRootPath (request ^. #fileRoot) + +renderOptions :: HurlOptions -> [String] +renderOptions options = + valued "--connect-timeout" (options ^. #connectTimeoutSeconds) + <> valued "--max-time" (options ^. #maxTimeSeconds) + <> valued "--retry" (options ^. #retryCount) + <> valued "--retry-interval" (options ^. #retryIntervalMilliseconds) + <> ["--insecure" | options ^. #insecureTls] + <> ["--include" | options ^. #includeHeaders] + <> ["--json" | options ^. #jsonOutput] + <> case options ^. #verbosity of + Just Verbose -> ["--verbose"] + Just VeryVerbose -> ["--very-verbose"] + Nothing -> [] + <> maybe [] (\path -> ["--curl", path]) (options ^. #curlExportPath) + <> map (Text.unpack . allowedArgumentText) (options ^. #additionalArguments) + where + valued flag = maybe [] (\value -> [flag, show value]) + +allowedArgumentText :: AllowedHurlArgument -> Text +allowedArgumentText (AllowedHurlArgument value) = value + +renderReportTarget :: HurlReportTarget -> [String] +renderReportTarget = \case + JUnitReport path -> ["--report-junit", path] + HtmlReport path -> ["--report-html", path] + JsonReport path -> ["--report-json", path] + TapReport path -> ["--report-tap", path] + +responseTarget :: RunOutputPolicy -> Maybe FilePath +responseTarget = \case + ResponseFile path -> Just path + _ -> Nothing + +validateRequest :: RunRequest -> Maybe (NonEmpty HurlOptionError) +validateRequest request = nonEmpty (numericIssues <> reportIssues) + where + options = request ^. #options + numericIssues = + concat + [ nonNegative "connect timeout" (options ^. #connectTimeoutSeconds), + nonNegative "max time" (options ^. #maxTimeSeconds), + nonNegative "retry count" (options ^. #retryCount), + nonNegative "retry interval" (options ^. #retryIntervalMilliseconds) + ] + formats = map reportFormat (request ^. #reportTargets) + reportIssues = [DuplicateReportFormat format | format <- nub formats, length (filter (== format) formats) > 1] + nonNegative name = maybe [] (\value -> [NegativeOption name value | value < 0]) + +reportFormat :: HurlReportTarget -> Text +reportFormat = \case + JUnitReport _ -> "JUnit" + HtmlReport _ -> "HTML" + JsonReport _ -> "JSON" + TapReport _ -> "TAP" + +renderRunStartError :: RunStartError -> Text +renderRunStartError = \case + InvalidFileRootLayout err -> renderFileRootError err + InvalidRunOptions issues -> Text.intercalate "\n" (map renderOptionError (toList issues)) + SecureRunFileError path message -> "could not prepare secure run file " <> Text.pack path <> ": " <> message + HurlSpawnFailed path message -> "Hurl could not be started at " <> Text.pack path <> ": " <> message + where + renderOptionError = \case + NegativeOption name value -> name <> " must not be negative, got " <> Text.pack (show value) + UnsupportedHurlArgument rawArgument -> "unsupported --hurl-arg " <> rawArgument + DuplicateReportFormat format -> "at most one " <> format <> " report target is allowed" diff --git a/src/HurlWorkbench/Parameter/Generate.hs b/src/HurlWorkbench/Parameter/Generate.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Parameter/Generate.hs @@ -0,0 +1,132 @@ +-- | Bounded generation of scenario inputs. No generated data enters errors. +module HurlWorkbench.Parameter.Generate + ( GeneratorEnvironment (..), + defaultGeneratorEnvironment, + generateValue, + validateGenerator, + generatorName, + uuid4Bytes, + uuid7Bytes, + formatUuid, + encodeTypeId, + ) +where + +import Control.Exception (IOException, try) +import Data.Bifunctor (first) +import Data.Bits (shiftR, (.&.), (.|.)) +import Data.ByteString qualified as BS +import Data.Text qualified as Text +import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word8) +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Types +import Numeric (showHex) +import System.IO (IOMode (ReadMode), withBinaryFile) + +data GeneratorEnvironment = GeneratorEnvironment + { currentTime :: IO UTCTime, + entropyBytes :: Int -> IO BS.ByteString + } + +defaultGeneratorEnvironment :: GeneratorEnvironment +defaultGeneratorEnvironment = GeneratorEnvironment getCurrentTime $ \count -> + if count < 0 || count > 16384 + then ioError (userError "invalid entropy request") + else withBinaryFile "/dev/urandom" ReadMode $ \handle -> + let readExactly remaining chunks + | remaining == 0 = pure (BS.concat (reverse chunks)) + | otherwise = do + bytes <- BS.hGet handle remaining + if BS.null bytes + then ioError (userError "entropy EOF") + else readExactly (remaining - BS.length bytes) (bytes : chunks) + in readExactly count [] + +generatorName :: Generator -> Text +generatorName = \case + Uuid4 -> "Uuid4" + Uuid7 -> "Uuid7" + TypeId _ -> "TypeId" + Rfc3339Now -> "Rfc3339Now" + RandomAlphanumeric _ -> "RandomAlphanumeric" + +validateGenerator :: Generator -> Either Text () +validateGenerator = \case + TypeId (TypeIdOptions prefix) + | Text.length prefix > 63 + || not (Text.all (\c -> letter c || c == '_') prefix) + || (not (Text.null prefix) && (not (letter (Text.head prefix)) || not (letter (Text.last prefix)))) -> + Left "TypeId prefix must be empty or at most 63 lowercase ASCII letters/underscores, starting and ending with a letter" + RandomAlphanumeric (RandomOptions count) | count < 1 || count > 4096 -> Left "RandomAlphanumeric length must be between 1 and 4096" + _ -> Right () + where + letter c = c >= 'a' && c <= 'z' + +-- | Synchronous IO failures are redacted; cancellation propagates normally. +generateValue :: GeneratorEnvironment -> Generator -> IO (Either Text HurlValueLiteral) +generateValue env generator = case validateGenerator generator of + Left err -> pure (Left err) + Right () -> do + result <- try @IOException generate + pure $ case result of + Left _ -> Left "generation failed" + Right (Left _) -> Left "generation failed" + Right (Right value) -> first (const "generated value is not a Hurl literal") (mkHurlValueLiteral value) + where + draw count = do + bytes <- entropyBytes env count + if BS.length bytes == count then pure bytes else ioError (userError "short entropy read") + uuid7 = do + now <- currentTime env + bytes <- BS.unpack <$> draw 16 + pure (uuid7Bytes (floor (utcTimeToPOSIXSeconds now * 1000)) bytes) + generate = case generator of + Uuid4 -> fmap (fmap formatUuid . uuid4Bytes . BS.unpack) (draw 16) + Uuid7 -> fmap (fmap formatUuid) uuid7 + TypeId (TypeIdOptions prefix) -> fmap (fmap (\bytes -> (if Text.null prefix then "" else prefix <> "_") <> encodeTypeId bytes)) uuid7 + Rfc3339Now -> do + now <- currentTime env + let millis = (floor (utcTimeToPOSIXSeconds now * 1000) :: Integer) `mod` 1000 + digits = show millis + pure (Right (Text.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" now <> "." <> replicate (3 - length digits) '0' <> digits <> "Z"))) + RandomAlphanumeric (RandomOptions count) -> sample (fromIntegral count) (fromIntegral count * 32 + 128) [] + -- Rejection sampling has a finite entropy budget, including a broken source + -- that supplies only rejected bytes. No modulo bias or unbounded loop. + sample remaining budget chunks + | remaining == 0 = pure (Right (Text.concat (reverse chunks))) + | budget <= 0 = pure (Left "entropy rejection budget exhausted") + | otherwise = do + let count = min budget (max 32 (min 4096 (remaining * 2))) + bytes <- draw count + let accepted = take remaining [Text.index alphabet (fromIntegral byte `mod` 62) | byte <- BS.unpack bytes, byte < 248] + sample (remaining - length accepted) (budget - count) (Text.pack accepted : chunks) + alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + +uuid4Bytes :: [Word8] -> Either Text [Word8] +uuid4Bytes = setVersion 4 + +setVersion :: Word8 -> [Word8] -> Either Text [Word8] +setVersion version bytes + | length bytes /= 16 = Left "UUID requires 16 bytes" + | otherwise = Right [if index == 6 then (byte .&. 15) .|. (version * 16) else if index == 8 then (byte .&. 63) .|. 128 else byte | (index, byte) <- zip [0 :: Int ..] bytes] + +uuid7Bytes :: Integer -> [Word8] -> Either Text [Word8] +uuid7Bytes millis bytes + | millis < 0 || millis >= 2 ^ (48 :: Int) = Left "UUID7 timestamp outside 48-bit range" + | length bytes /= 16 = Left "UUID requires 16 bytes" + | otherwise = setVersion 7 ([fromIntegral (millis `shiftR` bits) | bits <- [40, 32 .. 0]] <> drop 6 bytes) + +formatUuid :: [Word8] -> Text +formatUuid bytes = Text.pack (concat [separator index <> hex byte | (index, byte) <- zip [0 :: Int ..] bytes]) + where + separator index = if index `elem` [4, 6, 8, 10] then "-" else "" + hex byte = let digits = showHex byte "" in replicate (2 - length digits) '0' <> digits + +-- | TypeID v0.3: mori://jetify-com/typeid, spec/README.md (artifact URI pending). +encodeTypeId :: [Word8] -> Text +encodeTypeId bytes = Text.pack [alphabet !! fromIntegral ((value `shiftR` bits) .&. 31) | bits <- [125, 120 .. 0]] + where + value = foldl (\acc byte -> acc * 256 + fromIntegral byte) (0 :: Integer) bytes + alphabet = "0123456789abcdefghjkmnpqrstvwxyz" diff --git a/src/HurlWorkbench/Parameter/Properties.hs b/src/HurlWorkbench/Parameter/Properties.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Parameter/Properties.hs @@ -0,0 +1,117 @@ +-- | The deliberately small properties-file language accepted by Hurl 8 for +-- variables and secrets. This module parses the transport format; it does +-- not decide whether a parameter is plain or secret in the workspace. +module HurlWorkbench.Parameter.Properties + ( PropertyFileKind (..), + PropertyError (..), + parseVariableProperties, + parseSecretProperties, + renderPropertyError, + ) +where + +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate (isValidParameterName) + +data PropertyFileKind = VariableProperties | SecretProperties + deriving stock (Generic, Eq, Show) + +-- | A parse error which never retains a property value. That invariant is +-- important for secret files because callers may safely render or show it. +data PropertyError + = InvalidPropertiesUtf8 !PropertyFileKind !FilePath !Int + | MissingPropertyEquals !PropertyFileKind !FilePath !Int + | InvalidPropertyName !PropertyFileKind !FilePath !Int !ParameterName + | DuplicatePropertyName !PropertyFileKind !FilePath !Int !ParameterName + | InvalidPropertyValue !PropertyFileKind !FilePath !Int !ParameterName !HurlValueLiteralError + deriving stock (Generic, Eq, Show) + +parseVariableProperties :: FilePath -> ByteString -> Either PropertyError (Map ParameterName HurlValueLiteral) +parseVariableProperties path bytes = + parseProperties VariableProperties path bytes $ \line name value -> + first (InvalidPropertyValue VariableProperties path line name) (mkHurlValueLiteral value) + +parseSecretProperties :: FilePath -> ByteString -> Either PropertyError (Map ParameterName Text) +parseSecretProperties path bytes = + parseProperties SecretProperties path bytes $ \line name value -> + hurlValueLiteralText + <$> first (InvalidPropertyValue SecretProperties path line name) (mkHurlValueLiteral value) + +parseProperties :: PropertyFileKind -> FilePath -> ByteString -> (Int -> ParameterName -> Text -> Either PropertyError value) -> Either PropertyError (Map ParameterName value) +parseProperties kind path bytes parseValue = do + input <- case Text.Encoding.decodeUtf8' bytes of + Left _err -> Left (InvalidPropertiesUtf8 kind path (firstInvalidUtf8Offset bytes)) + Right value -> Right value + foldMLine Map.empty (zip [1 ..] (Text.lines input)) + where + foldMLine values [] = Right values + foldMLine values ((lineNumber, rawLine) : remaining) = + let line = Text.strip rawLine + in if Text.null line || "#" `Text.isPrefixOf` line + then foldMLine values remaining + else case Text.breakOn "=" line of + (_nameText, rest) | Text.null rest -> Left (MissingPropertyEquals kind path lineNumber) + (nameText, rest) -> do + let name = ParameterName nameText + valueText = Text.drop 1 rest + unlessEither (isValidParameterName nameText) (InvalidPropertyName kind path lineNumber name) + unlessEither (Map.notMember name values) (DuplicatePropertyName kind path lineNumber name) + value <- parseValue lineNumber name valueText + foldMLine (Map.insert name value values) remaining + +unlessEither :: Bool -> err -> Either err () +unlessEither condition err = if condition then Right () else Left err + +firstInvalidUtf8Offset :: ByteString -> Int +firstInvalidUtf8Offset bytes = go 0 + where + length_ = ByteString.length bytes + byte = ByteString.index bytes + go offset + | offset >= length_ = max 0 (length_ - 1) + | current <= 0x7F = go (offset + 1) + | current >= 0xC2 && current <= 0xDF = continuationSequence offset [continuation] + | current == 0xE0 = continuationSequence offset [between 0xA0 0xBF, continuation] + | current >= 0xE1 && current <= 0xEC = continuationSequence offset [continuation, continuation] + | current == 0xED = continuationSequence offset [between 0x80 0x9F, continuation] + | current >= 0xEE && current <= 0xEF = continuationSequence offset [continuation, continuation] + | current == 0xF0 = continuationSequence offset [between 0x90 0xBF, continuation, continuation] + | current >= 0xF1 && current <= 0xF3 = continuationSequence offset [continuation, continuation, continuation] + | current == 0xF4 = continuationSequence offset [between 0x80 0x8F, continuation, continuation] + | otherwise = offset + where + current = byte offset + continuationSequence start checks = check (start + 1) checks + where + check next [] = go next + check next (valid : remaining) + | next >= length_ = start + | valid (byte next) = check (next + 1) remaining + | otherwise = next + continuation = between 0x80 0xBF + between lower upper value = value >= lower && value <= upper + +renderPropertyError :: PropertyError -> Text +renderPropertyError = \case + InvalidPropertiesUtf8 kind path offset -> prefix kind path <> "is not UTF-8 at byte " <> tshow offset + MissingPropertyEquals kind path line -> atLine kind path line <> "must contain NAME=VALUE" + InvalidPropertyName kind path line name -> atLine kind path line <> "has invalid parameter name " <> quote (unParameterName name) + DuplicatePropertyName kind path line name -> atLine kind path line <> "repeats parameter " <> quote (unParameterName name) + InvalidPropertyValue kind path line name err -> + atLine kind path line <> "cannot transport parameter " <> quote (unParameterName name) <> ": " <> renderHurlValueLiteralError err + where + prefix kind path = label kind <> " file " <> quote (Text.pack path) <> " " + atLine kind path line = prefix kind path <> "line " <> tshow line <> " " + label VariableProperties = "variables" + label SecretProperties = "secrets" + quote value = "\"" <> value <> "\"" + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show diff --git a/src/HurlWorkbench/Parameter/Resolve.hs b/src/HurlWorkbench/Parameter/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Parameter/Resolve.hs @@ -0,0 +1,293 @@ +-- | Resolve all runtime values for a validated workflow. Plain values and +-- secrets remain separate from discovery through serialization. +module HurlWorkbench.Parameter.Resolve + ( BindingInput (..), + BindingSource (..), + BindingLayer (..), + SecretValue, + SecretValueError (..), + ResolvedBindings (..), + BindingIssue (..), + BindingError (..), + emptyBindingInput, + mkSecretValue, + resolveParameters, + resolveParametersWithGenerator, + resolveParametersWithLayersAndGenerator, + resolveParameterSubset, + resolveParameterSubsetInEnvironment, + resolveParametersWithLayers, + resolveWorkflowBindings, + resolveWorkflowBindingsWithLayers, + resolveWorkflowBindingSubsetWithLayers, + renderBindingError, + renderBindingIssue, + ) +where + +import Control.Exception (IOException, try) +import Data.Bifunctor (first) +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import HurlWorkbench.Parameter.Generate +import HurlWorkbench.Parameter.Properties +import HurlWorkbench.Parameter.Resolve.Internal +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate (isValidEnvironmentName) +import System.Environment (lookupEnv) + +emptyBindingInput :: BindingInput +emptyBindingInput = + BindingInput + { plainOverrides = Map.empty, + secretEnvironmentOverrides = Map.empty, + variableFiles = [], + secretFiles = [] + } + +resolveWorkflowBindings :: ValidatedWorkspace -> Workflow -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveWorkflowBindings validated workflow input = + resolveParameters validated (Set.fromList (workflow ^. #parameters)) input + +resolveWorkflowBindingsWithLayers :: ValidatedWorkspace -> Workflow -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveWorkflowBindingsWithLayers validated workflow layers input = + resolveParametersWithLayers validated (Set.fromList (workflow ^. #parameters)) layers input + +resolveWorkflowBindingSubsetWithLayers :: ValidatedWorkspace -> Workflow -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveWorkflowBindingSubsetWithLayers validated workflow layers input = + resolveParametersWithMode False validated (Set.fromList (workflow ^. #parameters)) layers input + +resolveParameters :: ValidatedWorkspace -> Set ParameterName -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParameters validated selected = resolveParametersWithLayers validated selected [] + +-- | Resolve one consumer's parameter subset from a shared runtime input. +-- Bindings for other declared consumers are ignored, while selected names +-- retain the same kind and precedence validation as normal resolution. +resolveParameterSubset :: ValidatedWorkspace -> Set ParameterName -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParameterSubset validated selected = resolveParametersWithMode False validated selected [] + +-- | Resolve runtime inputs over committed plain-value layers ordered from +-- highest to lowest precedence. Runtime overrides and variable files remain +-- above these layers; declared environments and defaults remain below them. +resolveParametersWithLayers :: ValidatedWorkspace -> Set ParameterName -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParametersWithLayers = resolveParametersWithLayersAndGenerator defaultGeneratorEnvironment + +-- | Inject clock/entropy while preserving the committed binding layers. +resolveParametersWithLayersAndGenerator :: GeneratorEnvironment -> ValidatedWorkspace -> Set ParameterName -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParametersWithLayersAndGenerator env = resolveParametersWithLookup env lookupEnv True + +resolveParametersWithMode :: Bool -> ValidatedWorkspace -> Set ParameterName -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParametersWithMode = resolveParametersWithLookup defaultGeneratorEnvironment lookupEnv + +-- | Resolve managed consumers from the invocation snapshot, including declared +-- parameter environments and explicit secret-environment channels. +resolveParameterSubsetInEnvironment :: [(String, String)] -> ValidatedWorkspace -> Set ParameterName -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParameterSubsetInEnvironment ambient validated selected = resolveParametersWithLookup defaultGeneratorEnvironment (pure . (`Map.lookup` Map.fromList ambient)) False validated selected [] + +resolveParametersWithGenerator :: GeneratorEnvironment -> ValidatedWorkspace -> Set ParameterName -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParametersWithGenerator env validated selected = resolveParametersWithLookup env lookupEnv True validated selected [] + +resolveParametersWithLookup :: GeneratorEnvironment -> (String -> IO (Maybe String)) -> Bool -> ValidatedWorkspace -> Set ParameterName -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings) +resolveParametersWithLookup generatorEnvironment lookupEnvironment rejectUnselected validated selected layers input = do + loadedVariables <- loadVariableFiles (input ^. #variableFiles) + loadedSecrets <- loadSecretFiles (input ^. #secretFiles) + case (loadedVariables, loadedSecrets) of + (Left err, _) -> pure (Left err) + (_, Left err) -> pure (Left err) + (Right variableMaps, Right secretMaps) -> do + let fileVariables = laterWins variableMaps + fileSecrets = laterWins secretMaps + explicitVariables = Map.map (,ExplicitVariable) (input ^. #plainOverrides) + explicitSecrets = Map.mapWithKey (\_ env -> (env, ExplicitSecretEnvironment env)) (input ^. #secretEnvironmentOverrides) + committedVariables = map sourcedLayer layers + parameters = validatedParameters validated + staticIssues = + unknownSelected parameters selected + <> [ issue + | rejectUnselected, + issue <- + unexpected selected explicitVariables + <> unexpected selected explicitSecrets + <> unexpected selected fileVariables + <> unexpected selected fileSecrets + <> concatMap (unexpected selected) committedVariables + ] + <> kindMismatches parameters selected explicitVariables explicitSecrets fileVariables fileSecrets committedVariables + resolved <- traverse (resolveOne generatorEnvironment lookupEnvironment parameters explicitVariables explicitSecrets fileVariables fileSecrets committedVariables) (Set.toAscList selected) + let dynamicIssues = concatMap (\(issues, _, _) -> issues) resolved + allIssues = staticIssues <> dynamicIssues + pure $ case nonEmpty allIssues of + Just issues -> Left (BindingIssues issues) + Nothing -> + Right + ResolvedBindings + { variables = Map.fromList (mapMaybe (\(_, variable, _) -> variable) resolved), + secrets = Map.fromList (mapMaybe (\(_, _, secret) -> secret) resolved) + } + where + sourcedLayer layer = Map.map (,(layer ^. #source)) (layer ^. #values) + +type Sourced value = Map ParameterName (value, BindingSource) + +loadVariableFiles :: [FilePath] -> IO (Either BindingError [Sourced HurlValueLiteral]) +loadVariableFiles = loadFiles VariableProperties parseVariableProperties + +loadSecretFiles :: [FilePath] -> IO (Either BindingError [Sourced Text]) +loadSecretFiles = loadFiles SecretProperties parseSecretProperties + +loadFiles :: PropertyFileKind -> (FilePath -> ByteString.ByteString -> Either PropertyError (Map ParameterName value)) -> [FilePath] -> IO (Either BindingError [Sourced value]) +loadFiles kind parser = go [] + where + go loaded [] = pure (Right (reverse loaded)) + go loaded (path : remaining) = do + bytes <- try @IOException (ByteString.readFile path) + case bytes of + Left _err -> pure (Left (BindingFileReadError kind path)) + Right contents -> case parser path contents of + Left err -> pure (Left (BindingPropertyError err)) + Right values -> + let source = case kind of + VariableProperties -> VariableFile path + SecretProperties -> SecretFile path + in go (Map.map (,source) values : loaded) remaining + +laterWins :: [Sourced value] -> Sourced value +laterWins = foldl' (flip Map.union) Map.empty + +unknownSelected :: Map ParameterName Parameter -> Set ParameterName -> [BindingIssue] +unknownSelected parameters selected = + [UnknownDeclaredParameter name | name <- Set.toAscList selected, Map.notMember name parameters] + +unexpected :: Set ParameterName -> Sourced value -> [BindingIssue] +unexpected selected values = + [ UnexpectedBinding name source + | (name, (_, source)) <- Map.toAscList values, + name `Set.notMember` selected + ] + +kindMismatches :: Map ParameterName Parameter -> Set ParameterName -> Sourced HurlValueLiteral -> Sourced Text -> Sourced HurlValueLiteral -> Sourced Text -> [Sourced HurlValueLiteral] -> [BindingIssue] +kindMismatches parameters selected explicitVariables explicitSecrets fileVariables fileSecrets committedVariables = + concatMap one (Set.toAscList selected) + where + one name = case Map.lookup name parameters of + Nothing -> [] + Just parameter -> case parameter ^. #kind of + Generated _ -> [BindingKindMismatch name Plain source | source <- sourcesFor name explicitSecrets <> sourcesFor name fileSecrets] + Plain -> [BindingKindMismatch name Secret source | source <- sourcesFor name explicitSecrets <> sourcesFor name fileSecrets] + Secret -> [BindingKindMismatch name Plain source | source <- sourcesFor name explicitVariables <> sourcesFor name fileVariables <> concatMap (sourcesFor name) committedVariables] + +sourcesFor :: ParameterName -> Sourced value -> [BindingSource] +sourcesFor name values = maybe [] (pure . snd) (Map.lookup name values) + +resolveOne :: GeneratorEnvironment -> (String -> IO (Maybe String)) -> Map ParameterName Parameter -> Sourced HurlValueLiteral -> Sourced Text -> Sourced HurlValueLiteral -> Sourced Text -> [Sourced HurlValueLiteral] -> ParameterName -> IO ([BindingIssue], Maybe (ParameterName, HurlValueLiteral), Maybe (ParameterName, SecretValue)) +resolveOne generatorEnvironment lookupEnvironment parameters explicitVariables explicitSecrets fileVariables fileSecrets committedVariables name = + case Map.lookup name parameters of + Nothing -> pure ([], Nothing, Nothing) + Just parameter -> case parameter ^. #kind of + Generated generator -> do + environmentValue <- traverse (lookupPlainEnvironment lookupEnvironment name) (parameter ^. #environment) + case firstJust [Right <$> Map.lookup name explicitVariables, Right <$> Map.lookup name fileVariables, environmentValue] of + Just (Left issue) -> pure ([issue], Nothing, Nothing) + Just (Right (value, _)) -> pure ([], Just (name, value), Nothing) + Nothing -> + generateValue generatorEnvironment generator >>= \case + Left _ -> pure ([GeneratorFailure name generator], Nothing, Nothing) + Right value -> pure ([], Just (name, value), Nothing) + Plain -> do + environmentValue <- traverse (lookupPlainEnvironment lookupEnvironment name) (parameter ^. #environment) + let selectedValue = + firstJust + [ Right <$> Map.lookup name explicitVariables, + Right <$> Map.lookup name fileVariables, + firstLayerValue name committedVariables, + environmentValue, + Right . (,DefaultValue) <$> parameter ^. #defaultValue + ] + pure $ case selectedValue of + Nothing -> ([MissingBinding name], Nothing, Nothing) + Just (Left issue) -> ([issue], Nothing, Nothing) + Just (Right (value, _source)) -> ([], Just (name, value), Nothing) + Secret -> do + explicitValue <- traverse (lookupSecretEnvironment lookupEnvironment name) (Map.lookup name explicitSecrets) + declaredValue <- traverse (\env -> lookupSecretEnvironment lookupEnvironment name (env, DeclaredEnvironment env)) (parameter ^. #environment) + let fileValue = case Map.lookup name fileSecrets of + Nothing -> Nothing + Just (value, source) -> Just (first (InvalidSecretBinding name source) (mkSecretValue value) <&> (,source)) + selectedValue = firstJust [explicitValue, fileValue, declaredValue] + pure $ case selectedValue of + Nothing -> ([MissingBinding name], Nothing, Nothing) + Just (Left issue) -> ([issue], Nothing, Nothing) + Just (Right (value, _source)) -> ([], Nothing, Just (name, value)) + +lookupPlainEnvironment :: (String -> IO (Maybe String)) -> ParameterName -> Text -> IO (Either BindingIssue (HurlValueLiteral, BindingSource)) +lookupPlainEnvironment lookupEnvironment name environmentName + | not (isValidEnvironmentName environmentName) = + pure (Left (InvalidBindingEnvironmentName name environmentName (DeclaredEnvironment environmentName))) + | otherwise = do + value <- lookupEnvironment (Text.unpack environmentName) + pure $ case value of + Nothing -> Left (MissingBindingEnvironment name environmentName (DeclaredEnvironment environmentName)) + Just raw -> first (InvalidPlainBinding name (DeclaredEnvironment environmentName)) (mkHurlValueLiteral (Text.pack raw)) <&> (,DeclaredEnvironment environmentName) + +lookupSecretEnvironment :: (String -> IO (Maybe String)) -> ParameterName -> (Text, BindingSource) -> IO (Either BindingIssue (SecretValue, BindingSource)) +lookupSecretEnvironment lookupEnvironment name (environmentName, source) + | not (isValidEnvironmentName environmentName) = + pure (Left (InvalidBindingEnvironmentName name environmentName source)) + | otherwise = do + value <- lookupEnvironment (Text.unpack environmentName) + pure $ case value of + Nothing -> Left (MissingBindingEnvironment name environmentName source) + Just raw -> first (InvalidSecretBinding name source) (mkSecretValue (Text.pack raw)) <&> (,source) + +firstJust :: [Maybe a] -> Maybe a +firstJust = \case + [] -> Nothing + Nothing : rest -> firstJust rest + Just value : _ -> Just value + +firstLayerValue :: ParameterName -> [Sourced value] -> Maybe (Either issue (value, BindingSource)) +firstLayerValue name = firstJust . map (fmap Right . Map.lookup name) + +renderBindingError :: BindingError -> Text +renderBindingError = \case + BindingFileReadError kind path -> label kind <> " file could not be read: " <> Text.pack path + BindingPropertyError err -> renderPropertyError err + BindingIssues issues -> Text.intercalate "\n" (map renderBindingIssue (toList issues)) + where + label VariableProperties = "variables" + label SecretProperties = "secrets" + +renderBindingIssue :: BindingIssue -> Text +renderBindingIssue = \case + UnexpectedBinding name source -> "parameter " <> quoted name <> " from " <> renderSource source <> " is not declared by the selected workflow" + BindingKindMismatch name expected source -> "parameter " <> quoted name <> " from " <> renderSource source <> " must be supplied as " <> kindName expected + MissingBinding name -> "required parameter " <> quoted name <> " has no value" + MissingBindingEnvironment name environmentName source -> "environment variable " <> quote environmentName <> " for parameter " <> quoted name <> " from " <> renderSource source <> " is not set" + InvalidBindingEnvironmentName name environmentName source -> "environment variable name " <> quote environmentName <> " for parameter " <> quoted name <> " from " <> renderSource source <> " is invalid" + InvalidPlainBinding name source err -> "plain parameter " <> quoted name <> " from " <> renderSource source <> " is invalid: " <> renderHurlValueLiteralError err + InvalidSecretBinding name source err -> "secret parameter " <> quoted name <> " from " <> renderSource source <> " is invalid: " <> secretError err + GeneratorFailure name generator -> "generation failed for parameter " <> quoted name <> " (" <> generatorName generator <> ")" + UnknownDeclaredParameter name -> "selected parameter " <> quoted name <> " does not exist in the validated workspace" + where + quoted = quote . unParameterName + quote value = "\"" <> value <> "\"" + kindName (Generated _) = "a plain value" + kindName Plain = "a plain value" + kindName Secret = "a secret value" + secretError SecretContainsLineBreakOrNul = "value contains a line break or NUL character, which Hurl secret files cannot carry" + secretError SecretHasSurroundingWhitespace = "value has leading or trailing whitespace, which Hurl secret files would trim" + +renderSource :: BindingSource -> Text +renderSource = \case + ExplicitVariable -> "--variable" + ExplicitSecretEnvironment env -> "--secret-env " <> env + VariableFile path -> "variables file " <> Text.pack path + SecretFile path -> "secrets file " <> Text.pack path + CommittedBinding label -> "committed " <> label + DeclaredEnvironment env -> "declared environment " <> env + DefaultValue -> "the workspace default" diff --git a/src/HurlWorkbench/Parameter/Resolve/Internal.hs b/src/HurlWorkbench/Parameter/Resolve/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Parameter/Resolve/Internal.hs @@ -0,0 +1,94 @@ +-- | Internal representation of resolved parameter values. The public module +-- keeps the secret constructor and accessor abstract; the Hurl adapter is +-- process-boundary modules are the only production consumers of +-- 'secretValueText'. +module HurlWorkbench.Parameter.Resolve.Internal + ( BindingInput (..), + BindingSource (..), + BindingLayer (..), + SecretValue, + SecretValueError (..), + ResolvedBindings (..), + BindingIssue (..), + BindingError (..), + mkSecretValue, + secretValueText, + ) +where + +import HurlWorkbench.Parameter.Properties (PropertyError, PropertyFileKind) +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Types + +data BindingInput = BindingInput + { plainOverrides :: !(Map ParameterName HurlValueLiteral), + secretEnvironmentOverrides :: !(Map ParameterName Text), + variableFiles :: ![FilePath], + secretFiles :: ![FilePath] + } + deriving stock (Generic, Eq, Show) + +data BindingSource + = ExplicitVariable + | ExplicitSecretEnvironment !Text + | VariableFile !FilePath + | SecretFile !FilePath + | CommittedBinding !Text + | DeclaredEnvironment !Text + | DefaultValue + deriving stock (Generic, Eq, Ord, Show) + +-- | One committed plain-value layer. Layers are ordered from highest to +-- lowest precedence. Recipe and matrix types stay outside this module. +data BindingLayer = BindingLayer + { source :: !BindingSource, + values :: !(Map ParameterName HurlValueLiteral) + } + deriving stock (Generic, Eq, Show) + +newtype SecretValue = SecretValue Text + deriving stock (Generic, Eq) + +instance Show SecretValue where + show _ = "SecretValue " + +data SecretValueError + = SecretContainsLineBreakOrNul + | SecretHasSurroundingWhitespace + deriving stock (Generic, Eq, Show) + +data ResolvedBindings = ResolvedBindings + { variables :: !(Map ParameterName HurlValueLiteral), + secrets :: !(Map ParameterName SecretValue) + } + deriving stock (Generic, Eq) + +instance Show ResolvedBindings where + show _ = "ResolvedBindings " + +data BindingIssue + = UnexpectedBinding !ParameterName !BindingSource + | BindingKindMismatch !ParameterName !ParameterKind !BindingSource + | MissingBinding !ParameterName + | MissingBindingEnvironment !ParameterName !Text !BindingSource + | InvalidBindingEnvironmentName !ParameterName !Text !BindingSource + | InvalidPlainBinding !ParameterName !BindingSource !HurlValueLiteralError + | InvalidSecretBinding !ParameterName !BindingSource !SecretValueError + | GeneratorFailure !ParameterName !Generator + | UnknownDeclaredParameter !ParameterName + deriving stock (Generic, Eq, Show) + +data BindingError + = BindingFileReadError !PropertyFileKind !FilePath + | BindingPropertyError !PropertyError + | BindingIssues !(NonEmpty BindingIssue) + deriving stock (Generic, Eq, Show) + +mkSecretValue :: Text -> Either SecretValueError SecretValue +mkSecretValue value = case mkHurlValueLiteral value of + Left ContainsLineBreakOrNul -> Left SecretContainsLineBreakOrNul + Left SurroundingWhitespace -> Left SecretHasSurroundingWhitespace + Right _ -> Right (SecretValue value) + +secretValueText :: SecretValue -> Text +secretValueText (SecretValue value) = value diff --git a/src/HurlWorkbench/Prelude.hs b/src/HurlWorkbench/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Prelude.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE PackageImports #-} + +-- | Project-wide prelude for hurl-workbench. It re-exports the small set of +-- types and functions that nearly every module needs, plus the lens +-- operators. +-- +-- It deliberately does not import @Data.Generics.Labels@: that orphan +-- @IsLabel@ instance would leak into every module. Modules that use +-- @#field@ access import @Data.Generics.Labels ()@ themselves. +module HurlWorkbench.Prelude + ( module X, + module Control.Lens, + ) +where + +import "base" Control.Monad as X (forM, forM_, unless, void, when) +import "base" Data.Foldable as X (for_, toList, traverse_) +import "base" Data.List.NonEmpty as X (NonEmpty (..), nonEmpty) +import "base" Data.Maybe as X (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) +import "base" Data.Traversable as X (for) +import "base" GHC.Generics as X (Generic) +import "containers" Data.Map.Strict as X (Map) +import "containers" Data.Set as X (Set) +import "lens" Control.Lens +import "text" Data.Text as X (Text) diff --git a/src/HurlWorkbench/Process/Run.hs b/src/HurlWorkbench/Process/Run.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Process/Run.hs @@ -0,0 +1,152 @@ +-- | Acquire a POSIX group ID before any waiter can reap the leader. All owned +-- output handles are caller-managed files, so termination never waits on a pipe. +module HurlWorkbench.Process.Run + ( OwnedProcess (..), + spawnGroup, + terminateGroup, + commandConfig, + runCommand, + CommandOutcome (..), + getExitCode, + waitExitCode, + getExitCodeSTM, + waitExitCodeSTM, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, asyncWithUnmask, wait) +import Control.Concurrent.STM +import Control.Exception (IOException, displayException, mask, onException, try) +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime, addUTCTime, getCurrentTime) +import HurlWorkbench.Prelude +import HurlWorkbench.Service.Resolve +import HurlWorkbench.Workspace.Types (ServiceName) +import System.Exit (ExitCode (..)) +import System.IO (Handle, IOMode (ReadWriteMode), withBinaryFile) +import System.IO.Error (isDoesNotExistError) +import System.Posix.Signals (nullSignal, sigKILL, sigTERM, signalProcessGroup) +import System.Posix.Types (ProcessID) +import System.Process qualified as Process +import System.Timeout qualified as Timeout + +data OwnedProcess = OwnedProcess + { processId :: !ProcessID, + completion :: !(TMVar (Either IOException ExitCode)), + reaper :: !(Async ()) + } + deriving stock (Generic) + +data CommandOutcome = CommandPassed | CommandFailed | CommandTimedOut | CommandStartFailed | CommandSkipped | CommandCancelled + deriving stock (Generic, Eq, Show) + +commandConfig :: ResolvedCommand -> Process.CreateProcess +commandConfig command = + (Process.proc (command ^. #executable) (command ^. #arguments)) + { Process.create_group = True, + Process.std_in = Process.NoStream, + Process.std_out = Process.NoStream, + Process.std_err = Process.NoStream, + Process.cwd = Just (command ^. #workingDirectory), + Process.env = Just (command ^. #environment) + } + +spawnGroup :: ServiceName -> Process.CreateProcess -> IO (Either ServiceError OwnedProcess) +spawnGroup name config = mask $ \_ -> do + -- createProcess_ leaves UseHandle inputs open in the parent. No pipe handles + -- or background waiter exist until the immutable group ID has been captured. + started <- try @IOException $ withBinaryFile "/dev/null" ReadWriteMode $ \nullHandle -> do + let output stream = case stream of Process.NoStream -> Process.UseHandle nullHandle; other -> other + (_, _, _, handle) <- + Process.createProcess_ + "owned process" + config + { Process.create_group = True, + Process.std_out = output (Process.std_out config), + Process.std_err = output (Process.std_err config) + } + pure handle + case started of + Left _ -> pure (Left (ServiceSpawnFailed "" "process launch failed")) + Right handle -> + Process.getPid handle >>= \case + Nothing -> do + _ <- Timeout.timeout 1000000 (Process.terminateProcess handle >> Process.waitForProcess handle) + pure (Left (ServiceProcessIdUnavailable name)) + Just pid -> do + completion <- newEmptyTMVarIO + reaper <- asyncWithUnmask $ \unmask -> do + result <- try @IOException (unmask (Process.waitForProcess handle)) + atomically (putTMVar completion result) + pure (Right (OwnedProcess pid completion reaper)) + +waitExitCodeSTM :: OwnedProcess -> STM ExitCode +waitExitCodeSTM owned = readTMVar (owned ^. #completion) >>= either throwSTM pure + +getExitCodeSTM :: OwnedProcess -> STM (Maybe ExitCode) +getExitCodeSTM owned = tryReadTMVar (owned ^. #completion) >>= traverse (either throwSTM pure) + +waitExitCode :: OwnedProcess -> IO ExitCode +waitExitCode = atomically . waitExitCodeSTM + +getExitCode :: OwnedProcess -> IO (Maybe ExitCode) +getExitCode = atomically . getExitCodeSTM + +-- | TERM and KILL address the group even if the leader has already exited. +-- The finite budget includes leader reaping and joining its one waiter. +terminateGroup :: ServiceName -> NominalDiffTime -> OwnedProcess -> IO (Either ServiceError ()) +terminateGroup name budget owned = do + attempted <- try @IOException terminate + pure (either (const (Left failure)) id attempted) + where + failure = ServiceShutdownFailed name (Just (owned ^. #processId)) "process group cleanup failed or timed out" + terminate = do + finished <- Timeout.timeout micros $ do + term <- signal sigTERM + began <- getCurrentTime + gone <- waitGroup (addUTCTime (budget / 2) began) + killed <- if gone then pure "" else signal sigKILL + _ <- waitExitCode owned + wait (owned ^. #reaper) + pure (term <> killed) + pure $ case finished of + Just "" -> Right () + Just message -> Left (ServiceShutdownFailed name (Just (owned ^. #processId)) message) + Nothing -> Left failure + micros = max 1 (floor (budget * 1000000)) + signal sig = + try @IOException (signalProcessGroup sig (owned ^. #processId)) >>= \case + Right () -> pure "" + Left err | isDoesNotExistError err -> pure "" + Left err -> do + -- Darwin can report EPERM while an empty group is disappearing. Only + -- suppress the failed signal once ESRCH positively confirms absence; + -- a group that still exists or remains uncertain is a cleanup failure. + vanished <- Timeout.timeout (max 1 (min 10000 (micros `div` 4))) confirmAbsent + pure $ if vanished == Just True then "" else (if sig == sigTERM then "SIGTERM: " else "SIGKILL: ") <> Text.pack (displayException err) + confirmAbsent = + try @IOException (signalProcessGroup nullSignal (owned ^. #processId)) >>= \case + Left err | isDoesNotExistError err -> pure True + Left _ -> threadDelay 1000 >> confirmAbsent + Right () -> threadDelay 1000 >> confirmAbsent + waitGroup deadline = do + alive <- try @IOException (signalProcessGroup nullSignal (owned ^. #processId)) + now <- getCurrentTime + case alive of + Left err | isDoesNotExistError err -> pure True + Left _ -> pure False + Right () | now >= deadline -> pure False + Right () -> threadDelay 10000 >> waitGroup deadline + +runCommand :: ServiceName -> NominalDiffTime -> ResolvedCommand -> Handle -> Handle -> IO (CommandOutcome, Maybe ServiceError) +runCommand name budget command stdout stderr = mask $ \restore -> do + spawnGroup name (commandConfig command) {Process.std_out = Process.UseHandle stdout, Process.std_err = Process.UseHandle stderr} >>= \case + Left _ -> pure (CommandStartFailed, Nothing) + Right owned -> do + let cleanupBudget = min 1 (budget / 4) + cleanup = terminateGroup name cleanupBudget owned + result <- restore (Timeout.timeout (max 1 (floor ((budget - cleanupBudget) * 1000000))) (waitExitCode owned)) `onException` void cleanup + shutdown <- cleanup + pure (case result of Just ExitSuccess -> CommandPassed; Just _ -> CommandFailed; Nothing -> CommandTimedOut, either Just (const Nothing) shutdown) diff --git a/src/HurlWorkbench/Run/Artifact.hs b/src/HurlWorkbench/Run/Artifact.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Run/Artifact.hs @@ -0,0 +1,154 @@ +-- | Collision-checked, owner-only response artifacts for batch client runs. +module HurlWorkbench.Run.Artifact + ( ArtifactError (..), + responseArtifactPath, + prepareResponseArtifacts, + renderArtifactError, + ) +where + +import Control.Exception (IOException, displayException, try) +import Control.Monad (foldM) +import Data.Bits ((.&.)) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import HurlWorkbench.Prelude +import HurlWorkbench.Run.FileRoot +import HurlWorkbench.Run.Prepare (PreparedRun) +import System.Directory + ( createDirectory, + createDirectoryIfMissing, + doesDirectoryExist, + doesPathExist, + pathIsSymbolicLink, + ) +import System.FilePath (addExtension, isAbsolute, splitDirectories, takeDirectory, ()) +import System.IO (hClose) +import System.Posix.Files + ( accessModes, + fileMode, + getFileStatus, + ownerExecuteMode, + ownerReadMode, + ownerWriteMode, + setFileMode, + unionFileModes, + ) +import System.Posix.IO (OpenFileFlags (..), OpenMode (WriteOnly), defaultFileFlags, fdToHandle, openFd) +import System.Posix.Types (FileMode) + +data ArtifactError + = ArtifactFileRootConflict !FileRootError + | InvalidArtifactStem !FilePath + | DuplicateArtifactTarget !FilePath + | ArtifactAlreadyExists !FilePath + | ArtifactPathIsSymbolicLink !FilePath + | ArtifactTargetIsDirectory !FilePath + | ArtifactIoError !FilePath !Text + deriving stock (Generic, Eq, Show) + +responseArtifactPath :: FilePath -> PreparedRun -> Either ArtifactError FilePath +responseArtifactPath outputDirectory prepared + | not (validStem stem) = Left (InvalidArtifactStem stem) + | otherwise = Right (addExtension (outputDirectory stem) "response") + where + stem = prepared ^. #artifactStem + +prepareResponseArtifacts :: FilePath -> Bool -> NonEmpty PreparedRun -> IO (Either (NonEmpty ArtifactError) (NonEmpty FilePath)) +prepareResponseArtifacts outputDirectory overwrite prepared = + case traverse (responseArtifactPath outputDirectory) prepared of + Left err -> pure (Left (err :| [])) + Right targets -> do + rootChecks <- traverse (\run -> checkFileRootOutputs (run ^. #fileRoot) [outputDirectory]) prepared + existingIssues <- fmap concat (traverse existingIssue (NonEmpty.toList targets)) + let duplicateIssues = + [ DuplicateArtifactTarget path + | (path, count) <- Map.toAscList (Map.fromListWith (+) [(path, 1 :: Int) | path <- NonEmpty.toList targets]), + count > 1 + ] + preflightIssues = [ArtifactFileRootConflict err | Left err <- toList rootChecks] <> duplicateIssues <> existingIssues + case nonEmpty preflightIssues of + Just issues -> pure (Left issues) + Nothing -> do + preparedTargets <- try @IOException (prepareAll targets) + pure $ case preparedTargets of + Left err -> Left (ArtifactIoError outputDirectory (Text.pack (displayException err)) :| []) + Right () -> Right targets + where + existingIssue path = do + exists <- doesPathExist path + symbolic <- if exists then pathIsSymbolicLink path else pure False + directory <- if exists && not symbolic then doesDirectoryExist path else pure False + pure $ + [ArtifactPathIsSymbolicLink path | symbolic] + <> [ArtifactTargetIsDirectory path | directory] + <> [ArtifactAlreadyExists path | exists && not symbolic && not directory && not overwrite] + + prepareAll targets = do + createDirectoryIfMissing True outputDirectory + setFileMode outputDirectory secureDirectoryMode + verifyMode secureDirectoryMode outputDirectory + traverse_ (prepareTarget outputDirectory) targets + +prepareTarget :: FilePath -> FilePath -> IO () +prepareTarget outputDirectory target = do + let relativeDirectories = filter (not . null) (splitDirectories (dropPrefix outputDirectory target)) + _ <- foldM ensureDirectory outputDirectory relativeDirectories + handle <- fdToHandle =<< openFd target WriteOnly defaultFileFlags {creat = Just secureFileMode, trunc = True, nofollow = True} + hClose handle + setFileMode target secureFileMode + verifyMode secureFileMode target + +ensureDirectory :: FilePath -> FilePath -> IO FilePath +ensureDirectory parent component = do + let path = parent component + exists <- doesPathExist path + if exists + then do + symbolic <- pathIsSymbolicLink path + when symbolic (ioError (userError ("artifact directory is a symbolic link: " <> path))) + directory <- doesDirectoryExist path + unless directory (ioError (userError ("artifact parent is not a directory: " <> path))) + else createDirectory path + setFileMode path secureDirectoryMode + verifyMode secureDirectoryMode path + pure path + +dropPrefix :: FilePath -> FilePath -> FilePath +dropPrefix outputDirectory target = + let rootParts = splitDirectories outputDirectory + targetParts = splitDirectories (takeDirectory target) + in foldl' () "" (drop (length rootParts) targetParts) + +validStem :: FilePath -> Bool +validStem stem = + not (null stem) + && not (isAbsolute stem) + && all validComponent (splitDirectories stem) + where + validComponent component = not (null component) && component /= "." && component /= ".." + +verifyMode :: FileMode -> FilePath -> IO () +verifyMode expected path = do + actual <- (.&. accessModes) . fileMode <$> getFileStatus path + unless (actual == expected) (ioError (userError ("insecure permissions on " <> path))) + +secureFileMode :: FileMode +secureFileMode = ownerReadMode `unionFileModes` ownerWriteMode + +secureDirectoryMode :: FileMode +secureDirectoryMode = secureFileMode `unionFileModes` ownerExecuteMode + +renderArtifactError :: ArtifactError -> Text +renderArtifactError = \case + ArtifactFileRootConflict err -> renderFileRootError err + InvalidArtifactStem stem -> "invalid generated artifact stem " <> quote stem + DuplicateArtifactTarget path -> "more than one case resolves to artifact " <> quote path + ArtifactAlreadyExists path -> "artifact already exists; use --overwrite to replace " <> quote path + ArtifactPathIsSymbolicLink path -> "artifact path must not be a symbolic link: " <> quote path + ArtifactTargetIsDirectory path -> "artifact target is a directory: " <> quote path + ArtifactIoError path message -> "could not prepare artifacts under " <> quote path <> ": " <> message + where + quote = ("\"" <>) . (<> "\"") . Text.pack diff --git a/src/HurlWorkbench/Run/Batch.hs b/src/HurlWorkbench/Run/Batch.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Run/Batch.hs @@ -0,0 +1,200 @@ +-- | Batch-ready Hurl requests. Bounded scheduling and result aggregation are +-- added by EP-4's second milestone; preparation already targets this type. +module HurlWorkbench.Run.Batch + ( PositiveInt, + positiveIntValue, + BatchOptionError (..), + mkPositiveInt, + BatchOptions (..), + BatchCase (..), + SkipReason (..), + CaseOutcome (..), + CaseResult (..), + BatchResult (..), + runBatch, + runBatchObserved, + ) +where + +import Control.Concurrent.Async (replicateConcurrently_) +import Control.Concurrent.STM + ( TQueue, + TVar, + atomically, + modifyTVar', + newTQueue, + newTVar, + readTVar, + readTVarIO, + tryReadTQueue, + writeTQueue, + writeTVar, + ) +import Control.Exception (mask) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Time.Clock (NominalDiffTime) +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Prelude +import System.Exit (ExitCode (..)) + +newtype PositiveInt = PositiveInt Int + deriving stock (Generic, Eq, Ord, Show) + +positiveIntValue :: PositiveInt -> Int +positiveIntValue (PositiveInt value) = value + +data BatchOptionError = NonPositiveJobs !Int + deriving stock (Generic, Eq, Show) + +mkPositiveInt :: Int -> Either BatchOptionError PositiveInt +mkPositiveInt value + | value > 0 = Right (PositiveInt value) + | otherwise = Left (NonPositiveJobs value) + +data BatchOptions = BatchOptions + { jobs :: !PositiveInt, + failFast :: !Bool + } + deriving stock (Generic, Eq, Show) + +data BatchCase = BatchCase + { name :: !Text, + artifactStem :: !FilePath, + request :: !RunRequest + } + deriving stock (Generic, Eq) + +instance Show BatchCase where + show batchCase = "BatchCase " <> show (batchCase ^. #name) <> " " + +data SkipReason + = FailFastTriggered + | BatchPrerequisiteFailed + | BatchCancelled + deriving stock (Generic, Eq, Show) + +data CaseOutcome + = CasePassed + | CaseFailed !ExitCode + | CaseStartFailed !RunStartError + | CaseSkipped !SkipReason + deriving stock (Generic, Eq, Show) + +data CaseResult = CaseResult + { name :: !Text, + outcome :: !CaseOutcome, + elapsed :: !(Maybe NominalDiffTime), + outputPath :: !(Maybe FilePath), + capturedOutput :: !(Maybe CapturedRunOutput) + } + deriving stock (Generic, Eq, Show) + +data BatchResult = BatchResult + { cases :: !(NonEmpty CaseResult), + selectedExitCode :: !ExitCode + } + deriving stock (Generic, Eq, Show) + +runBatch :: HurlRunner -> BatchOptions -> NonEmpty BatchCase -> IO BatchResult +runBatch runner options batchCases = runBatchObserved runner options batchCases (\_index _result -> pure ()) + +-- | Run a batch while publishing each completed case with its declaration +-- index. The observer lets orchestration retain completed outcomes if a +-- prerequisite failure asynchronously cancels the batch. +runBatchObserved :: HurlRunner -> BatchOptions -> NonEmpty BatchCase -> (Int -> CaseResult -> IO ()) -> IO BatchResult +runBatchObserved runner options batchCases observe = do + queue <- atomically newTQueue + results <- atomically (newTVar Map.empty) + stopped <- atomically (newTVar False) + let indexedCases = zip [0 ..] (NonEmpty.toList batchCases) + workerCount = min (positiveIntValue (options ^. #jobs)) (length indexedCases) + atomically (traverse_ (writeTQueue queue) indexedCases) + replicateConcurrently_ workerCount (worker queue results stopped) + completed <- readTVarIO results + let ordered = NonEmpty.fromList (map (caseResult completed) indexedCases) + pure + BatchResult + { cases = ordered, + selectedExitCode = selectExitCode ordered + } + where + worker queue results stopped = + nextWork queue stopped >>= \case + Nothing -> pure () + Just (caseIndex, batchCase) -> do + mask $ \restore -> do + result <- restore (executeCase runner batchCase) + atomically $ do + modifyTVar' results (Map.insert caseIndex result) + when (options ^. #failFast && caseFailed result) (writeTVar stopped True) + observe caseIndex result + worker queue results stopped + + nextWork :: TQueue (Int, BatchCase) -> TVar Bool -> IO (Maybe (Int, BatchCase)) + nextWork queue stopped = atomically $ do + shouldStop <- readTVar stopped + if shouldStop then pure Nothing else tryReadTQueue queue + + caseResult completed (caseIndex, batchCase) = + Map.findWithDefault (skippedCase batchCase FailFastTriggered) caseIndex completed + +executeCase :: HurlRunner -> BatchCase -> IO CaseResult +executeCase runner batchCase = do + executed <- runHurl runner (batchCase ^. #request) + pure $ case executed of + Left err -> + CaseResult + { name = batchCase ^. #name, + outcome = CaseStartFailed err, + elapsed = Nothing, + outputPath = requestOutputPath (batchCase ^. #request), + capturedOutput = Nothing + } + Right result -> + CaseResult + { name = batchCase ^. #name, + outcome = case result ^. #exitCode of + ExitSuccess -> CasePassed + failed -> CaseFailed failed, + elapsed = Just (result ^. #elapsed), + outputPath = requestOutputPath (batchCase ^. #request), + capturedOutput = result ^. #capturedOutput + } + +skippedCase :: BatchCase -> SkipReason -> CaseResult +skippedCase batchCase reason = + CaseResult + { name = batchCase ^. #name, + outcome = CaseSkipped reason, + elapsed = Nothing, + outputPath = requestOutputPath (batchCase ^. #request), + capturedOutput = Nothing + } + +requestOutputPath :: RunRequest -> Maybe FilePath +requestOutputPath request = case request ^. #outputPolicy of + ResponseFile path -> Just path + _ -> Nothing + +caseFailed :: CaseResult -> Bool +caseFailed result = case result ^. #outcome of + CasePassed -> False + _ -> True + +selectExitCode :: NonEmpty CaseResult -> ExitCode +selectExitCode results = + fromMaybe fallback (firstFailure (NonEmpty.toList results)) + where + fallback + | all (not . caseFailed) results = ExitSuccess + | otherwise = ExitFailure 3 + + firstFailure = \case + [] -> Nothing + result : remaining -> case result ^. #outcome of + CaseFailed exitCode -> Just exitCode + CaseStartFailed _ -> Just (ExitFailure 3) + CasePassed -> firstFailure remaining + CaseSkipped _ -> firstFailure remaining diff --git a/src/HurlWorkbench/Run/FileRoot.hs b/src/HurlWorkbench/Run/FileRoot.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Run/FileRoot.hs @@ -0,0 +1,98 @@ +-- | Caller-owned Hurl body directories. Validation uses filesystem operations +-- under the effective identity; no mode-bit inference or process-global cwd. +module HurlWorkbench.Run.FileRoot + ( FileRoot, + FileRootError, + validateFileRoot, + fileRootPath, + checkFileRootOutputs, + selectSuiteFileRoot, + renderFileRootError, + ) +where + +import Control.Exception (IOException, try) +import Data.Generics.Labels () +import Data.List (isPrefixOf) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import System.Directory (canonicalizePath, listDirectory) +import System.FilePath (isAbsolute, splitDirectories, ()) +import System.Posix.Files (getFileStatus, isDirectory) + +-- The flag records explicit selection, which requires disjoint output trees. +data FileRoot = FileRoot !FilePath !Bool + deriving stock (Generic, Eq) + +instance Show FileRoot where + show _ = "FileRoot " + +data FileRootError = InvalidFileRoot | FileRootBindingFailed !BindingError | FileRootOutputOverlap | FileRootOutputUnreadable + deriving stock (Generic, Eq) + +instance Show FileRootError where + show = Text.unpack . renderFileRootError + +-- | Nothing selects the supplied workspace base. Explicit relative paths use +-- the supplied invocation or workspace base, according to the caller. +validateFileRoot :: FilePath -> Maybe FilePath -> IO (Either FileRootError FileRoot) +validateFileRoot base requested = do + attempted <- try @IOException $ do + let selected = fromMaybe base requested + absolute = case requested of + Nothing -> base + Just _ -> if isAbsolute selected then selected else base selected + when (maybe False null requested) (ioError (userError "empty file root")) + canonical <- canonicalizePath absolute + -- stat of root/. needs directory search access, and listing needs read + -- access. Both use the effective identity, including ACLs and privileges. + status <- getFileStatus (canonical ".") + unless (isDirectory status) (ioError (userError "file root is not a directory")) + _ <- listDirectory canonical + pure (FileRoot canonical (isJust requested)) + pure (either (const (Left InvalidFileRoot)) Right attempted) + +fileRootPath :: FileRoot -> FilePath +fileRootPath (FileRoot path _) = path + +-- | Canonicalize existing parent components even for not-yet-created outputs. +-- This check must run before report reservation, overwrite, or chmod. +checkFileRootOutputs :: FileRoot -> [FilePath] -> IO (Either FileRootError ()) +checkFileRootOutputs (FileRoot _ False) _ = pure (Right ()) +checkFileRootOutputs (FileRoot root True) targets = do + inspected <- try @IOException (traverse canonicalizePath targets) + pure $ case inspected of + Left _ -> Left FileRootOutputUnreadable + Right paths + | any overlaps paths -> Left FileRootOutputOverlap + | otherwise -> Right () + where + overlaps path = let a = splitDirectories root; b = splitDirectories path in a `isPrefixOf` b || b `isPrefixOf` a + +-- | Only suite-wide bindings participate. A typed CLI selection wins without +-- resolving the shadowed parameter. Static workspace validation checks its kind. +selectSuiteFileRoot :: ValidatedWorkspace -> SuiteName -> BindingInput -> Maybe FileRoot -> IO (Either FileRootError FileRoot) +selectSuiteFileRoot workspace name input selected = case selected of + Just root -> pure (Right root) + Nothing -> case lookupSuite name workspace >>= view #fileRootParameter of + Nothing -> validateFileRoot base Nothing + Just parameter -> + resolveParameterSubset workspace (Set.singleton parameter) input >>= \case + Left err -> pure (Left (FileRootBindingFailed err)) + Right bindings -> case Map.lookup parameter (bindings ^. #variables) of + Nothing -> pure (Left InvalidFileRoot) + Just value -> validateFileRoot base (Just (Text.unpack (hurlValueLiteralText value))) + where + base = unWorkspaceRoot (validatedRoot workspace) + +renderFileRootError :: FileRootError -> Text +renderFileRootError = \case + InvalidFileRoot -> "--file-root must select an existing readable, searchable directory" + FileRootBindingFailed err -> "suite file-root parameter: " <> renderBindingError err + FileRootOutputOverlap -> "file-root input and output trees must be disjoint" + FileRootOutputUnreadable -> "could not inspect file-root output layout" diff --git a/src/HurlWorkbench/Run/Prepare.hs b/src/HurlWorkbench/Run/Prepare.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Run/Prepare.hs @@ -0,0 +1,185 @@ +-- | Convert pure selections into fully rendered, syntax-checked, bound runs +-- before any Hurl process starts. +module HurlWorkbench.Run.Prepare + ( PreparedRun (..), + PreparationError (..), + prepareSelection, + prepareSelectionForSuite, + prepareSelectionForSuiteWith, + prepareSelectionWith, + prepareSelectionWithGenerator, + prepareExpandedForSuiteWith, + prepareSelectionAtFileRootWith, + prepareSelectionForSuiteAtFileRootWith, + prepareExpandedForSuiteAtFileRootWith, + buildBatchCase, + renderPreparationError, + ) +where + +import Control.Monad (foldM) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Parameter.Generate (GeneratorEnvironment) +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Batch +import HurlWorkbench.Run.FileRoot +import HurlWorkbench.Run.Selection +import HurlWorkbench.Workflow.Render +import HurlWorkbench.Workspace.Context (ValidatedWorkspace, validatedRoot) +import HurlWorkbench.Workspace.Types (Workflow, WorkspaceRoot (..)) + +data PreparedRun = PreparedRun + { displayName :: !Text, + artifactStem :: !FilePath, + safety :: !SafetyDisposition, + renderedWorkflow :: !RenderedWorkflow, + bindings :: !ResolvedBindings, + fileRoot :: !FileRoot, + options :: !HurlOptions + } + deriving stock (Generic, Eq, Show) + +data PreparationError + = RunFileRootFailed !FileRootError + | SelectionPreparationFailed !SelectionError + | RunRenderFailed !Text !RenderError + | RunFormatFailed !Text !HurlfmtError + | RunBindingFailed !Text !BindingError + deriving stock (Generic, Eq, Show) + +data CachedWorkflow + = CachedRenderFailure !RenderError + | CachedFormatFailure !HurlfmtError + | CachedRendered !RenderedWorkflow + +prepareSelection :: HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelection = prepareSelectionWith validateRenderedWorkflow + +-- | Prepare one selection from suite-wide runtime input. Bindings intended +-- for other selections in the same suite are ignored. +prepareSelectionForSuite :: HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionForSuite = prepareSelectionUsing resolveWorkflowBindingSubsetWithLayers validateRenderedWorkflow + +prepareSelectionForSuiteWith :: (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionForSuiteWith = prepareSelectionUsing resolveWorkflowBindingSubsetWithLayers + +prepareSelectionWith :: (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionWith = prepareSelectionUsing resolveWorkflowBindingsWithLayers + +-- | Deterministic preflight with an injected clock and entropy provider. +prepareSelectionWithGenerator :: GeneratorEnvironment -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionWithGenerator env = prepareSelectionUsing (\validated workflow -> resolveParametersWithLayersAndGenerator env validated (Set.fromList (workflow ^. #parameters))) + +prepareSelectionUsing :: (ValidatedWorkspace -> Workflow -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings)) -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionUsing resolveBindings validateRendered capabilities validated input hurlOptions selection = + case resolveSelection validated selection of + Left err -> pure (Left (SelectionPreparationFailed err :| [])) + Right expanded -> withDefaultRoot validated $ \root -> prepareExpandedUsing resolveBindings root validateRendered capabilities validated hurlOptions (fmap (,input) expanded) + +prepareExpandedForSuiteWith :: (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> HurlOptions -> NonEmpty (ExpandedRun, BindingInput) -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareExpandedForSuiteWith validateRendered capabilities validated options runs = + withDefaultRoot validated $ \root -> prepareExpandedForSuiteAtFileRootWith root validateRendered capabilities validated options runs + +withDefaultRoot :: ValidatedWorkspace -> (FileRoot -> IO (Either (NonEmpty PreparationError) a)) -> IO (Either (NonEmpty PreparationError) a) +withDefaultRoot validated action = validateFileRoot (unWorkspaceRoot (validatedRoot validated)) Nothing >>= either (pure . Left . (:| []) . RunFileRootFailed) action + +prepareSelectionAtFileRootWith :: FileRoot -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionAtFileRootWith = prepareSelectionAtFileRootUsing resolveWorkflowBindingsWithLayers + +prepareSelectionForSuiteAtFileRootWith :: FileRoot -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionForSuiteAtFileRootWith = prepareSelectionAtFileRootUsing resolveWorkflowBindingSubsetWithLayers + +prepareSelectionAtFileRootUsing :: (ValidatedWorkspace -> Workflow -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings)) -> FileRoot -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> BindingInput -> HurlOptions -> RunSelection -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareSelectionAtFileRootUsing resolveBindings root validateRendered capabilities validated input options selection = + case resolveSelection validated selection of + Left err -> pure (Left (SelectionPreparationFailed err :| [])) + Right expanded -> prepareExpandedUsing resolveBindings root validateRendered capabilities validated options (fmap (,input) expanded) + +prepareExpandedForSuiteAtFileRootWith :: FileRoot -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> HurlOptions -> NonEmpty (ExpandedRun, BindingInput) -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareExpandedForSuiteAtFileRootWith = prepareExpandedUsing resolveWorkflowBindingSubsetWithLayers + +prepareExpandedUsing :: (ValidatedWorkspace -> Workflow -> [BindingLayer] -> BindingInput -> IO (Either BindingError ResolvedBindings)) -> FileRoot -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> HurlOptions -> NonEmpty (ExpandedRun, BindingInput) -> IO (Either (NonEmpty PreparationError) (NonEmpty PreparedRun)) +prepareExpandedUsing resolveBindings root validateRendered capabilities validated hurlOptions assignedRuns = do + (_cache, errors, prepared) <- foldM prepareOne (Map.empty, [], []) (NonEmpty.toList assignedRuns) + pure $ case (nonEmpty (reverse errors), nonEmpty (reverse prepared)) of + (Just problems, _) -> Left problems + (Nothing, Just ready) -> Right ready + (Nothing, Nothing) -> error "prepareExpandedUsing: impossible empty expanded selection" + where + prepareOne (cache, errors, prepared) (expanded, input) = do + (nextCache, cached) <- cachedWorkflow cache expanded + case cached of + CachedRenderFailure err -> pure (nextCache, RunRenderFailed (expanded ^. #displayName) err : errors, prepared) + CachedFormatFailure err -> pure (nextCache, RunFormatFailed (expanded ^. #displayName) err : errors, prepared) + CachedRendered rendered -> do + resolved <- + resolveBindings + validated + (expanded ^. #workflow . #workflow) + (expanded ^. #bindingLayers) + input + pure $ case resolved of + Left err -> (nextCache, RunBindingFailed (expanded ^. #displayName) err : errors, prepared) + Right bindings -> + ( nextCache, + errors, + PreparedRun + { displayName = expanded ^. #displayName, + artifactStem = expanded ^. #artifactStem, + safety = expanded ^. #safety, + renderedWorkflow = rendered, + bindings, + fileRoot = root, + options = hurlOptions + } + : prepared + ) + + cachedWorkflow cache expanded = + let workflowName = expanded ^. #workflow . #workflow . #name + in case Map.lookup workflowName cache of + Just cached -> pure (cache, cached) + Nothing -> do + cached <- renderAndValidate expanded + pure (Map.insert workflowName cached cache, cached) + + renderAndValidate expanded = + renderWorkflow (expanded ^. #workflow) >>= \case + Left err -> pure (CachedRenderFailure err) + Right rendered -> + validateRendered capabilities rendered <&> \case + Left err -> CachedFormatFailure err + Right () -> CachedRendered rendered + +buildBatchCase :: HurlRunMode -> RunOutputPolicy -> [HurlReportTarget] -> PreparedRun -> BatchCase +buildBatchCase runMode output reports prepared = + BatchCase + { name = prepared ^. #displayName, + artifactStem = prepared ^. #artifactStem, + request = + RunRequest + { renderedWorkflow = prepared ^. #renderedWorkflow, + fileRoot = prepared ^. #fileRoot, + mode = runMode, + bindings = prepared ^. #bindings, + options = prepared ^. #options, + outputPolicy = output, + reportTargets = reports + } + } + +renderPreparationError :: PreparationError -> Text +renderPreparationError = \case + RunFileRootFailed err -> renderFileRootError err + SelectionPreparationFailed err -> renderSelectionError err + RunRenderFailed name err -> prefix name <> renderRenderError err + RunFormatFailed name err -> prefix name <> renderHurlfmtError err + RunBindingFailed name err -> prefix name <> renderBindingError err + where + prefix name = "run \"" <> name <> "\": " diff --git a/src/HurlWorkbench/Run/Selection.hs b/src/HurlWorkbench/Run/Selection.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Run/Selection.hs @@ -0,0 +1,169 @@ +-- | Pure expansion of workflow, recipe, and matrix selections. Each expanded +-- run names one resolved workflow plus ordered committed plain bindings. +module HurlWorkbench.Run.Selection + ( RunSelection (..), + SafetyDisposition (..), + BindingLayer (..), + ExpandedRun (..), + SelectionError (..), + resolveSelection, + renderSelectionError, + ) +where + +import Data.Bifunctor (first) +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import HurlWorkbench.Parameter.Resolve (BindingLayer (..), BindingSource (..)) +import HurlWorkbench.Prelude +import HurlWorkbench.Workflow.Resolve +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import System.FilePath (()) + +data RunSelection + = SelectWorkflow !WorkflowName + | SelectRecipe !RecipeName + | SelectMatrix !MatrixName + deriving stock (Generic, Eq, Show) + +data SafetyDisposition + = Classified !Safety + | UnclassifiedWorkflow + deriving stock (Generic, Eq, Show) + +data ExpandedRun = ExpandedRun + { displayName :: !Text, + workflow :: !ResolvedWorkflow, + safety :: !SafetyDisposition, + bindingLayers :: ![BindingLayer], + artifactStem :: !FilePath + } + deriving stock (Generic, Eq, Show) + +data SelectionError + = SelectedWorkflowInvalid !WorkflowError + | SelectedRecipeNotFound !RecipeName + | SelectedMatrixNotFound !MatrixName + | RecipeWorkflowNotFound !RecipeName !WorkflowName + | MatrixRecipeNotFound !MatrixName !RecipeName + | MatrixHasNoCases !MatrixName + | DuplicateMatrixCase !MatrixName !MatrixCaseName + | DuplicateCommittedBinding !Text !ParameterName + | UndeclaredCommittedBinding !Text !WorkflowName !ParameterName + | SecretCommittedBinding !Text !ParameterName + deriving stock (Generic, Eq, Show) + +resolveSelection :: ValidatedWorkspace -> RunSelection -> Either SelectionError (NonEmpty ExpandedRun) +resolveSelection validated = \case + SelectWorkflow name -> do + resolved <- first SelectedWorkflowInvalid (resolveWorkflow validated name) + pure + ( ExpandedRun + { displayName = unWorkflowName name, + workflow = resolved, + safety = UnclassifiedWorkflow, + bindingLayers = [], + artifactStem = Text.unpack (unWorkflowName name) + } + :| [] + ) + SelectRecipe name -> do + recipe <- maybe (Left (SelectedRecipeNotFound name)) Right (lookupRecipe name validated) + expanded <- expandRecipe validated recipe + pure (expanded :| []) + SelectMatrix name -> do + matrix <- maybe (Left (SelectedMatrixNotFound name)) Right (lookupMatrix name validated) + recipe <- maybe (Left (MatrixRecipeNotFound name (matrix ^. #recipe))) Right (lookupRecipe (matrix ^. #recipe) validated) + let duplicateCase = firstDuplicate (map (view #name) (matrix ^. #cases)) + maybe (pure ()) (Left . DuplicateMatrixCase name) duplicateCase + cases <- maybe (Left (MatrixHasNoCases name)) Right (nonEmpty (matrix ^. #cases)) + base <- expandRecipe validated recipe + traverse (expandCase validated matrix base) cases + +expandRecipe :: ValidatedWorkspace -> Recipe -> Either SelectionError ExpandedRun +expandRecipe validated recipe = do + resolved <- first (const (RecipeWorkflowNotFound (recipe ^. #name) (recipe ^. #workflow))) (resolveWorkflow validated (recipe ^. #workflow)) + layer <- bindingLayer validated resolved (recipeLabel recipe) (recipe ^. #bindings) + pure + ExpandedRun + { displayName = unRecipeName (recipe ^. #name), + workflow = resolved, + safety = Classified (recipe ^. #safety), + bindingLayers = [layer], + artifactStem = Text.unpack (unRecipeName (recipe ^. #name)) + } + +expandCase :: ValidatedWorkspace -> Matrix -> ExpandedRun -> MatrixCase -> Either SelectionError ExpandedRun +expandCase validated matrix base matrixCase = do + layer <- bindingLayer validated (base ^. #workflow) (matrixCaseLabel matrix matrixCase) (matrixCase ^. #bindings) + let matrixName = unMatrixName (matrix ^. #name) + caseName = unMatrixCaseName (matrixCase ^. #name) + pure + base + { displayName = matrixName <> "/" <> caseName, + bindingLayers = layer : base ^. #bindingLayers, + artifactStem = Text.unpack matrixName Text.unpack caseName + } + +bindingLayer :: ValidatedWorkspace -> ResolvedWorkflow -> Text -> [Binding] -> Either SelectionError BindingLayer +bindingLayer validated resolved label bindings = do + let duplicate = firstDuplicate (map (view #parameter) bindings) + maybe (pure ()) (Left . DuplicateCommittedBinding label) duplicate + traverse_ validateBinding bindings + pure + BindingLayer + { source = CommittedBinding label, + values = Map.fromList [(binding ^. #parameter, binding ^. #value) | binding <- bindings] + } + where + definition = resolved ^. #workflow + declared = Set.fromList (definition ^. #parameters) + validateBinding binding + | (binding ^. #parameter) `Set.notMember` declared = + Left (UndeclaredCommittedBinding label (definition ^. #name) (binding ^. #parameter)) + | otherwise = case lookupParameter (binding ^. #parameter) validated of + Just parameter | parameter ^. #kind == Secret -> Left (SecretCommittedBinding label (binding ^. #parameter)) + _ -> Right () + +firstDuplicate :: (Ord value) => [value] -> Maybe value +firstDuplicate values = go Set.empty values + where + go _ [] = Nothing + go seen (value : remaining) + | value `Set.member` seen = Just value + | otherwise = go (Set.insert value seen) remaining + +recipeLabel :: Recipe -> Text +recipeLabel recipe = "recipe " <> quote (unRecipeName (recipe ^. #name)) + +matrixCaseLabel :: Matrix -> MatrixCase -> Text +matrixCaseLabel matrix matrixCase = + "matrix " + <> quote (unMatrixName (matrix ^. #name)) + <> " case " + <> quote (unMatrixCaseName (matrixCase ^. #name)) + +renderSelectionError :: SelectionError -> Text +renderSelectionError = \case + SelectedWorkflowInvalid err -> renderWorkflowError err + SelectedRecipeNotFound name -> "unknown recipe " <> quote (unRecipeName name) + SelectedMatrixNotFound name -> "unknown matrix " <> quote (unMatrixName name) + RecipeWorkflowNotFound recipe workflow -> + "recipe " <> quote (unRecipeName recipe) <> " refers to unknown workflow " <> quote (unWorkflowName workflow) + MatrixRecipeNotFound matrix recipe -> + "matrix " <> quote (unMatrixName matrix) <> " refers to unknown recipe " <> quote (unRecipeName recipe) + MatrixHasNoCases matrix -> "matrix " <> quote (unMatrixName matrix) <> " has no cases" + DuplicateMatrixCase matrix matrixCase -> + "matrix " <> quote (unMatrixName matrix) <> " declares case " <> quote (unMatrixCaseName matrixCase) <> " more than once" + DuplicateCommittedBinding label parameter -> label <> " binds parameter " <> quotedParameter parameter <> " more than once" + UndeclaredCommittedBinding label workflow parameter -> + label <> " binds parameter " <> quotedParameter parameter <> " which workflow " <> quote (unWorkflowName workflow) <> " does not declare" + SecretCommittedBinding label parameter -> label <> " commits a value for secret parameter " <> quotedParameter parameter + where + quotedParameter = quote . unParameterName + +quote :: Text -> Text +quote value = "\"" <> value <> "\"" diff --git a/src/HurlWorkbench/Service/Environment.hs b/src/HurlWorkbench/Service/Environment.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Service/Environment.hs @@ -0,0 +1,22 @@ +-- | One environment selection contract for managed command consumers. +module HurlWorkbench.Service.Environment (selectEnvironment) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Types (EnvironmentPolicy (..)) + +-- | Selected inherited names are required even when explicitly overridden. +-- Empty values count as present. No implicit platform variables are introduced. +selectEnvironment :: EnvironmentPolicy -> [(String, String)] -> [(String, String)] -> Either [Text] [(String, String)] +selectEnvironment policy ambient overrides = + case policy of + Inherit -> Right (overlay parent) + Clean names -> + let missing = filter (\name -> Map.notMember (Text.unpack name) parent) names + in if null missing + then Right (overlay (Map.filterWithKey (\key _ -> Text.pack key `elem` names) parent)) + else Left missing + where + parent = Map.fromList ambient + overlay selected = Map.toAscList (Map.fromList overrides `Map.union` selected) diff --git a/src/HurlWorkbench/Service/Group.hs b/src/HurlWorkbench/Service/Group.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Service/Group.hs @@ -0,0 +1,144 @@ +-- | Dynamic group membership is the monitor generation. Removing an entry and +-- observing its exit happen in one STM transaction; no stale monitor can target +-- a replacement acquired by Restart. +module HurlWorkbench.Service.Group + ( ServiceGroup, + LifecycleOutcome (..), + newServiceGroup, + startNamed, + startNamedObserved, + stopNamed, + applyServiceStep, + applyServiceStepObserved, + watchServices, + cleanupServices, + ) +where + +import Control.Concurrent.Async (race) +import Control.Concurrent.STM +import Control.Exception (mask) +import Data.Generics.Labels () +import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) +import HurlWorkbench.Prelude +import HurlWorkbench.Process.Run +import HurlWorkbench.Service.Resolve +import HurlWorkbench.Service.Run (awaitService) +import HurlWorkbench.Workspace.Types (ServiceName (..), ServiceStep (..)) + +-- Newest acquisition first, including services still in readiness. +data Entry = Entry !ResolvedService !OwnedProcess !Bool + +newtype ServiceGroup = ServiceGroup (TVar [Entry]) + +data LifecycleOutcome = LifecycleOutcome + { name :: !ServiceName, + action :: !Text, + status :: !Text, + elapsed :: !NominalDiffTime, + failure :: !(Maybe ServiceError) + } + deriving stock (Generic, Eq, Show) + +newServiceGroup :: IO ServiceGroup +newServiceGroup = ServiceGroup <$> newTVarIO [] + +unexpected :: ServiceGroup -> STM ServiceError +unexpected (ServiceGroup entries) = do + active <- readTVar entries + foldr + orElse + retry + [ ServiceExitedDuringCallback (service ^. #name) <$> waitExitCodeSTM owned + | Entry service owned True <- active + ] + +watchServices :: ServiceGroup -> IO (Either ServiceError a) -> IO (Either ServiceError a) +watchServices group action = race (atomically (unexpected group)) action <&> either Left id + +startNamed :: ServiceGroup -> ResolvedService -> IO (Either ServiceError ()) +startNamed group service = startNamedObserved group service (const (pure ())) + +startNamedObserved :: ServiceGroup -> ResolvedService -> (LifecycleOutcome -> IO ()) -> IO (Either ServiceError ()) +startNamedObserved group@(ServiceGroup entries) service observe = mask $ \restore -> do + began <- getCurrentTime + let emit action began_ result = do + ended <- getCurrentTime + observe (LifecycleOutcome (service ^. #name) action (either (const "failed") (const "passed") result) (diffUTCTime ended began_) (either Just (const Nothing) result)) + spawnGroup (service ^. #name) (commandConfig (service ^. #processConfig)) >>= \case + Left err -> emit "start" began (Left err) >> pure (Left err) + Right owned -> do + -- Ownership is registered before readiness becomes interruptible. + atomically (modifyTVar' entries (Entry service owned False :)) + emit "start" began (Right ()) + readyBegan <- getCurrentTime + result <- restore (watchServices group (awaitService service owned)) + emit "readiness" readyBegan result + case result of + Left err -> pure (Left err) + Right () -> do + atomically (modifyTVar' entries (map (markReady (owned ^. #processId)))) + pure (Right ()) + where + markReady pid entry@(Entry definition process _) = + if process ^. #processId == pid then Entry definition process True else entry + +stopNamed :: ServiceGroup -> ServiceName -> IO (Either ServiceError ()) +stopNamed (ServiceGroup entries) name = mask $ \_ -> do + retired <- atomically $ do + active <- readTVar entries + -- Check every current leader before retiring the intentional generation. + exits <- for active $ \(Entry service owned ready) -> do + exitCode <- getExitCodeSTM owned + pure [ServiceExitedDuringCallback (service ^. #name) code | ready, Just code <- [exitCode]] + case concat exits of + err : _ -> pure (Left err) + [] -> case [entry | entry@(Entry service _ _) <- active, service ^. #name == name] of + [] -> pure (Left (ServiceShutdownFailed name Nothing "service is not running")) + entry : _ -> do + -- Keep ownership until termination finishes, but retire the monitor. + modifyTVar' entries (map (\entry_@(Entry service owned _) -> if service ^. #name == name then Entry service owned False else entry_)) + pure (Right entry) + case retired of + Left err -> pure (Left err) + Right (Entry service owned _) -> do + result <- terminateGroup name (service ^. #shutdownTimeout) owned + case result of + Left err -> pure (Left err) + Right () -> do + atomically (modifyTVar' entries (filter (\(Entry _ process _) -> process ^. #processId /= owned ^. #processId))) + pure (Right ()) + +applyServiceStep :: ServiceGroup -> [ResolvedService] -> ServiceStep -> IO (Either ServiceError ()) +applyServiceStep group definitions operation = applyServiceStepObserved group definitions operation (const (pure ())) + +applyServiceStepObserved :: ServiceGroup -> [ResolvedService] -> ServiceStep -> (LifecycleOutcome -> IO ()) -> IO (Either ServiceError ()) +applyServiceStepObserved group definitions operation observe = case operation of + Stop name -> watchServices group (stop name) + Start name -> watchServices group (start name) + Restart name -> + watchServices group $ + stop name >>= \case + Left err -> pure (Left err) + Right () -> start name + where + stop name = do + began <- getCurrentTime + result <- stopNamed group name + ended <- getCurrentTime + observe (LifecycleOutcome name "stop" (either (const "failed") (const "passed") result) (diffUTCTime ended began) (either Just (const Nothing) result)) + pure result + start name = case filter ((== name) . view #name) definitions of + service : _ -> startNamedObserved group service observe + [] -> pure (Left (ServiceProcessIdUnavailable name)) + +cleanupServices :: ServiceGroup -> IO [LifecycleOutcome] +cleanupServices (ServiceGroup entries) = do + active <- readTVarIO entries + results <- for active $ \(Entry service owned _) -> do + began <- getCurrentTime + result <- terminateGroup (service ^. #name) (service ^. #shutdownTimeout) owned + ended <- getCurrentTime + pure (LifecycleOutcome (service ^. #name) "cleanup" (either (const "failed") (const "passed") result) (diffUTCTime ended began) (either Just (const Nothing) result)) + atomically (writeTVar entries []) + pure results diff --git a/src/HurlWorkbench/Service/Resolve.hs b/src/HurlWorkbench/Service/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Service/Resolve.hs @@ -0,0 +1,206 @@ +-- | Resolve a validated service definition against suite-level runtime +-- bindings. Per-recipe and per-case binding layers never enter this module. +module HurlWorkbench.Service.Resolve + ( ResolvedCommand (..), + ResolvedReadiness (..), + ResolvedService (..), + ServiceError (..), + requiredServiceParameters, + resolveService, + resolveCommand, + renderServiceError, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime) +import HurlWorkbench.Parameter.Resolve (ResolvedBindings (..)) +import HurlWorkbench.Parameter.Resolve.Internal (secretValueText) +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import Numeric.Natural (Natural) +import System.Exit (ExitCode) +import System.FilePath (()) +import System.Posix.Types (ProcessID) + +data ResolvedCommand = ResolvedCommand + { executable :: !FilePath, + arguments :: ![String], + workingDirectory :: !FilePath, + environmentPolicy :: !EnvironmentPolicy, + environment :: ![(String, String)] + } + deriving stock (Generic, Eq) + +instance Show ResolvedCommand where + show _ = "ResolvedCommand " + +data ResolvedReadiness + = ResolvedHttpReadiness !Text !Int !Int !NominalDiffTime + | ResolvedCommandReadiness !ResolvedCommand !Int !NominalDiffTime + deriving stock (Generic, Eq, Show) + +data ResolvedService = ResolvedService + { name :: !ServiceName, + processConfig :: !ResolvedCommand, + readiness :: !ResolvedReadiness, + shutdownTimeout :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + +data ServiceError + = ServicePhaseFailed !Text + | ServiceBindingMissing !ParameterName + | ServiceBindingUnknown !ParameterName + | ServiceReadinessSecretPlaceholder !ParameterName + | ServiceReadinessMalformedPlaceholder !Text + | ServiceReadinessInvalidUrl !Text !Text + | ServiceEnvironmentMissing !ServiceName !Text ![Text] + | ServiceSpawnFailed !FilePath !Text + | ServiceProcessIdUnavailable !ServiceName + | ServiceExitedBeforeReady !ServiceName !ExitCode + | ServiceReadinessTimedOut !ServiceName + | ServiceReadinessProbeStartFailed !FilePath !Text + | ServiceExitedDuringCallback !ServiceName !ExitCode + | ServiceShutdownFailed !ServiceName !(Maybe ProcessID) !Text + deriving stock (Generic, Eq, Show) + +data UrlPart + = UrlText !Text + | UrlParameter !ParameterName + +requiredServiceParameters :: Service -> Either ServiceError (Set ParameterName) +requiredServiceParameters service = do + readinessParameters <- case service ^. #readiness of + HttpReadinessCheck http -> + Set.fromList . mapMaybe partParameter <$> parseUrlTemplate (http ^. #url) + CommandReadinessCheck probe -> pure (commandParameters (probe ^. #command)) + pure (commandParameters (service ^. #command) <> readinessParameters) + where + commandParameters command = Set.fromList (map (view #parameter) (command ^. #environment)) + partParameter = \case + UrlText _ -> Nothing + UrlParameter name -> Just name + +resolveService :: ValidatedWorkspace -> ResolvedBindings -> Service -> Either ServiceError ResolvedService +resolveService validated bindings service = do + processConfig <- resolveCommand validated bindings (service ^. #command) + readiness <- case service ^. #readiness of + HttpReadinessCheck http -> + ResolvedHttpReadiness + <$> substituteReadinessUrl validated bindings (http ^. #url) + <*> pure (fromIntegral (http ^. #expectedStatus)) + <*> pure (milliseconds (http ^. #intervalMilliseconds)) + <*> pure (seconds (http ^. #timeoutSeconds)) + CommandReadinessCheck probe -> + ResolvedCommandReadiness + <$> resolveCommand validated bindings (probe ^. #command) + <*> pure (milliseconds (probe ^. #intervalMilliseconds)) + <*> pure (seconds (probe ^. #timeoutSeconds)) + pure + ResolvedService + { name = service ^. #name, + processConfig, + readiness, + shutdownTimeout = seconds (service ^. #shutdownTimeoutSeconds) + } + +resolveCommand :: ValidatedWorkspace -> ResolvedBindings -> CommandSpec -> Either ServiceError ResolvedCommand +resolveCommand validated bindings command = do + environment <- traverse resolveEnvironmentBinding (command ^. #environment) + let WorkspaceRoot root = validatedRoot validated + workingDirectory = maybe root (root ) (command ^. #workingDirectory) + pure + ResolvedCommand + { executable = Text.unpack (command ^. #executable), + arguments = map Text.unpack (command ^. #arguments), + workingDirectory, + environmentPolicy = command ^. #environmentPolicy, + environment + } + where + resolveEnvironmentBinding binding = do + value <- resolveValue (binding ^. #parameter) + pure (Text.unpack (binding ^. #variable), Text.unpack value) + + resolveValue name = + case Map.lookup name (bindings ^. #variables) of + Just value -> Right (hurlValueLiteralText value) + Nothing -> case Map.lookup name (bindings ^. #secrets) of + Just value -> Right (secretValueText value) + Nothing -> Left (ServiceBindingMissing name) + +substituteReadinessUrl :: ValidatedWorkspace -> ResolvedBindings -> Text -> Either ServiceError Text +substituteReadinessUrl validated bindings template = do + urlParts <- parseUrlTemplate template + Text.concat <$> traverse renderPart urlParts + where + renderPart = \case + UrlText value -> Right value + UrlParameter name -> readinessValue name + + readinessValue name = case lookupParameter name validated of + Nothing -> Left (ServiceBindingUnknown name) + Just parameter + | parameter ^. #kind == Secret -> Left (ServiceReadinessSecretPlaceholder name) + | otherwise -> case Map.lookup name (bindings ^. #variables) of + Nothing -> Left (ServiceBindingMissing name) + Just value -> Right (hurlValueLiteralText value) + +parseUrlTemplate :: Text -> Either ServiceError [UrlPart] +parseUrlTemplate template = go [] template + where + go accumulated remaining = + case Text.breakOn "{{" remaining of + (prefix, rest) + | Text.null rest -> + if "}}" `Text.isInfixOf` prefix + then malformed + else Right (reverse (prependText prefix accumulated)) + | otherwise -> + let afterOpen = Text.drop 2 rest + (rawName, close) = Text.breakOn "}}" afterOpen + in if Text.null close || Text.null rawName || "{{" `Text.isInfixOf` rawName + then malformed + else go (UrlParameter (ParameterName rawName) : prependText prefix accumulated) (Text.drop 2 close) + + prependText value accumulated + | Text.null value = accumulated + | otherwise = UrlText value : accumulated + malformed = Left (ServiceReadinessMalformedPlaceholder template) + +milliseconds :: Natural -> Int +milliseconds value = fromIntegral value * 1000 + +seconds :: Natural -> NominalDiffTime +seconds = fromIntegral + +renderServiceError :: ServiceError -> Text +renderServiceError = \case + ServicePhaseFailed phase -> "suite " <> phase <> " command failed" + ServiceBindingMissing name -> "service parameter " <> quotedParameter name <> " has no suite-level runtime value" + ServiceBindingUnknown name -> "readiness URL refers to unknown parameter " <> quotedParameter name + ServiceReadinessSecretPlaceholder name -> "readiness URL must not contain secret parameter " <> quotedParameter name + ServiceReadinessMalformedPlaceholder value -> "readiness URL contains a malformed placeholder near " <> quote value + ServiceReadinessInvalidUrl url message -> "invalid readiness URL " <> quote url <> ": " <> message + ServiceEnvironmentMissing name phase names -> "service " <> quotedService name <> " " <> phase <> " requires missing environment variables: " <> Text.intercalate ", " names + ServiceSpawnFailed executable message -> "service executable " <> quote (Text.pack executable) <> " could not be started: " <> message + ServiceProcessIdUnavailable name -> "service " <> quotedService name <> " started without an observable process id" + ServiceExitedBeforeReady name exitCode -> "service " <> quotedService name <> " exited before readiness with " <> Text.pack (show exitCode) + ServiceReadinessTimedOut name -> "service " <> quotedService name <> " did not become ready before its timeout" + ServiceReadinessProbeStartFailed executable message -> "readiness executable " <> quote (Text.pack executable) <> " could not be started: " <> message + ServiceExitedDuringCallback name exitCode -> "service " <> quotedService name <> " exited while its suite was running with " <> Text.pack (show exitCode) + ServiceShutdownFailed name processId message -> + "service " + <> quotedService name + <> maybe "" ((" (pid " <>) . (<> ")") . Text.pack . show) processId + <> " could not be shut down cleanly: " + <> message + where + quotedParameter = quote . unParameterName + quotedService = quote . unServiceName + quote value = "\"" <> value <> "\"" diff --git a/src/HurlWorkbench/Service/Run.hs b/src/HurlWorkbench/Service/Run.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Service/Run.hs @@ -0,0 +1,180 @@ +-- | POSIX process-group lifecycle and readiness probes for one managed +-- service. Cleanup always completes before callback exceptions are rethrown. +module HurlWorkbench.Service.Run + ( ServiceHandle, + serviceProcessId, + withService, + freezeService, + awaitService, + prepareCommand, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race) +import Control.Exception (SomeException, finally, mask, throwIO, try) +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) +import HurlWorkbench.Prelude +import HurlWorkbench.Process.Run +import HurlWorkbench.Service.Environment (selectEnvironment) +import HurlWorkbench.Service.Resolve +import HurlWorkbench.Workspace.Types (EnvironmentPolicy (..), ServiceName (..)) +import Network.HTTP.Client + ( HttpException, + Manager, + Request (responseTimeout), + defaultManagerSettings, + httpNoBody, + newManager, + parseRequest, + responseStatus, + responseTimeoutMicro, + ) +import Network.HTTP.Types.Status (statusCode) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.Posix.Types (ProcessID) +import System.Timeout qualified as Timeout + +data ServiceHandle = ServiceHandle + { name :: !Text, + processId :: !ProcessID + } + deriving stock (Generic, Eq, Show) + +serviceProcessId :: ServiceHandle -> ProcessID +serviceProcessId = view #processId + +data PreparedReadiness + = PreparedHttpReadiness !Manager !Request !Int !Int !NominalDiffTime + | PreparedCommandReadiness !ResolvedCommand !Int !NominalDiffTime + +withService :: ResolvedService -> (ServiceHandle -> IO a) -> IO (Either ServiceError a) +withService service callback = mask $ \restore -> do + ambient <- getEnvironment + case prepareCommand ambient (service ^. #name) "command" (service ^. #processConfig) of + Left err -> pure (Left err) + Right command -> do + preparedReadiness <- prepareReadiness ambient (service ^. #name) (service ^. #readiness) + case preparedReadiness of + Left err -> pure (Left err) + Right readiness -> launch restore command readiness + where + launch restore command readiness = do + spawnGroup (service ^. #name) (commandConfig command) >>= \case + Left err -> pure (Left err) + Right owned -> do + execution <- try @SomeException (restore (runLifecycle service readiness owned (owned ^. #processId) callback)) + shutdown <- terminateGroup (service ^. #name) (service ^. #shutdownTimeout) owned + case execution of + Left exception -> throwIO exception + Right (Left err) -> pure (Left err) + Right (Right value) -> pure (value <$ shutdown) + +awaitService :: ResolvedService -> OwnedProcess -> IO (Either ServiceError ()) +awaitService service owned = do + prepared <- prepareReadiness [] (service ^. #name) (service ^. #readiness) + case prepared of + Left err -> pure (Left err) + Right readiness -> awaitReadiness service readiness owned + +runLifecycle :: ResolvedService -> PreparedReadiness -> OwnedProcess -> ProcessID -> (ServiceHandle -> IO a) -> IO (Either ServiceError a) +runLifecycle service readiness process pid callback = + awaitReadiness service readiness process >>= \case + Left err -> pure (Left err) + Right () -> + race + (callback ServiceHandle {name = unServiceName (service ^. #name), processId = pid}) + (waitExitCode process) + <&> \case + Left value -> Right value + Right exitCode -> Left (ServiceExitedDuringCallback (service ^. #name) exitCode) + +prepareReadiness :: [(String, String)] -> ServiceName -> ResolvedReadiness -> IO (Either ServiceError PreparedReadiness) +prepareReadiness _ambient _name (ResolvedHttpReadiness url expectedStatus interval timeout) = do + parsed <- try @HttpException (parseRequest (Text.unpack url)) + case parsed of + Left _ -> pure (Left (ServiceReadinessInvalidUrl "" "URL could not be parsed")) + Right request -> do + manager <- newManager defaultManagerSettings + let withTimeout = request {responseTimeout = responseTimeoutMicro 1000000} + pure + ( Right + ( PreparedHttpReadiness + manager + withTimeout + expectedStatus + interval + timeout + ) + ) +prepareReadiness ambient name (ResolvedCommandReadiness command interval timeout) = + pure ((\prepared -> PreparedCommandReadiness prepared interval timeout) <$> prepareCommand ambient name "readiness command" command) + +prepareCommand :: [(String, String)] -> ServiceName -> Text -> ResolvedCommand -> Either ServiceError ResolvedCommand +prepareCommand ambient name phase command = + case selectEnvironment (command ^. #environmentPolicy) ambient (command ^. #environment) of + Left missing -> Left (ServiceEnvironmentMissing name phase missing) + Right selected -> Right (command & #environment .~ selected & #environmentPolicy .~ Clean []) + +freezeService :: [(String, String)] -> ResolvedService -> IO (Either ServiceError ResolvedService) +freezeService ambient service = case prepareCommand ambient (service ^. #name) "command" (service ^. #processConfig) of + Left err -> pure (Left err) + Right command -> + prepareReadiness ambient (service ^. #name) (service ^. #readiness) + <&> fmap + ( \prepared -> + service & #processConfig .~ command & #readiness .~ case prepared of + PreparedCommandReadiness probe interval timeout -> ResolvedCommandReadiness probe interval timeout + PreparedHttpReadiness {} -> service ^. #readiness + ) + +awaitReadiness :: ResolvedService -> PreparedReadiness -> OwnedProcess -> IO (Either ServiceError ()) +awaitReadiness service readiness process = do + began <- getCurrentTime + let deadline = addUTCTime (readinessTimeout readiness) began + loop deadline + where + loop deadline = do + getExitCode process >>= \case + Just exitCode -> pure (Left (ServiceExitedBeforeReady (service ^. #name) exitCode)) + Nothing -> do + now <- getCurrentTime + if now >= deadline + then pure (Left (ServiceReadinessTimedOut (service ^. #name))) + else do + attempted <- Timeout.timeout (remainingMicroseconds now deadline) (probeReadiness readiness) + case attempted of + Nothing -> pure (Left (ServiceReadinessTimedOut (service ^. #name))) + Just (Left err) -> pure (Left err) + Just (Right True) -> + getExitCode process <&> \case + Just exitCode -> Left (ServiceExitedBeforeReady (service ^. #name) exitCode) + Nothing -> Right () + Just (Right False) -> threadDelay (readinessInterval readiness) >> loop deadline + +probeReadiness :: PreparedReadiness -> IO (Either ServiceError Bool) +probeReadiness (PreparedHttpReadiness manager request expected _interval _timeout) = do + attempted <- try @HttpException (httpNoBody request manager) + pure (Right (either (const False) ((== expected) . statusCode . responseStatus) attempted)) +probeReadiness (PreparedCommandReadiness command _interval timeout) = mask $ \restore -> do + spawnGroup (ServiceName "readiness") (commandConfig command) >>= \case + Left _ -> pure (Left (ServiceReadinessProbeStartFailed "" "process launch failed")) + Right owned -> do + exitCode <- restore (waitExitCode owned) `finally` void (terminateGroup (ServiceName "readiness") (min 1 timeout) owned) + pure (Right (exitCode == ExitSuccess)) + +readinessInterval :: PreparedReadiness -> Int +readinessInterval = \case + PreparedHttpReadiness _ _ _ interval _ -> interval + PreparedCommandReadiness _ interval _ -> interval + +readinessTimeout :: PreparedReadiness -> NominalDiffTime +readinessTimeout = \case + PreparedHttpReadiness _ _ _ _ timeout -> timeout + PreparedCommandReadiness _ _ timeout -> timeout + +remainingMicroseconds :: UTCTime -> UTCTime -> Int +remainingMicroseconds now deadline = max 1 (floor (diffUTCTime deadline now * 1000000)) diff --git a/src/HurlWorkbench/Suite/Isolation.hs b/src/HurlWorkbench/Suite/Isolation.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Suite/Isolation.hs @@ -0,0 +1,59 @@ +-- | Pure application-state checks, before formatting, binding IO, capability +-- probes, report replacement, or service resolution. +module HurlWorkbench.Suite.Isolation + ( IsolationIssue (..), + checkIsolation, + checkSuiteIsolation, + checkSuiteIsolationWith, + renderIsolationIssue, + ) +where + +import Data.Generics.Labels () +import Data.Text qualified as Text +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Batch (PositiveInt, positiveIntValue) +import HurlWorkbench.Run.Selection +import HurlWorkbench.Suite.Scenario (VerifiedScenarioInputs) +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types + +data IsolationIssue + = SharedStateParallelUnsafe !Text !SafetyDisposition + | IndependentStateHandoffRequired + deriving stock (Generic, Eq, Show) + +checkIsolation :: IsolationPolicy -> PositiveInt -> [ExpandedRun] -> [IsolationIssue] +checkIsolation IndependentState _ _ = [IndependentStateHandoffRequired] +checkIsolation SharedState jobs runs = + [ SharedStateParallelUnsafe (Text.pack (run ^. #artifactStem)) (run ^. #safety) + | positiveIntValue jobs > 1, + run <- runs, + run ^. #safety /= Classified ReadOnly + ] + +-- | Expansion is pure; malformed references are handled by normal preparation. +checkSuiteIsolation :: ValidatedWorkspace -> SuiteName -> PositiveInt -> [IsolationIssue] +checkSuiteIsolation workspace name jobs = checkSuiteIsolationWith Nothing workspace name jobs + +checkSuiteIsolationWith :: Maybe VerifiedScenarioInputs -> ValidatedWorkspace -> SuiteName -> PositiveInt -> [IsolationIssue] +checkSuiteIsolationWith verified workspace name jobs = case lookupSuite name workspace of + Nothing -> [] + Just suite | suite ^. #isolation == IndependentState, isJust verified -> [] + Just suite -> checkIsolation (suite ^. #isolation) jobs (concatMap expanded (suite ^. #runs)) + where + expanded (ServiceRun _) = [] + expanded (CheckRun _) = [] + expanded reference = either (const []) toList (resolveSelection workspace (selection reference)) + selection = \case + WorkflowRun name_ -> SelectWorkflow name_ + RecipeRun name_ -> SelectRecipe name_ + MatrixRun name_ -> SelectMatrix name_ + CheckRun _ -> error "check step is not a Hurl selection" + ServiceRun _ -> error "lifecycle step is not a Hurl selection" + +renderIsolationIssue :: IsolationIssue -> Text +renderIsolationIssue = \case + SharedStateParallelUnsafe scenario _ -> + "shared-state-parallel-unsafe: scenario \"" <> scenario <> "\" requires --jobs 1; mutation permission does not establish isolation" + IndependentStateHandoffRequired -> "independent-state-handoff-required: independent scenarios require a verified runtime handoff" diff --git a/src/HurlWorkbench/Suite/Resolve.hs b/src/HurlWorkbench/Suite/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Suite/Resolve.hs @@ -0,0 +1,558 @@ +-- | Complete suite preflight. Every run, safety decision, report target, and +-- optional managed service is resolved before execution can start. +module HurlWorkbench.Suite.Resolve + ( ReportFormat (..), + SuiteOptions (..), + SuiteRequest (..), + SuitePreflightIssue (..), + SuitePreflightError (..), + PreparedSuite (..), + PreparedStep (..), + SuiteMetadata (..), + ScenarioMetadata (..), + suiteMetadata, + reserveSuiteSummary, + suitePreflightReasonCode, + suitePreflightSetupFailure, + preflightFileRoot, + preflightScenarioInputs, + prepareSuite, + prepareSuiteWith, + renderSuitePreflightIssue, + renderSuitePreflightError, + ) +where + +import Control.Exception (IOException, displayException, try) +import Data.Bits ((.&.)) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime) +import HurlWorkbench.Check.Resolve +import HurlWorkbench.Hurl.Format (HurlfmtCapabilities, HurlfmtError, validateRenderedWorkflow) +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Batch +import HurlWorkbench.Run.FileRoot +import HurlWorkbench.Run.Prepare +import HurlWorkbench.Run.Selection +import HurlWorkbench.Service.Resolve +import HurlWorkbench.Service.Run (freezeService, prepareCommand) +import HurlWorkbench.Suite.Isolation +import HurlWorkbench.Suite.Scenario +import HurlWorkbench.Workflow.Render (RenderedWorkflow) +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import System.Directory + ( canonicalizePath, + createDirectory, + createDirectoryIfMissing, + doesPathExist, + removePathForcibly, + ) +import System.Environment (getEnvironment) +import System.FilePath (normalise, splitDirectories, ()) +import System.IO.Error (isDoesNotExistError) +import System.Info (os) +import System.Posix.Files + ( accessModes, + fileMode, + getFileStatus, + getSymbolicLinkStatus, + isDirectory, + isSymbolicLink, + ownerExecuteMode, + ownerReadMode, + ownerWriteMode, + setFileMode, + unionFileModes, + ) +import System.Posix.Types (FileMode) + +data ReportFormat = JUnit | Html | Json | Tap + deriving stock (Generic, Eq, Ord, Show) + +data SuiteOptions = SuiteOptions + { jobs :: !PositiveInt, + failFastOverride :: !(Maybe Bool), + allowMutating :: !Bool, + manageService :: !Bool, + reportFormats :: !(Set ReportFormat), + reportDirectory :: !(Maybe FilePath), + overwriteReports :: !Bool + } + deriving stock (Generic, Eq, Show) + +data SuiteRequest = SuiteRequest + { suiteName :: !SuiteName, + fileRoot :: !(Maybe FileRoot), + scenarioInputs :: !(Maybe ScenarioInputs), + bindingInput :: !BindingInput, + hurlOptions :: !HurlOptions, + suiteOptions :: !SuiteOptions + } + deriving stock (Generic, Eq, Show) + +data SuitePreflightIssue + = SuiteFileRootFailed !FileRootError + | SuiteNotFound !SuiteName + | SuiteRunPreparationFailed !PreparationError + | SuiteDependencyUnavailable + | SuiteScenarioFailed !ScenarioIssue + | SuiteScenarioInputsUnexpected + | SuiteIndependentExternalRequired + | SuiteIsolationFailed !IsolationIssue + | SuiteUnsafeRun !Text !SafetyDisposition + | SuiteDuplicateArtifactStem !FilePath + | SuiteSharedCurlExport !FilePath + | SuiteReportDirectoryRequired + | SuiteInvalidReportDirectory !FilePath + | SuiteReportPathExists !FilePath + | SuiteReportPathIsSymbolicLink !FilePath + | SuiteReportPathIsNotDirectory !FilePath + | SuiteReportIoError !FilePath !Text + | SuiteExternalLifecycle + | SuiteCheckFailed !CheckName !CheckResolutionError + | SuiteServiceNotFound !ServiceName + | SuiteServiceBindingFailed !BindingError + | SuiteServiceResolutionFailed !ServiceError + deriving stock (Generic, Eq, Show) + +newtype SuitePreflightError = SuitePreflightError + { issues :: NonEmpty SuitePreflightIssue + } + deriving stock (Generic, Eq, Show) + +-- | Safe report data has no executable requests or provider/runtime values. +data ScenarioMetadata = ScenarioMetadata + { name :: !Text, + scenario :: !FilePath, + reports :: ![FilePath] + } + deriving stock (Generic, Eq, Show) + +data SuiteMetadata = SuiteMetadata + { name :: !SuiteName, + isolation :: !IsolationPolicy, + scenarios :: ![ScenarioMetadata], + summaryPath :: !(Maybe FilePath) + } + deriving stock (Generic, Eq, Show) + +data PreparedStep = HurlBatch !Int !(NonEmpty BatchCase) | ServiceBarrier !ServiceStep | CheckBarrier !ResolvedCheck + deriving stock (Generic, Show) + +data PreparedSuite = PreparedSuite + { metadata :: !SuiteMetadata, + cases :: ![BatchCase], + batchOptions :: !BatchOptions, + managedServices :: ![ResolvedService], + steps :: ![PreparedStep], + setupCommands :: ![ResolvedCommand], + teardownCommands :: ![ResolvedCommand], + commandTimeout :: !NominalDiffTime, + cleanupTimeout :: !NominalDiffTime + } + deriving stock (Generic, Show) + +suiteMetadata :: ValidatedWorkspace -> SuiteRequest -> Either SuitePreflightError SuiteMetadata +suiteMetadata workspace request = do + suite <- maybe (Left (SuitePreflightError (SuiteNotFound (request ^. #suiteName) :| []))) Right (lookupSuite (request ^. #suiteName) workspace) + expanded <- either (Left . SuitePreflightError . (:| []) . SuiteRunPreparationFailed . SelectionPreparationFailed) Right (traverse (resolveSelection workspace . runSelection) (hurlReferences suite)) + let runs = concatMap toList expanded + pure + SuiteMetadata + { name = suite ^. #name, + isolation = suite ^. #isolation, + scenarios = fmap (\run -> ScenarioMetadata (run ^. #displayName) (run ^. #artifactStem) (map reportPath (suiteReportTargets (request ^. #suiteOptions . #reportFormats) (run ^. #artifactStem)))) runs, + summaryPath = fmap (\root -> root Text.unpack (unSuiteName (suite ^. #name)) "summary.json") (request ^. #suiteOptions . #reportDirectory) + } + where + reportPath = \case + JUnitReport path -> path + HtmlReport path -> path + JsonReport path -> path + TapReport path -> path + +-- | A refusal reserves only the suite directory, never fictitious Hurl reports. +reserveSuiteSummary :: ValidatedWorkspace -> SuiteRequest -> SuiteMetadata -> IO (Either SuitePreflightIssue ()) +reserveSuiteSummary workspace request metadata = + preflightFileRoot workspace request >>= \case + Left err -> pure (Left (NonEmpty.head (err ^. #issues))) + Right _ -> case request ^. #suiteOptions . #reportDirectory of + Nothing -> pure (Right ()) + Just root -> prepareReportLayout root (root Text.unpack (unSuiteName (metadata ^. #name))) [] (request ^. #suiteOptions . #overwriteReports) + +prepareSuite :: HurlfmtCapabilities -> ValidatedWorkspace -> SuiteRequest -> IO (Either SuitePreflightError PreparedSuite) +prepareSuite = prepareSuiteWith validateRenderedWorkflow + +prepareSuiteWith :: (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> SuiteRequest -> IO (Either SuitePreflightError PreparedSuite) +prepareSuiteWith validateRendered capabilities validated request = + preflightFileRoot validated request >>= \case + Left err -> pure (Left err) + Right root -> do + preflight <- preflightScenarioInputs validated request + case preflight of + Left err -> pure (Left err) + Right verified -> prepareVerifiedSuiteWith root verified validateRendered capabilities validated request + +prepareVerifiedSuiteWith :: FileRoot -> Maybe VerifiedScenarioInputs -> (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlfmtCapabilities -> ValidatedWorkspace -> SuiteRequest -> IO (Either SuitePreflightError PreparedSuite) +prepareVerifiedSuiteWith root verified validateRendered capabilities validated request = + case lookupSuite (request ^. #suiteName) validated of + Nothing -> pure (Left (SuitePreflightError (SuiteNotFound (request ^. #suiteName) :| []))) + Just _ + | Just problems <- nonEmpty (checkSuiteIsolationWith verified validated (request ^. #suiteName) (request ^. #suiteOptions . #jobs)) -> + pure (Left (SuitePreflightError (fmap SuiteIsolationFailed problems))) + Just suite -> do + ambient <- getEnvironment + selections <- case verified of + Nothing -> traverse prepareReference (hurlReferences suite) + Just inputs -> case traverse (resolveSelection validated . runSelection) (hurlReferences suite) of + Left err -> pure [Left (SelectionPreparationFailed err :| [])] + Right expanded -> case nonEmpty (concatMap toList expanded) of + Nothing -> pure [] + Just runs -> case traverse (\run -> (run,) <$> scenarioBindingInput inputs run) runs of + Nothing -> error "verified scenario assignment incomplete" + Just assigned -> pure <$> prepareExpandedForSuiteAtFileRootWith root validateRendered capabilities validated (request ^. #hurlOptions) assigned + serviceResult <- prepareManagedServices ambient suite + checkResults <- traverse (\name -> fmap (either (Left . SuiteCheckFailed name) Right) (prepareCheck ambient validated (request ^. #bindingInput) name)) [name | CheckRun name <- suite ^. #runs] + let preparationIssues = + concat + [ map preparationIssue (NonEmpty.toList errors) + | Left errors <- selections + ] + preparedRuns = concat [NonEmpty.toList runs | Right runs <- selections] + safetyIssues = + [ SuiteUnsafeRun (prepared ^. #displayName) (prepared ^. #safety) + | prepared <- preparedRuns, + not (request ^. #suiteOptions . #allowMutating), + requiresAuthorization (prepared ^. #safety) + ] + checkNames = [name | CheckRun name <- suite ^. #runs] + duplicateIssues = + map SuiteDuplicateArtifactStem (duplicates (map (view #artifactStem) preparedRuns)) + <> [SuiteDuplicateArtifactStem "phases" | not (null (suite ^. #setup) && null (suite ^. #teardown)), any (\run -> take 1 (splitDirectories (run ^. #artifactStem)) == ["phases"]) preparedRuns] + <> map (SuiteDuplicateArtifactStem . ("checks" ) . Text.unpack . unCheckName) (duplicates checkNames) + <> [SuiteDuplicateArtifactStem "checks" | not (null checkNames), any (\run -> take 1 (splitDirectories (run ^. #artifactStem)) == ["checks"]) preparedRuns] + curlIssues = + [ SuiteSharedCurlExport path + | length preparedRuns > 1, + Just path <- [request ^. #hurlOptions . #curlExportPath] + ] + reportIssues = + [SuiteReportDirectoryRequired | (not (null checkNames) || not (Set.null (request ^. #suiteOptions . #reportFormats))) && isNothing (request ^. #suiteOptions . #reportDirectory)] + serviceIssues = either pure (const []) serviceResult + issues = preparationIssues <> safetyIssues <> duplicateIssues <> curlIssues <> reportIssues <> serviceIssues <> [err | Left err <- checkResults] + case nonEmpty issues of + Just problems -> pure (Left (SuitePreflightError problems)) + Nothing -> case (preparedRuns, serviceResult) of + (runs, Right (services, setup, teardown)) -> + prepareReports suite runs >>= \case + Left problem -> pure (Left (SuitePreflightError (problem :| []))) + Right (batchCases, _summary) -> + pure + ( Right + PreparedSuite + { metadata = either (error "validated suite metadata failed") id (suiteMetadata validated request), + cases = batchCases, + batchOptions = + BatchOptions + (request ^. #suiteOptions . #jobs) + (fromMaybe (suite ^. #failFast) (request ^. #suiteOptions . #failFastOverride)), + managedServices = services, + steps = orderedSteps validated suite batchCases [check | Right check <- checkResults], + setupCommands = setup, + teardownCommands = teardown, + commandTimeout = fromIntegral (suite ^. #commandTimeoutSeconds), + cleanupTimeout = fromIntegral (suite ^. #cleanupTimeoutSeconds) + } + ) + _ -> error "prepareSuite: validated suite produced no prepared runs" + where + preparationIssue RunBindingFailed {} | isJust verified = SuiteScenarioFailed ScenarioRuntimeInputFailed + preparationIssue err = SuiteRunPreparationFailed err + + prepareReference reference = + prepareSelectionForSuiteAtFileRootWith + root + validateRendered + capabilities + validated + (request ^. #bindingInput) + (request ^. #hurlOptions) + (runSelection reference) + + prepareManagedServices ambient suite + | not (request ^. #suiteOptions . #manageService) = + pure $ if any isLifecycle (suite ^. #runs) then Left SuiteExternalLifecycle else Right ([], [], []) + | otherwise = do + services <- traverse (prepareService ambient) (suiteServices suite) + setup <- traverse (preparePhase ambient "setup") (suite ^. #setup) + teardown <- traverse (preparePhase ambient "teardown") (suite ^. #teardown) + pure ((,,) <$> sequence services <*> sequence setup <*> sequence teardown) + + prepareService ambient serviceName = case lookupService serviceName validated of + Nothing -> pure (Left (SuiteServiceNotFound serviceName)) + Just service -> case requiredServiceParameters service of + Left err -> pure (Left (SuiteServiceResolutionFailed err)) + Right required -> + resolveParameterSubsetInEnvironment ambient validated required (request ^. #bindingInput) >>= \case + Left err -> pure (Left (SuiteServiceBindingFailed err)) + Right bindings -> case resolveService validated bindings service of + Left err -> pure (Left (SuiteServiceResolutionFailed err)) + Right resolved -> fmap (either (Left . SuiteServiceResolutionFailed) Right) (freezeService ambient resolved) + + preparePhase ambient phase command = + resolveParameterSubsetInEnvironment ambient validated (Set.fromList (map (view #parameter) (command ^. #environment))) (request ^. #bindingInput) <&> \case + Left err -> Left (SuiteServiceBindingFailed err) + Right bindings -> + either + (Left . SuiteServiceResolutionFailed) + Right + (resolveCommand validated bindings command >>= prepareCommand ambient (request ^. #suiteName & unSuiteName & ServiceName) phase) + + prepareReports suite runs = case request ^. #suiteOptions . #reportDirectory of + Nothing -> + pure + ( Right + ( fmap (buildBatchCase TestMode CaptureRunOutput []) runs, + Nothing + ) + ) + Just reportRoot -> do + let suiteRoot = reportRoot Text.unpack (unSuiteName (suite ^. #name)) + runList = runs + runRoots = map ((suiteRoot ) . view #artifactStem) runList + formats = request ^. #suiteOptions . #reportFormats + batchCases = + [ buildBatchCase TestMode CaptureRunOutput (suiteReportTargets formats runRoot) prepared + | (prepared, runRoot) <- zip runList runRoots + ] + summary = suiteRoot "summary.json" + prepared <- prepareReportLayout reportRoot suiteRoot (runRoots <> [suiteRoot "checks" Text.unpack (unCheckName name) | CheckRun name <- suite ^. #runs] <> [suiteRoot "phases" phase show ordinal | (phase, commands) <- [("setup", suite ^. #setup), ("teardown", suite ^. #teardown)], ordinal <- [0 .. length commands - 1]]) (request ^. #suiteOptions . #overwriteReports) + pure ((,Just summary) batchCases <$ prepared) + +-- | Select once before rendering, dependency probes, services, and reports. +preflightFileRoot :: ValidatedWorkspace -> SuiteRequest -> IO (Either SuitePreflightError FileRoot) +preflightFileRoot workspace request = + selectSuiteFileRoot workspace (request ^. #suiteName) (request ^. #bindingInput) (request ^. #fileRoot) >>= \case + Left err -> pure (Left (SuitePreflightError (SuiteFileRootFailed err :| []))) + Right root -> do + checked <- checkFileRootOutputs root (maybe [] pure (request ^. #suiteOptions . #reportDirectory) <> maybe [] pure (request ^. #hurlOptions . #curlExportPath)) + pure (either (Left . SuitePreflightError . (:| []) . SuiteFileRootFailed) (const (Right root)) checked) + +-- | Public early boundary for core runners and CLI capability detection. Raw +-- assignments are checked in full before any syntax probe or binding preparation. +preflightScenarioInputs :: ValidatedWorkspace -> SuiteRequest -> IO (Either SuitePreflightError (Maybe VerifiedScenarioInputs)) +preflightScenarioInputs workspace request = case lookupSuite (request ^. #suiteName) workspace of + Nothing -> pure (failure (SuiteNotFound (request ^. #suiteName))) + Just suite -> case (suite ^. #isolation, request ^. #scenarioInputs) of + (SharedState, Just _) -> pure (failure SuiteScenarioInputsUnexpected) + (SharedState, Nothing) -> pure $ case nonEmpty (checkSuiteIsolation workspace (request ^. #suiteName) (request ^. #suiteOptions . #jobs)) of + Nothing -> Right Nothing + Just issues -> Left (SuitePreflightError (fmap SuiteIsolationFailed issues)) + (IndependentState, Nothing) -> pure (failure (SuiteIsolationFailed IndependentStateHandoffRequired)) + (IndependentState, Just inputs) + | request ^. #suiteOptions . #manageService -> pure (failure SuiteIndependentExternalRequired) + | otherwise -> case traverse (resolveSelection workspace . runSelection) (hurlReferences suite) of + Left err -> pure (failure (SuiteRunPreparationFailed (SelectionPreparationFailed err))) + Right expanded -> verifyScenarioInputs workspace (concatMap toList expanded) (request ^. #bindingInput) inputs <&> either (failure . SuiteScenarioFailed) (Right . Just) + where + failure issue = Left (SuitePreflightError (issue :| [])) + +hurlReferences :: Suite -> [RunReference] +hurlReferences suite = filter (\case ServiceRun _ -> False; CheckRun _ -> False; _ -> True) (suite ^. #runs) + +isLifecycle :: RunReference -> Bool +isLifecycle (ServiceRun _) = True +isLifecycle _ = False + +-- | Partition adjacent Hurl references without losing global case indices. +orderedSteps :: ValidatedWorkspace -> Suite -> [BatchCase] -> [ResolvedCheck] -> [PreparedStep] +orderedSteps workspace suite cases checks = go 0 [] 0 cases (suite ^. #runs) + where + checkIndex = Map.fromList [(check ^. #name, check) | check <- checks] + flush _ [] = [] + flush offset accumulated = [HurlBatch offset (NonEmpty.fromList accumulated)] + go offset accumulated count _remaining [] = flush (offset - count) accumulated + go offset accumulated count remaining (ServiceRun step : rest) = + flush (offset - count) accumulated <> [ServiceBarrier step] <> go offset [] 0 remaining rest + go offset accumulated count remaining (CheckRun name : rest) = + let check = fromMaybe (error "preflighted check missing") (Map.lookup name checkIndex) + in flush (offset - count) accumulated <> [CheckBarrier check] <> go offset [] 0 remaining rest + go offset accumulated count remaining (reference : rest) = + let size = either (const 0) length (resolveSelection workspace (runSelection reference)) + (batch, later) = splitAt size remaining + in go (offset + size) (accumulated <> batch) (count + size) later rest + +runSelection :: RunReference -> RunSelection +runSelection = \case + WorkflowRun name -> SelectWorkflow name + RecipeRun name -> SelectRecipe name + MatrixRun name -> SelectMatrix name + CheckRun _ -> error "check step is not a Hurl selection" + ServiceRun _ -> error "lifecycle step is not a Hurl selection" + +requiresAuthorization :: SafetyDisposition -> Bool +requiresAuthorization = \case + Classified ReadOnly -> False + Classified Mutating -> True + UnclassifiedWorkflow -> True + +suiteReportTargets :: Set ReportFormat -> FilePath -> [HurlReportTarget] +suiteReportTargets formats runRoot = map target (Set.toAscList formats) + where + target = \case + JUnit -> JUnitReport (runRoot "junit.xml") + Html -> HtmlReport (runRoot "html") + Json -> JsonReport (runRoot "json") + Tap -> TapReport (runRoot "report.tap") + +prepareReportLayout :: FilePath -> FilePath -> [FilePath] -> Bool -> IO (Either SuitePreflightIssue ()) +prepareReportLayout reportRoot suiteRoot runRoots overwrite + | null reportRoot || reportRoot == "." || reportRoot == ".." || normalise reportRoot == "/" = pure (Left (SuiteInvalidReportDirectory reportRoot)) + | otherwise = do + inspected <- concat <$> traverse inspectDirectory (filter (\path -> path /= "/" && path /= "") (drop 1 (scanl () "" (splitDirectories (normalise suiteRoot))))) + case inspected of + problem : _ -> pure (Left problem) + [] -> do + suiteExists <- doesPathExist suiteRoot + if suiteExists && not overwrite + then pure (Left (SuiteReportPathExists suiteRoot)) + else do + attempted <- try @IOException $ do + when suiteExists (removePathForcibly suiteRoot) + ensureOwnerDirectory reportRoot + createDirectory suiteRoot + secureDirectory suiteRoot + traverse_ createRunRoot runRoots + pure $ case attempted of + Left err -> Left (SuiteReportIoError suiteRoot (Text.pack (displayException err))) + Right () -> Right () + where + createRunRoot path = do + createDirectoryIfMissing True path + secureTree suiteRoot path + +inspectDirectory :: FilePath -> IO [SuitePreflightIssue] +inspectDirectory path = do + inspected <- try @IOException (getSymbolicLinkStatus path) + case inspected of + Left err | isDoesNotExistError err -> pure [] + Left _ -> pure [SuiteReportIoError path "could not inspect report path"] + Right status + | isSymbolicLink status -> do + -- macOS exposes these fixed OS-owned aliases for ordinary temporary + -- directories. User-controlled symlink ancestors remain forbidden. + canonical <- try @IOException (canonicalizePath path) + pure [SuiteReportPathIsSymbolicLink path | not (os == "darwin" && path `elem` ["/tmp", "/var"] && either (const False) (== ("/private" <> path)) canonical)] + | not (isDirectory status) -> pure [SuiteReportPathIsNotDirectory path] + | otherwise -> pure [] + +ensureOwnerDirectory :: FilePath -> IO () +ensureOwnerDirectory path = createDirectoryIfMissing True path >> secureDirectory path + +secureTree :: FilePath -> FilePath -> IO () +secureTree root target = go root relativeParts + where + rootParts = splitDirectories root + targetParts = splitDirectories target + relativeParts = drop (length rootParts) targetParts + go _ [] = pure () + go parent (component : remaining) = do + let path = parent component + secureDirectory path + go path remaining + +secureDirectory :: FilePath -> IO () +secureDirectory path = do + setFileMode path secureDirectoryMode + actual <- (.&. accessModes) . fileMode <$> getFileStatus path + unless (actual == secureDirectoryMode) (ioError (userError ("insecure permissions on " <> path))) + +secureDirectoryMode :: FileMode +secureDirectoryMode = ownerReadMode `unionFileModes` ownerWriteMode `unionFileModes` ownerExecuteMode + +duplicates :: (Ord value) => [value] -> [value] +duplicates values = + [ value + | (value, count) <- Map.toAscList (Map.fromListWith (+) [(value, 1 :: Int) | value <- values]), + count > 1 + ] + +renderSuitePreflightError :: SuitePreflightError -> Text +renderSuitePreflightError = Text.intercalate "\n" . map renderSuitePreflightIssue . toList . view #issues + +renderSuitePreflightIssue :: SuitePreflightIssue -> Text +renderSuitePreflightIssue = \case + SuiteFileRootFailed err -> renderFileRootError err + SuiteDependencyUnavailable -> "suite-dependency-unavailable" + SuiteScenarioFailed issue -> renderScenarioIssue issue + SuiteScenarioInputsUnexpected -> "scenario-inputs-unexpected: shared-state suites reject scenario inputs" + SuiteIndependentExternalRequired -> "independent-state-external-required: use --external-service" + SuiteIsolationFailed issue -> renderIsolationIssue issue + SuiteExternalLifecycle -> "external-service-lifecycle: lifecycle steps require managed services" + SuiteNotFound name -> "unknown suite " <> quote (unSuiteName name) + SuiteRunPreparationFailed err -> renderPreparationError err + SuiteUnsafeRun name disposition -> + "run " <> quote name <> " requires --allow-mutating (" <> safetyLabel disposition <> ")" + SuiteDuplicateArtifactStem stem -> "suite produces duplicate report path for " <> quote (Text.pack stem) + SuiteSharedCurlExport path -> "--curl has one path and cannot be shared by multiple suite runs: " <> quote (Text.pack path) + SuiteReportDirectoryRequired -> "--report-dir is required for checks or selected report formats" + SuiteInvalidReportDirectory path -> "invalid report directory " <> quote (Text.pack path) + SuiteReportPathExists path -> "report suite directory already exists; use --overwrite to replace " <> quote (Text.pack path) + SuiteReportPathIsSymbolicLink path -> "report path must not be a symbolic link: " <> quote (Text.pack path) + SuiteReportPathIsNotDirectory path -> "report path is not a directory: " <> quote (Text.pack path) + SuiteReportIoError path message -> "could not prepare reports under " <> quote (Text.pack path) <> ": " <> message + SuiteCheckFailed name err -> "check \"" <> unCheckName name <> "\": " <> renderCheckResolutionError err + SuiteServiceNotFound name -> "suite refers to unknown service " <> quote (unServiceName name) + SuiteServiceBindingFailed err -> "managed service: " <> renderBindingError err + SuiteServiceResolutionFailed err -> "managed service: " <> renderServiceError err + where + safetyLabel = \case + Classified Mutating -> "mutating recipe" + Classified ReadOnly -> "read-only recipe" + UnclassifiedWorkflow -> "unclassified workflow" + quote value = "\"" <> value <> "\"" + +-- | Stable codes are the only diagnostic content serialized into summaries. +suitePreflightReasonCode :: SuitePreflightIssue -> Text +suitePreflightReasonCode = \case + SuiteFileRootFailed _ -> "suite-file-root-invalid" + SuiteIsolationFailed (SharedStateParallelUnsafe _ _) -> "shared-state-parallel-unsafe" + SuiteIsolationFailed IndependentStateHandoffRequired -> "independent-state-handoff-required" + SuiteScenarioFailed issue -> renderScenarioIssue issue + SuiteScenarioInputsUnexpected -> "scenario-inputs-unexpected" + SuiteIndependentExternalRequired -> "independent-state-external-required" + SuiteDependencyUnavailable -> "suite-dependency-unavailable" + SuiteExternalLifecycle -> "external-service-lifecycle" + SuiteNotFound _ -> "suite-not-found" + SuiteRunPreparationFailed RunBindingFailed {} -> "suite-binding-failed" + SuiteRunPreparationFailed _ -> "suite-preparation-failed" + SuiteUnsafeRun _ _ -> "mutation-authorization-required" + SuiteDuplicateArtifactStem _ -> "suite-duplicate-scenario" + SuiteSharedCurlExport _ -> "suite-shared-curl-export" + SuiteReportDirectoryRequired -> "suite-report-directory-required" + SuiteInvalidReportDirectory _ -> "suite-invalid-report-directory" + SuiteReportPathExists _ -> "suite-report-path-exists" + SuiteReportPathIsSymbolicLink _ -> "suite-report-path-symlink" + SuiteReportPathIsNotDirectory _ -> "suite-report-path-not-directory" + SuiteReportIoError _ _ -> "suite-report-io-error" + SuiteCheckFailed _ _ -> "suite-check-preparation-failed" + SuiteServiceNotFound _ -> "suite-service-not-found" + SuiteServiceBindingFailed _ -> "suite-service-binding-failed" + SuiteServiceResolutionFailed _ -> "suite-service-resolution-failed" + +suitePreflightSetupFailure :: SuitePreflightIssue -> Bool +suitePreflightSetupFailure = \case + SuiteDependencyUnavailable -> True + SuiteScenarioFailed ScenarioFileUnreadable -> True + SuiteScenarioFailed ScenarioRuntimeInputFailed -> True + SuiteRunPreparationFailed RunBindingFailed {} -> True + SuiteCheckFailed _ _ -> True + SuiteServiceBindingFailed _ -> True + _ -> False diff --git a/src/HurlWorkbench/Suite/Run.hs b/src/HurlWorkbench/Suite/Run.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Suite/Run.hs @@ -0,0 +1,512 @@ +-- | Execute a fully preflighted suite, optionally inside one managed-service +-- lifecycle, and emit a redacted atomic summary. +module HurlWorkbench.Suite.Run + ( ServiceOutcome (..), + SuiteResult (..), + StepOutcome (..), + PhaseOutcome (..), + CommandOutcome (..), + LifecycleOutcome (..), + runSuite, + runSuiteWith, + finalizeSuitePreflight, + ) +where + +import Control.Applicative ((<|>)) +import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO) +import Control.Exception (IOException, SomeAsyncException, SomeException, fromException, mask, onException, throwIO, try) +import Data.Aeson qualified as Aeson +import Data.Bits ((.&.)) +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime, addUTCTime, diffUTCTime, getCurrentTime) +import HurlWorkbench.Check.Run +import HurlWorkbench.Hurl.Format (HurlfmtCapabilities, HurlfmtError, validateRenderedWorkflow) +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Prelude +import HurlWorkbench.Process.Run +import HurlWorkbench.Run.Batch +import HurlWorkbench.Service.Group +import HurlWorkbench.Service.Resolve +import HurlWorkbench.Suite.Resolve +import HurlWorkbench.Workflow.Render (RenderedWorkflow) +import HurlWorkbench.Workspace.Context (ValidatedWorkspace) +import HurlWorkbench.Workspace.Types (CheckName (..), IsolationPolicy (..), ServiceName (..), ServiceStep (..), SuiteName (..)) +import System.Directory (createDirectoryIfMissing, removeFile, renameFile) +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, ()) +import System.IO (Handle, IOMode (WriteMode), hClose, withBinaryFile) +import System.IO.Temp (openBinaryTempFile, withSystemTempDirectory) +import System.Posix.Files + ( accessModes, + fileMode, + getFileStatus, + ownerExecuteMode, + ownerReadMode, + ownerWriteMode, + setFileMode, + unionFileModes, + ) +import System.Posix.Types (FileMode) +import System.Timeout qualified as Timeout + +data ServiceOutcome + = ServiceStopped + | ServiceFailed !ServiceError + deriving stock (Generic, Eq, Show) + +data StepOutcome = HurlStep !CaseResult | LifecycleStep !LifecycleOutcome | CheckStep !CheckResult + deriving stock (Generic, Eq, Show) + +data PhaseOutcome = PhaseOutcome + { phase :: !Text, + ordinal :: !Int, + status :: !CommandOutcome, + elapsed :: !(Maybe NominalDiffTime), + artifacts :: ![FilePath], + cleanupFailure :: !(Maybe ServiceError) + } + deriving stock (Generic, Eq, Show) + +data SuiteResult = SuiteResult + { cases :: ![CaseResult], + serviceOutcome :: !(Maybe ServiceOutcome), + summaryPath :: !(Maybe FilePath), + summaryError :: !(Maybe Text), + selectedExitCode :: !ExitCode, + steps :: ![StepOutcome], + services :: ![LifecycleOutcome], + phases :: ![PhaseOutcome], + primaryFailure :: !(Maybe Text), + cleanupDiagnostics :: ![ServiceError] + } + deriving stock (Generic, Eq, Show) + +runSuite :: HurlRunner -> HurlfmtCapabilities -> ValidatedWorkspace -> SuiteRequest -> IO (Either SuitePreflightError SuiteResult) +runSuite = runSuiteWith validateRenderedWorkflow + +runSuiteWith :: (HurlfmtCapabilities -> RenderedWorkflow -> IO (Either HurlfmtError ())) -> HurlRunner -> HurlfmtCapabilities -> ValidatedWorkspace -> SuiteRequest -> IO (Either SuitePreflightError SuiteResult) +runSuiteWith validateRendered runner capabilities validated request = + preflightFileRoot validated request >>= \case + Left err -> pure (Left err) + Right root -> do + let selected = request & #fileRoot .~ Just root + prepareSuiteWith validateRendered capabilities validated selected >>= \case + Left err -> Left <$> finalizeSuitePreflight validated selected err + Right prepared -> Right <$> executePreparedSuite runner prepared + +-- | One ownership boundary covers setup, every acquisition and barrier, active +-- batches, reverse service cleanup, and finally teardown. Observations survive +-- cancellation; only safe logical outcomes reach the summary. +executePreparedSuite :: HurlRunner -> PreparedSuite -> IO SuiteResult +executePreparedSuite runner prepared = withPhaseRoot $ \phaseRoot -> mask $ \restore -> do + observed <- newTVarIO Map.empty + lifecycle <- newTVarIO Map.empty + checks <- newTVarIO Map.empty + startups <- newTVarIO [] + phases <- newTVarIO Map.empty + primary <- newTVarIO Nothing + group <- newServiceGroup + let remember reason = atomically (modifyTVar' primary (\current -> current <|> Just reason)) + phaseCommand phase ordinal budget command = do + let relative = "phases" Text.unpack phase show ordinal + directory = phaseRoot relative + artifacts = if isJust (prepared ^. #metadata . #summaryPath) then [relative "stdout", relative "stderr"] else [] + pending = PhaseOutcome phase ordinal CommandCancelled Nothing artifacts Nothing + atomically (modifyTVar' phases (Map.insert (phase, ordinal) pending)) + began <- getCurrentTime + attempted <- try @IOException $ do + createDirectoryIfMissing True directory + traverse_ (`setFileMode` secureDirectoryMode) [takeDirectory (takeDirectory directory), takeDirectory directory, directory] + withCapture (directory "stdout") $ \stdout -> + withCapture (directory "stderr") $ \stderr -> + runCommand (ServiceName phase) budget command stdout stderr + let (outcome, cleanup) = either (const (CommandStartFailed, Nothing)) id attempted + ended <- getCurrentTime + atomically (modifyTVar' phases (Map.insert (phase, ordinal) (pending & #status .~ outcome & #elapsed .~ Just (diffUTCTime ended began) & #cleanupFailure .~ cleanup))) + pure (outcome == CommandPassed && isNothing cleanup) + setup = runSetup 0 (prepared ^. #setupCommands) + runSetup _ [] = pure (Right ()) + runSetup ordinal (command : rest) = do + passed <- phaseCommand "setup" ordinal (prepared ^. #commandTimeout) command + if passed + then runSetup (ordinal + 1) rest + else do + remember "setup-failed" + pure (Left (ServicePhaseFailed "setup")) + recordService event = atomically (modifyTVar' startups (<> [event])) + startAll [] = pure (Right ()) + startAll (service : rest) = do + result <- startNamedObserved group service recordService + case result of + Left err -> pure (Left err) + Right () -> startAll rest + executeSteps _ [] = pure (Right ()) + executeSteps ordinal (step : rest) = case step of + HurlBatch offset cases -> do + batch <- + watchServices group $ + Right + <$> runBatchObserved + runner + (prepared ^. #batchOptions) + cases + ( \caseIndex result -> do + atomically (modifyTVar' observed (Map.insert (offset + caseIndex) result)) + when (result ^. #outcome /= CasePassed) (remember "hurl-failed") + ) + case batch of + Left err -> pure (Left err) + Right result + | prepared ^. #batchOptions . #failFast, result ^. #selectedExitCode /= ExitSuccess -> pure (Right ()) + | otherwise -> executeSteps (ordinal + 1) rest + CheckBarrier check -> do + result <- + watchServices group $ + Right + <$> runCheckObserved + phaseRoot + check + ( \outcome -> do + atomically (modifyTVar' checks (Map.insert ordinal outcome)) + unless (checkPassed outcome) (remember "check-failed") + ) + case result of + Left err -> pure (Left err) + Right outcome + | not (null (outcome ^. #cleanupDiagnostics)) -> pure (Right ()) + | not (checkPassed outcome), prepared ^. #batchOptions . #failFast -> pure (Right ()) + | otherwise -> executeSteps (ordinal + 1) rest + ServiceBarrier operation -> do + let (name, action) = stepLabel operation + pending = LifecycleOutcome name action "cancelled" 0 Nothing + atomically (modifyTVar' lifecycle (Map.insert ordinal pending)) + began <- getCurrentTime + result <- applyServiceStepObserved group (prepared ^. #managedServices) operation recordService + ended <- getCurrentTime + atomically (modifyTVar' lifecycle (Map.insert ordinal (pending & #status .~ either (const "failed") (const "passed") result & #elapsed .~ diffUTCTime ended began & #failure .~ either Just (const Nothing) result))) + case result of + Left err -> pure (Left err) + Right () -> executeSteps (ordinal + 1) rest + execute = + setup >>= \case + Left err -> pure (Left err) + Right () -> + startAll (prepared ^. #managedServices) >>= \case + Left err -> pure (Left err) + Right () -> executeSteps 0 (prepared ^. #steps) + teardown = do + began <- getCurrentTime + let deadline = addUTCTime (prepared ^. #cleanupTimeout) began + go _ [] = pure () + go ordinal (command : rest) = do + now <- getCurrentTime + if now >= deadline + then pure () + else do + _passed <- phaseCommand "teardown" ordinal (min (prepared ^. #commandTimeout) (diffUTCTime deadline now)) command + outcomes <- readTVarIO phases + let timedOut = maybe False ((== CommandTimedOut) . view #status) (Map.lookup ("teardown", ordinal) outcomes) + unless (timedOut && diffUTCTime deadline now <= prepared ^. #commandTimeout) (go (ordinal + 1) rest) + go 0 (prepared ^. #teardownCommands) + execution <- try @SomeException (restore execute) + case execution of + Right (Left _) -> remember "service-failed" + _ -> pure () + cleanup <- cleanupServices group + teardown + completed <- readTVarIO observed + barrierResults <- readTVarIO lifecycle + checkResults <- readTVarIO checks + serviceStarts <- readTVarIO startups + phaseResults <- readTVarIO phases + primaryFailure <- readTVarIO primary + let cancelled = case execution of Left err -> isJust (fromException err :: Maybe SomeAsyncException); _ -> False + serviceError = case execution of Right (Left err) -> Just err; _ -> Nothing + missingReason + | cancelled = BatchCancelled + | isJust serviceError || any (not . null . view #cleanupDiagnostics) checkResults = BatchPrerequisiteFailed + | otherwise = FailFastTriggered + caseResults = [Map.findWithDefault (prerequisiteFailed batchCase & #outcome .~ CaseSkipped missingReason) caseIndex completed | (caseIndex, batchCase) <- zip [0 ..] (toList (prepared ^. #cases))] + phaseOutcomes = [Map.findWithDefault (PhaseOutcome phase ordinal CommandSkipped Nothing [] Nothing) (phase, ordinal) phaseResults | (phase, commands) <- [("setup", prepared ^. #setupCommands), ("teardown", prepared ^. #teardownCommands)], ordinal <- [0 .. length commands - 1]] + cleanupErrors = + mapMaybe (view #failure) cleanup + <> mapMaybe (view #cleanupFailure) phaseOutcomes + <> [ServicePhaseFailed "teardown" | phase <- phaseOutcomes, phase ^. #phase == "teardown", phase ^. #status /= CommandPassed] + allServiceErrors = maybe [] pure serviceError <> cleanupErrors + serviceOutcome + | err : _ <- allServiceErrors = Just (ServiceFailed err) + | null (prepared ^. #managedServices) = Nothing + | otherwise = Just ServiceStopped + exitCode + | cancelled = ExitFailure 130 + | not (null allServiceErrors) = ExitFailure 4 + | any startFailed stepResults = ExitFailure 3 + | otherwise = selectStepExit stepResults + stepResults = + concat + [ case step of + HurlBatch offset cases -> map HurlStep (take (length cases) (drop offset (toList caseResults))) + CheckBarrier check -> [CheckStep (Map.findWithDefault (skippedCheck (skipStatus missingReason) check) ordinal checkResults)] + ServiceBarrier operation -> let (name, action) = stepLabel operation in [LifecycleStep (Map.findWithDefault (LifecycleOutcome name action "skipped" 0 Nothing) ordinal barrierResults)] + | (ordinal, step) <- zip [0 :: Int ..] (prepared ^. #steps) + ] + provisional = + SuiteResult + caseResults + serviceOutcome + Nothing + Nothing + exitCode + stepResults + (serviceStarts <> [event | LifecycleStep event <- stepResults] <> cleanup) + phaseOutcomes + (primaryFailure <|> if null cleanupErrors then Nothing else Just "cleanup-failed") + cleanupErrors + summary <- case prepared ^. #metadata . #summaryPath of + Nothing -> pure (Right Nothing) + Just path -> do + let write = writeSummary path (summaryValueWithStatus (if cancelled then "cancelled" else exitStatus exitCode) (prepared ^. #metadata) provisional) + written <- + if cancelled + then fromMaybe (Left "suite summary write timed out") <$> Timeout.timeout 1000000 write + else write + pure (Just path <$ written) + let finished = case summary of + Right path -> provisional & #summaryPath .~ path + Left message -> provisional & #summaryError .~ Just message & #selectedExitCode .~ (if null allServiceErrors then ExitFailure 3 else ExitFailure 4) + case execution of + Left err -> throwIO err + Right _ -> pure finished + where + withPhaseRoot action = case prepared ^. #metadata . #summaryPath of + Just path -> action (takeDirectory path) + Nothing -> withSystemTempDirectory "hurl-workbench-phases" action + +stepLabel :: ServiceStep -> (ServiceName, Text) +stepLabel = \case Stop name -> (name, "stop"); Start name -> (name, "start"); Restart name -> (name, "restart") + +withCapture :: FilePath -> (Handle -> IO a) -> IO a +withCapture path action = withBinaryFile path WriteMode $ \handle -> do + setFileMode path secureFileMode + action handle + +secureDirectoryMode :: FileMode +secureDirectoryMode = secureFileMode `unionFileModes` ownerExecuteMode + +prerequisiteFailed :: BatchCase -> CaseResult +prerequisiteFailed batchCase = + CaseResult + { name = batchCase ^. #name, + outcome = CaseSkipped BatchPrerequisiteFailed, + elapsed = Nothing, + outputPath = Nothing, + capturedOutput = Nothing + } + +startFailed :: StepOutcome -> Bool +startFailed (HurlStep result) = case result ^. #outcome of CaseStartFailed _ -> True; _ -> False +startFailed (CheckStep result) = result ^. #outcome == CheckStartFailed +startFailed (LifecycleStep _) = False + +selectStepExit :: [StepOutcome] -> ExitCode +selectStepExit results = fromMaybe fallback (firstFailure results) + where + fallback + | all passed results = ExitSuccess + | otherwise = ExitFailure 3 + passed (HurlStep result) = result ^. #outcome == CasePassed + passed (CheckStep result) = checkPassed result + passed (LifecycleStep result) = result ^. #status == "passed" + firstFailure = \case + [] -> Nothing + HurlStep result : remaining -> case result ^. #outcome of + CaseFailed code -> Just code + CaseStartFailed _ -> Just (ExitFailure 3) + _ -> firstFailure remaining + CheckStep result : remaining | checkExitCode result /= ExitSuccess -> Just (checkExitCode result) + _ : remaining -> firstFailure remaining + +skipStatus :: SkipReason -> Text +skipStatus = \case + FailFastTriggered -> "skipped-fail-fast" + BatchPrerequisiteFailed -> "skipped-prerequisite-failed" + BatchCancelled -> "cancelled" + +writeSummary :: FilePath -> Aeson.Value -> IO (Either Text ()) +writeSummary path value = do + written <- try @IOException $ do + let directory = takeDirectory path + (temporaryPath, handle) <- openBinaryTempFile directory ".summary.json.tmp" + let cleanup = do + _ <- try @IOException (hClose handle) + _ <- try @IOException (removeFile temporaryPath) + pure () + ( do + setFileMode temporaryPath secureFileMode + verifyMode temporaryPath + LazyByteString.hPut handle (Aeson.encode value) + hClose handle + renameFile temporaryPath path + setFileMode path secureFileMode + verifyMode path + ) + `onException` cleanup + pure $ case written of + Left _ -> Left "could not write suite summary" + Right () -> Right () + +summaryValueWithStatus :: Text -> SuiteMetadata -> SuiteResult -> Aeson.Value +summaryValueWithStatus status metadata result = + Aeson.object + [ "suite" Aeson..= unSuiteName (metadata ^. #name), + "isolation" Aeson..= isolationLabel (metadata ^. #isolation), + "status" Aeson..= status, + "service" Aeson..= serviceStatus (result ^. #serviceOutcome), + "primaryFailure" Aeson..= (result ^. #primaryFailure), + "cleanupDiagnostics" Aeson..= (map (const ("cleanup-failed" :: Text)) (result ^. #cleanupDiagnostics) <> concat [check ^. #cleanupDiagnostics | CheckStep check <- result ^. #steps]), + "services" Aeson..= map lifecycleValue (result ^. #services), + "phases" Aeson..= map phaseValue (result ^. #phases), + "steps" Aeson..= map stepValue (result ^. #steps), + "cases" Aeson..= zipWith caseValue (toList (metadata ^. #scenarios)) (toList (result ^. #cases)) + ] + where + caseValue logical caseResult = + Aeson.object + [ "name" Aeson..= (logical ^. #name), + "scenario" Aeson..= (logical ^. #scenario), + "status" Aeson..= caseStatus (caseResult ^. #outcome), + "elapsedSeconds" Aeson..= fmap (realToFrac @NominalDiffTime @Double) (caseResult ^. #elapsed), + "reports" Aeson..= case (caseResult ^. #outcome) of + CaseSkipped _ -> [] + CaseStartFailed _ -> [] + _ -> logical ^. #reports + ] + +lifecycleValue :: LifecycleOutcome -> Aeson.Value +lifecycleValue event = + Aeson.object + [ "kind" Aeson..= ("service" :: Text), + "name" Aeson..= unServiceName (event ^. #name), + "action" Aeson..= (event ^. #action), + "status" Aeson..= (event ^. #status), + "artifacts" Aeson..= ([] :: [FilePath]), + "elapsedSeconds" Aeson..= realToFrac @NominalDiffTime @Double (event ^. #elapsed) + ] + +phaseValue :: PhaseOutcome -> Aeson.Value +phaseValue event = + Aeson.object + [ "phase" Aeson..= (event ^. #phase), + "index" Aeson..= (event ^. #ordinal), + "status" Aeson..= commandStatus (event ^. #status), + "elapsedSeconds" Aeson..= fmap (realToFrac @NominalDiffTime @Double) (event ^. #elapsed), + "artifacts" Aeson..= (event ^. #artifacts) + ] + +commandStatus :: CommandOutcome -> Text +commandStatus = \case + CommandPassed -> "passed" + CommandFailed -> "failed" + CommandTimedOut -> "timed-out" + CommandStartFailed -> "start-failed" + CommandSkipped -> "skipped" + CommandCancelled -> "cancelled" + +stepValue :: StepOutcome -> Aeson.Value +stepValue (LifecycleStep event) = lifecycleValue event +stepValue (CheckStep result) = + Aeson.object + [ "kind" Aeson..= ("check" :: Text), + "name" Aeson..= unCheckName (result ^. #name), + "status" Aeson..= checkStatus result, + "expectedStatus" Aeson..= (result ^. #expectedStatus), + "actualStatus" Aeson..= (result ^. #actualStatus), + "elapsedSeconds" Aeson..= fmap (realToFrac @NominalDiffTime @Double) (result ^. #elapsed), + "stdout" Aeson..= (result ^. #stdoutPath), + "stderr" Aeson..= (result ^. #stderrPath), + "cleanupDiagnostics" Aeson..= (result ^. #cleanupDiagnostics) + ] +stepValue (HurlStep result) = + Aeson.object + ["kind" Aeson..= ("hurl" :: Text), "name" Aeson..= (result ^. #name), "status" Aeson..= caseStatus (result ^. #outcome)] + +isolationLabel :: IsolationPolicy -> Text +isolationLabel SharedState = "shared-state" +isolationLabel IndependentState = "independent-state" + +-- | Report a refusal only when validated logical names and the ordinary safe +-- report reservation rules make a destination available. No runner is involved. +finalizeSuitePreflight :: ValidatedWorkspace -> SuiteRequest -> SuitePreflightError -> IO SuitePreflightError +finalizeSuitePreflight workspace request original + | any isReportFailure (original ^. #issues) = pure original + | otherwise = case suiteMetadata workspace request of + Left _ -> pure original + Right metadata -> case metadata ^. #summaryPath of + Nothing -> pure original + Just path -> + reserveSuiteSummary workspace request metadata >>= \case + Left issue -> pure (append issue) + Right () -> + writeSummary path (preflightSummary metadata) <&> \case + Left _ -> append (SuiteReportIoError path "summary-write-failed") + Right () -> original + where + append issue = original & #issues %~ (<> (issue :| [])) + isReportFailure = \case + SuiteFileRootFailed _ -> True + SuiteReportPathExists _ -> True + SuiteReportPathIsSymbolicLink _ -> True + SuiteReportPathIsNotDirectory _ -> True + SuiteInvalidReportDirectory _ -> True + SuiteReportIoError _ _ -> True + _ -> False + preflightSummary metadata = + Aeson.object + [ "suite" Aeson..= unSuiteName (metadata ^. #name), + "isolation" Aeson..= isolationLabel (metadata ^. #isolation), + "status" Aeson..= (if any suitePreflightSetupFailure (original ^. #issues) then "setup-failed" else "refused" :: Text), + "reasonCodes" Aeson..= map suitePreflightReasonCode (toList (original ^. #issues)), + "cases" + Aeson..= map + ( \logical -> + Aeson.object + [ "name" Aeson..= (logical ^. #name), + "scenario" Aeson..= (logical ^. #scenario), + "status" Aeson..= ("not-started" :: Text), + "reports" Aeson..= ([] :: [FilePath]) + ] + ) + (toList (metadata ^. #scenarios)) + ] + +serviceStatus :: Maybe ServiceOutcome -> Text +serviceStatus = \case + Nothing -> "external-or-not-configured" + Just ServiceStopped -> "stopped" + Just (ServiceFailed _) -> "failed" + +caseStatus :: CaseOutcome -> Text +caseStatus = \case + CasePassed -> "passed" + CaseFailed _ -> "failed" + CaseStartFailed _ -> "start-failed" + CaseSkipped FailFastTriggered -> "skipped-fail-fast" + CaseSkipped BatchPrerequisiteFailed -> "skipped-prerequisite-failed" + CaseSkipped BatchCancelled -> "cancelled" + +exitStatus :: ExitCode -> Text +exitStatus = \case + ExitSuccess -> "passed" + ExitFailure _ -> "failed" + +verifyMode :: FilePath -> IO () +verifyMode path = do + actual <- (.&. accessModes) . fileMode <$> getFileStatus path + unless (actual == secureFileMode) (ioError (userError ("insecure permissions on " <> path))) + +secureFileMode :: FileMode +secureFileMode = ownerReadMode `unionFileModes` ownerWriteMode diff --git a/src/HurlWorkbench/Suite/Scenario.hs b/src/HurlWorkbench/Suite/Scenario.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Suite/Scenario.hs @@ -0,0 +1,241 @@ +-- | Private caller-owned fixture assignments. Only full verification produces +-- executable per-scenario inputs; raw provider values never appear in errors. +module HurlWorkbench.Suite.Scenario + ( ScenarioInputs (..), + ScenarioAssignment (..), + ScenarioBinding (..), + ScenarioSecret (..), + VerifiedScenarioInputs, + ScenarioIssue (..), + decodeScenarioInputs, + loadScenarioInputs, + verifyScenarioInputs, + scenarioBindingInput, + renderScenarioIssue, + ) +where + +import Control.Exception (IOException, try) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser) +import Data.Bifunctor (first) +import Data.Bits ((.&.)) +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as Char8 +import Data.Char (isControl, isSpace) +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import HurlWorkbench.Parameter.Properties +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Selection +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate (isValidEntityName, isValidEnvironmentName) +import Network.HTTP.Client qualified as HTTP +import System.FilePath (splitDirectories) +import System.Posix.Files + ( fileMode, + getSymbolicLinkStatus, + groupModes, + isRegularFile, + otherModes, + unionFileModes, + ) + +newtype ScenarioInputs = ScenarioInputs [ScenarioAssignment] + deriving stock (Generic, Eq) + +data ScenarioAssignment = ScenarioAssignment + { scenario :: !FilePath, + fixtureId :: !Text, + endpoint :: !Text, + endpointParameter :: !ParameterName, + bindings :: ![ScenarioBinding], + secretEnvironment :: ![ScenarioSecret] + } + deriving stock (Generic, Eq) + +data ScenarioBinding = ScenarioBinding + { parameter :: !ParameterName, + value :: !Text + } + deriving stock (Generic, Eq) + +data ScenarioSecret = ScenarioSecret + { parameter :: !ParameterName, + variable :: !Text + } + deriving stock (Generic, Eq) + +newtype VerifiedScenarioInputs = VerifiedScenarioInputs (Map FilePath BindingInput) + +instance Show ScenarioInputs where show _ = "ScenarioInputs " + +instance Show ScenarioAssignment where show _ = "ScenarioAssignment " + +instance Show ScenarioBinding where show _ = "ScenarioBinding " + +instance Show ScenarioSecret where show _ = "ScenarioSecret " + +instance Show VerifiedScenarioInputs where show _ = "VerifiedScenarioInputs " + +data ScenarioIssue + = ScenarioFileUnreadable + | ScenarioFileNotPrivateRegular + | ScenarioMalformedInput + | ScenarioUnsupportedVersion + | ScenarioInvalidLabel + | ScenarioAssignmentMismatch + | ScenarioDuplicateFixture + | ScenarioInvalidFixture + | ScenarioDuplicateEndpoint + | ScenarioInvalidEndpoint + | ScenarioInvalidParameter + | ScenarioDuplicateParameter + | ScenarioConflictingBinding + | ScenarioRuntimeInputFailed + deriving stock (Generic, Eq, Show) + +instance Aeson.FromJSON ScenarioInputs where + parseJSON = Aeson.withObject "scenario-inputs" $ \object -> do + exactFields ["version", "scenarios"] object + version <- object Aeson..: "version" :: Parser Int + unless (version == 1) (fail "unsupported-version") + ScenarioInputs <$> object Aeson..: "scenarios" + +instance Aeson.FromJSON ScenarioAssignment where + parseJSON = Aeson.withObject "assignment" $ \object -> do + exactFields ["scenario", "fixtureId", "endpoint", "endpointParameter", "bindings", "secretEnvironment"] object + ScenarioAssignment <$> object Aeson..: "scenario" <*> object Aeson..: "fixtureId" <*> object Aeson..: "endpoint" <*> (ParameterName <$> object Aeson..: "endpointParameter") <*> object Aeson..: "bindings" <*> object Aeson..: "secretEnvironment" + +instance Aeson.FromJSON ScenarioBinding where + parseJSON = Aeson.withObject "binding" $ \object -> do + exactFields ["parameter", "value"] object + ScenarioBinding <$> (ParameterName <$> object Aeson..: "parameter") <*> object Aeson..: "value" + +instance Aeson.FromJSON ScenarioSecret where + parseJSON = Aeson.withObject "secret" $ \object -> do + exactFields ["parameter", "variable"] object + ScenarioSecret <$> (ParameterName <$> object Aeson..: "parameter") <*> object Aeson..: "variable" + +exactFields :: [Aeson.Key] -> Aeson.Object -> Parser () +exactFields expected object = unless (Set.fromList expected == Set.fromList (KeyMap.keys object)) (fail "invalid-fields") + +decodeScenarioInputs :: ByteString.ByteString -> Either ScenarioIssue ScenarioInputs +decodeScenarioInputs bytes = case Aeson.eitherDecodeStrict @Aeson.Value bytes of + Left _ -> Left ScenarioMalformedInput + Right (Aeson.Object object) + | Just (Aeson.Number version) <- KeyMap.lookup "version" object, version /= 1 -> Left ScenarioUnsupportedVersion + Right _ -> first (const ScenarioMalformedInput) (Aeson.eitherDecodeStrict bytes) + +loadScenarioInputs :: FilePath -> IO (Either ScenarioIssue ScenarioInputs) +loadScenarioInputs path = do + status <- try @IOException (getSymbolicLinkStatus path) + case status of + Left _ -> pure (Left ScenarioFileUnreadable) + Right file + | not (isRegularFile file) || fileMode file .&. (groupModes `unionFileModes` otherModes) /= 0 -> pure (Left ScenarioFileNotPrivateRegular) + | otherwise -> fmap (either (const (Left ScenarioFileUnreadable)) decodeScenarioInputs) (try @IOException (ByteString.readFile path)) + +-- | Validate the entire assignment and common input before any run preparation. +-- File channels are inspected for conflicting names; the existing binding +-- resolver retains ordinary suite input precedence. +verifyScenarioInputs :: ValidatedWorkspace -> [ExpandedRun] -> BindingInput -> ScenarioInputs -> IO (Either ScenarioIssue VerifiedScenarioInputs) +verifyScenarioInputs workspace runs common (ScenarioInputs assignments) = do + loaded <- snapshotInputs common + origins <- traverse (endpointOrigin . view #endpoint) assignments + pure $ do + (input, fileNames) <- loaded + endpointKeys <- sequence origins + let expected = map (view #artifactStem) runs + labels = map (view #scenario) assignments + ensure (all validLabel labels) ScenarioInvalidLabel + ensure (unique expected && unique labels && Set.fromList expected == Set.fromList labels) ScenarioAssignmentMismatch + ensure (all (validFixture . view #fixtureId) assignments) ScenarioInvalidFixture + ensure (unique (map (view #fixtureId) assignments)) ScenarioDuplicateFixture + ensure (unique endpointKeys) ScenarioDuplicateEndpoint + let assignmentsByStem = Map.fromList [(assignment ^. #scenario, assignment) | assignment <- assignments] + verified <- traverse (verifyRun input fileNames assignmentsByStem) runs + pure (VerifiedScenarioInputs (Map.fromList verified)) + where + verifyRun input fileNames assignmentsByStem run = do + assignment <- maybe (Left ScenarioAssignmentMismatch) Right (Map.lookup (run ^. #artifactStem) assignmentsByStem) + let endpointName = assignment ^. #endpointParameter + plain = (endpointName, assignment ^. #endpoint) : [(binding ^. #parameter, binding ^. #value) | binding <- assignment ^. #bindings] + secret = [(binding ^. #parameter, binding ^. #variable) | binding <- assignment ^. #secretEnvironment] + names = map fst plain <> map fst secret + supplied = Set.fromList names + committed = Set.unions (map (Map.keysSet . view #values) (run ^. #bindingLayers)) + runtime = Map.keysSet (input ^. #plainOverrides) <> Map.keysSet (input ^. #secretEnvironmentOverrides) + declared = Set.fromList (run ^. #workflow . #workflow . #parameters) + checkKind kind name = name `Set.member` declared && maybe False ((== kind) . view #kind) (lookupParameter name workspace) + ensure (unique names) ScenarioDuplicateParameter + ensure (all (checkKind Plain . fst) plain && all (checkKind Secret . fst) secret && all (isValidEnvironmentName . snd) secret) ScenarioInvalidParameter + ensure (Set.null (supplied `Set.intersection` (committed <> runtime <> fileNames))) ScenarioConflictingBinding + values <- traverse (\(name, value) -> (name,) <$> first (const ScenarioRuntimeInputFailed) (mkHurlValueLiteral value)) plain + pure (run ^. #artifactStem, input {plainOverrides = Map.fromList values <> input ^. #plainOverrides, secretEnvironmentOverrides = Map.fromList secret <> input ^. #secretEnvironmentOverrides}) + +-- | Verified assignments are immutable; callers cannot manufacture a verified +-- value or change its mapping. Only expanded logical scenarios can select input. +scenarioBindingInput :: VerifiedScenarioInputs -> ExpandedRun -> Maybe BindingInput +scenarioBindingInput (VerifiedScenarioInputs inputs) run = Map.lookup (run ^. #artifactStem) inputs + +snapshotInputs :: BindingInput -> IO (Either ScenarioIssue (BindingInput, Set ParameterName)) +snapshotInputs input = do + variables <- traverse (load parseVariableProperties) (input ^. #variableFiles) + secrets <- traverse (load parseSecretProperties) (input ^. #secretFiles) + pure $ do + plainFiles <- sequence variables + secretMaps <- sequence secrets + pure (input, Set.unions (map Map.keysSet plainFiles <> map Map.keysSet secretMaps)) + where + load parser path = do + bytes <- try @IOException (ByteString.readFile path) + pure $ first (const ScenarioRuntimeInputFailed) (bytes >>= first (const (userError "invalid runtime input")) . parser path) + +endpointOrigin :: Text -> IO (Either ScenarioIssue (Bool, Text, Int)) +endpointOrigin endpoint + | Text.any (\c -> isControl c || isSpace c || c `elem` ("@?#" :: String)) endpoint = pure (Left ScenarioInvalidEndpoint) + | not (any (`Text.isPrefixOf` lowered) ["http://", "https://"]) = pure (Left ScenarioInvalidEndpoint) + | otherwise = do + parsed <- try @HTTP.HttpException (HTTP.parseRequest (Text.unpack lowered)) + pure $ case parsed of + Left _ -> Left ScenarioInvalidEndpoint + Right request + | HTTP.path request /= "/" || ByteString.null (HTTP.host request) || HTTP.port request < 1 || HTTP.port request > 65535 -> Left ScenarioInvalidEndpoint + | otherwise -> Right (HTTP.secure request, Text.toLower (Text.pack (Char8.unpack (HTTP.host request))), HTTP.port request) + where + lowered = Text.toLower endpoint + +validLabel :: FilePath -> Bool +validLabel path = not (null path) && all (isValidEntityName . Text.pack) (splitDirectories path) + +validFixture :: Text -> Bool +validFixture value = not (Text.null value) && not (Text.any isControl value) + +unique :: (Ord a) => [a] -> Bool +unique values = Set.size (Set.fromList values) == length values + +ensure :: Bool -> issue -> Either issue () +ensure condition issue = if condition then Right () else Left issue + +renderScenarioIssue :: ScenarioIssue -> Text +renderScenarioIssue = \case + ScenarioFileUnreadable -> "scenario-file-unreadable" + ScenarioFileNotPrivateRegular -> "scenario-file-not-private-regular" + ScenarioMalformedInput -> "scenario-malformed-input" + ScenarioUnsupportedVersion -> "scenario-unsupported-version" + ScenarioInvalidLabel -> "scenario-invalid-label" + ScenarioAssignmentMismatch -> "scenario-assignment-mismatch" + ScenarioDuplicateFixture -> "scenario-duplicate-fixture" + ScenarioInvalidFixture -> "scenario-invalid-fixture" + ScenarioDuplicateEndpoint -> "scenario-duplicate-endpoint" + ScenarioInvalidEndpoint -> "scenario-invalid-endpoint" + ScenarioInvalidParameter -> "scenario-invalid-parameter" + ScenarioDuplicateParameter -> "scenario-duplicate-parameter" + ScenarioConflictingBinding -> "scenario-conflicting-binding" + ScenarioRuntimeInputFailed -> "scenario-runtime-input-failed" diff --git a/src/HurlWorkbench/Workflow/Render.hs b/src/HurlWorkbench/Workflow/Render.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workflow/Render.hs @@ -0,0 +1,190 @@ +-- | Byte-faithful composition of complete Hurl entry fragments. +module HurlWorkbench.Workflow.Render + ( RenderedFragmentSpan (..), + RenderedWorkflow (..), + RenderError (..), + renderWorkflow, + renderRenderError, + ) +where + +import Control.Exception (IOException, displayException, try) +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import HurlWorkbench.Prelude +import HurlWorkbench.Workflow.Resolve +import HurlWorkbench.Workspace.Types + +-- | Inclusive rendered line range occupied by one source fragment. Separator +-- lines inserted by the composer do not belong to either adjacent fragment. +data RenderedFragmentSpan = RenderedFragmentSpan + { fragmentName :: !FragmentName, + fragmentPath :: !FilePath, + firstLine :: !Int, + lastLine :: !Int + } + deriving stock (Generic, Eq, Show) + +-- | Deterministic Hurl source plus the provenance needed to explain parser +-- diagnostics. +data RenderedWorkflow = RenderedWorkflow + { workspaceRoot :: !WorkspaceRoot, + workflowName :: !WorkflowName, + sourceFragments :: !(NonEmpty ResolvedFragment), + fragmentSpans :: !(NonEmpty RenderedFragmentSpan), + contents :: !Text + } + deriving stock (Generic, Eq, Show) + +data RenderError + = FragmentReadFailed !FragmentName !FilePath !Text + | InvalidFragmentUtf8 !FragmentName !FilePath !Int !Text + | EmptyFragment !FragmentName !FilePath + deriving stock (Generic, Eq, Show) + +data LoadedFragment = LoadedFragment + { resolved :: !ResolvedFragment, + text :: !Text + } + deriving stock (Generic, Eq, Show) + +renderWorkflow :: ResolvedWorkflow -> IO (Either RenderError RenderedWorkflow) +renderWorkflow resolvedWorkflow = do + loaded <- traverse loadFragment (resolvedWorkflow ^. #sourceFragments) + pure $ do + fragments <- sequenceA loaded + let (renderedText, spans) = composeFragments fragments + definition = resolvedWorkflow ^. #workflow + pure + RenderedWorkflow + { workspaceRoot = resolvedWorkflow ^. #workspaceRoot, + workflowName = definition ^. #name, + sourceFragments = resolvedWorkflow ^. #sourceFragments, + fragmentSpans = spans, + contents = ensureFinalLineFeed renderedText + } + +loadFragment :: ResolvedFragment -> IO (Either RenderError LoadedFragment) +loadFragment resolvedFragment = do + let definition = resolvedFragment ^. #fragment + name = definition ^. #name + path = resolvedFragment ^. #fragmentPath + readResult <- try (ByteString.readFile path) + pure $ case readResult of + Left (err :: IOException) -> Left (FragmentReadFailed name path (Text.pack (displayException err))) + Right bytes + | ByteString.null bytes -> Left (EmptyFragment name path) + | otherwise -> case Text.Encoding.decodeUtf8' bytes of + Right decoded -> Right LoadedFragment {resolved = resolvedFragment, text = decoded} + Left err -> + Left + ( InvalidFragmentUtf8 + name + path + (firstInvalidUtf8Offset bytes) + (Text.pack (displayException err)) + ) + +composeFragments :: NonEmpty LoadedFragment -> (Text, NonEmpty RenderedFragmentSpan) +composeFragments fragments = + case NonEmpty.toList fragments of + first : rest -> + let initialText = first ^. #text + initialSpan = spanAt 1 first + initialNextLine = 1 + lineFeeds initialText + (pieces, spans, _, _) = foldl appendOne ([initialText], [initialSpan], initialNextLine, initialText) rest + in (Text.concat (reverse pieces), NonEmpty.fromList (reverse spans)) + [] -> error "composeFragments: impossible empty NonEmpty" + where + appendOne (pieces, spans, nextLine, priorText) loaded = + let separator = fragmentSeparator priorText + first = nextLine + lineFeeds separator + currentText = loaded ^. #text + currentSpan = spanAt first loaded + followingLine = first + lineFeeds currentText + in (currentText : separator : pieces, currentSpan : spans, followingLine, currentText) + +spanAt :: Int -> LoadedFragment -> RenderedFragmentSpan +spanAt first loaded = + let resolvedFragment = loaded ^. #resolved + definition = resolvedFragment ^. #fragment + fragmentText = loaded ^. #text + final = first + lineFeeds fragmentText - if Text.isSuffixOf "\n" fragmentText then 1 else 0 + in RenderedFragmentSpan + { fragmentName = definition ^. #name, + fragmentPath = resolvedFragment ^. #fragmentPath, + firstLine = first, + lastLine = max first final + } + +-- | Leave at least one blank line between fragments while never removing +-- source bytes. +fragmentSeparator :: Text -> Text +fragmentSeparator prior + | Text.isSuffixOf "\n\n" prior = "" + | Text.isSuffixOf "\n" prior = "\n" + | otherwise = "\n\n" + +ensureFinalLineFeed :: Text -> Text +ensureFinalLineFeed value + | Text.isSuffixOf "\n" value = value + | otherwise = value <> "\n" + +lineFeeds :: Text -> Int +lineFeeds = Text.count "\n" + +-- | Locate the first byte that makes the input invalid UTF-8. The public +-- decoder still decides validity; this scanner exists only to make its +-- otherwise offset-free error actionable. +firstInvalidUtf8Offset :: ByteString.ByteString -> Int +firstInvalidUtf8Offset bytes = go 0 + where + length_ = ByteString.length bytes + byte = ByteString.index bytes + + go offset + | offset >= length_ = max 0 (length_ - 1) + | current <= 0x7F = go (offset + 1) + | current >= 0xC2 && current <= 0xDF = continuationSequence offset [continuation] + | current == 0xE0 = continuationSequence offset [between 0xA0 0xBF, continuation] + | current >= 0xE1 && current <= 0xEC = continuationSequence offset [continuation, continuation] + | current == 0xED = continuationSequence offset [between 0x80 0x9F, continuation] + | current >= 0xEE && current <= 0xEF = continuationSequence offset [continuation, continuation] + | current == 0xF0 = continuationSequence offset [between 0x90 0xBF, continuation, continuation] + | current >= 0xF1 && current <= 0xF3 = continuationSequence offset [continuation, continuation, continuation] + | current == 0xF4 = continuationSequence offset [between 0x80 0x8F, continuation, continuation] + | otherwise = offset + where + current = byte offset + + continuationSequence start checks = check (start + 1) checks + where + check next [] = go next + check next (valid : remaining) + | next >= length_ = start + | valid (byte next) = check (next + 1) remaining + | otherwise = next + + continuation = between 0x80 0xBF + between lower upper value = value >= lower && value <= upper + +renderRenderError :: RenderError -> Text +renderRenderError = \case + FragmentReadFailed name path message -> + "could not read fragment " <> quoteName name <> " at " <> Text.pack path <> ": " <> message + InvalidFragmentUtf8 name path offset message -> + "fragment " + <> quoteName name + <> " at " + <> Text.pack path + <> " is not valid UTF-8 at byte offset " + <> Text.pack (show offset) + <> ": " + <> message + EmptyFragment name path -> + "fragment " <> quoteName name <> " at " <> Text.pack path <> " is empty" + where + quoteName = ("\"" <>) . (<> "\"") . unFragmentName diff --git a/src/HurlWorkbench/Workflow/Resolve.hs b/src/HurlWorkbench/Workflow/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workflow/Resolve.hs @@ -0,0 +1,69 @@ +-- | Resolve a validated workflow to the canonical files that supply its +-- ordered Hurl entries. +module HurlWorkbench.Workflow.Resolve + ( ResolvedFragment (..), + ResolvedWorkflow (..), + WorkflowError (..), + resolveWorkflow, + renderWorkflowError, + ) +where + +import Data.Generics.Labels () +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types + +-- | One declared fragment paired with the canonical, root-contained file +-- proved by semantic workspace validation. +data ResolvedFragment = ResolvedFragment + { fragment :: !Fragment, + fragmentPath :: !FilePath + } + deriving stock (Generic, Eq, Show) + +-- | A workflow whose ordered fragment names have all been resolved. +data ResolvedWorkflow = ResolvedWorkflow + { workspaceRoot :: !WorkspaceRoot, + workflow :: !Workflow, + sourceFragments :: !(NonEmpty ResolvedFragment) + } + deriving stock (Generic, Eq, Show) + +-- | A defensive resolution failure. Public command paths normally cannot see +-- the latter two cases because 'ValidatedWorkspace' rejects them first. +data WorkflowError + = WorkflowNotFound !WorkflowName + | WorkflowHasNoFragments !WorkflowName + | WorkflowFragmentNotFound !WorkflowName !FragmentName + deriving stock (Generic, Eq, Show) + +resolveWorkflow :: ValidatedWorkspace -> WorkflowName -> Either WorkflowError ResolvedWorkflow +resolveWorkflow validated selected = do + definition <- maybe (Left (WorkflowNotFound selected)) Right (lookupWorkflow selected validated) + fragmentNames <- maybe (Left (WorkflowHasNoFragments selected)) Right (nonEmpty (definition ^. #fragments)) + resolved <- traverse resolveFragment fragmentNames + pure + ResolvedWorkflow + { workspaceRoot = validatedRoot validated, + workflow = definition, + sourceFragments = resolved + } + where + resolveFragment fragmentName = + case (lookupFragment fragmentName validated, lookupFragmentFile fragmentName validated) of + (Just definition, Just path) -> Right ResolvedFragment {fragment = definition, fragmentPath = path} + _ -> Left (WorkflowFragmentNotFound selected fragmentName) + +renderWorkflowError :: WorkflowError -> Text +renderWorkflowError = \case + WorkflowNotFound name -> "unknown workflow " <> quote (unWorkflowName name) + WorkflowHasNoFragments name -> "workflow " <> quote (unWorkflowName name) <> " has no fragments" + WorkflowFragmentNotFound workflowName fragmentName -> + "workflow " + <> quote (unWorkflowName workflowName) + <> " refers to unresolved fragment " + <> quote (unFragmentName fragmentName) + +quote :: Text -> Text +quote value = "\"" <> value <> "\"" diff --git a/src/HurlWorkbench/Workspace/Context.hs b/src/HurlWorkbench/Workspace/Context.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workspace/Context.hs @@ -0,0 +1,135 @@ +-- | Loaded workspaces. +-- +-- A 'WorkspaceContext' is a decoded manifest plus its location. A +-- 'ValidatedWorkspace' is the only value later features accept: it can be +-- obtained solely through 'HurlWorkbench.Workspace.Validate.validateWorkspace', +-- carries its own root, and offers typed lookups by category-specific name. +module HurlWorkbench.Workspace.Context + ( -- * Decoded context + WorkspaceContext (..), + loadWorkspaceContext, + + -- * Validated workspace + ValidatedWorkspace, + validatedContext, + validatedManifestPath, + validatedRoot, + validatedWorkspace, + + -- ** Indexes + validatedParameters, + validatedFragments, + validatedWorkflows, + validatedRecipes, + validatedMatrices, + validatedChecks, + validatedServices, + validatedSuites, + + -- ** Lookups + lookupParameter, + lookupFragment, + lookupFragmentFile, + lookupWorkflow, + lookupRecipe, + lookupMatrix, + lookupCheck, + lookupCheckExecutable, + lookupService, + lookupSuite, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context.Internal (ValidatedWorkspace (..), WorkspaceContext (..)) +import HurlWorkbench.Workspace.Decode (decodeWorkspaceFile) +import HurlWorkbench.Workspace.Discover (WorkspaceSource, workspaceSourcePath) +import HurlWorkbench.Workspace.Error (WorkspaceError) +import HurlWorkbench.Workspace.Types +import System.Directory (canonicalizePath) +import System.FilePath (takeDirectory) + +-- | Canonicalize the manifest path and decode it. The workspace root is the +-- canonical directory containing the manifest. +loadWorkspaceContext :: WorkspaceSource -> IO (Either WorkspaceError WorkspaceContext) +loadWorkspaceContext source = do + manifest <- canonicalizePath (workspaceSourcePath source) + decoded <- decodeWorkspaceFile manifest + pure $ + decoded <&> \ws -> + WorkspaceContext + { manifestPath = manifest, + workspaceRoot = WorkspaceRoot (takeDirectory manifest), + workspace = ws + } + +validatedContext :: ValidatedWorkspace -> WorkspaceContext +validatedContext = view #context + +validatedManifestPath :: ValidatedWorkspace -> FilePath +validatedManifestPath = view (#context . #manifestPath) + +validatedRoot :: ValidatedWorkspace -> WorkspaceRoot +validatedRoot = view (#context . #workspaceRoot) + +-- | The decoded workspace, with every list in declaration order. +validatedWorkspace :: ValidatedWorkspace -> Workspace +validatedWorkspace = view (#context . #workspace) + +validatedParameters :: ValidatedWorkspace -> Map ParameterName Parameter +validatedParameters = view #parameterIndex + +validatedFragments :: ValidatedWorkspace -> Map FragmentName Fragment +validatedFragments = view #fragmentIndex + +validatedWorkflows :: ValidatedWorkspace -> Map WorkflowName Workflow +validatedWorkflows = view #workflowIndex + +validatedRecipes :: ValidatedWorkspace -> Map RecipeName Recipe +validatedRecipes = view #recipeIndex + +validatedMatrices :: ValidatedWorkspace -> Map MatrixName Matrix +validatedMatrices = view #matrixIndex + +validatedChecks :: ValidatedWorkspace -> Map CheckName Check +validatedChecks = view #checkIndex + +validatedServices :: ValidatedWorkspace -> Map ServiceName Service +validatedServices = view #serviceIndex + +validatedSuites :: ValidatedWorkspace -> Map SuiteName Suite +validatedSuites = view #suiteIndex + +lookupParameter :: ParameterName -> ValidatedWorkspace -> Maybe Parameter +lookupParameter name = Map.lookup name . validatedParameters + +lookupFragment :: FragmentName -> ValidatedWorkspace -> Maybe Fragment +lookupFragment name = Map.lookup name . validatedFragments + +-- | Canonical absolute path of a fragment file, guaranteed to be a regular +-- file inside the workspace root at validation time. +lookupFragmentFile :: FragmentName -> ValidatedWorkspace -> Maybe FilePath +lookupFragmentFile name = Map.lookup name . view #fragmentFiles + +lookupWorkflow :: WorkflowName -> ValidatedWorkspace -> Maybe Workflow +lookupWorkflow name = Map.lookup name . validatedWorkflows + +lookupRecipe :: RecipeName -> ValidatedWorkspace -> Maybe Recipe +lookupRecipe name = Map.lookup name . validatedRecipes + +lookupMatrix :: MatrixName -> ValidatedWorkspace -> Maybe Matrix +lookupMatrix name = Map.lookup name . validatedMatrices + +lookupCheck :: CheckName -> ValidatedWorkspace -> Maybe Check +lookupCheck name = Map.lookup name . validatedChecks + +lookupCheckExecutable :: CheckName -> ValidatedWorkspace -> Maybe FilePath +lookupCheckExecutable name = Map.lookup name . view #checkExecutables + +lookupService :: ServiceName -> ValidatedWorkspace -> Maybe Service +lookupService name = Map.lookup name . validatedServices + +lookupSuite :: SuiteName -> ValidatedWorkspace -> Maybe Suite +lookupSuite name = Map.lookup name . validatedSuites diff --git a/src/HurlWorkbench/Workspace/Context/Internal.hs b/src/HurlWorkbench/Workspace/Context/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workspace/Context/Internal.hs @@ -0,0 +1,41 @@ +-- | Internal representation of 'ValidatedWorkspace'. Only +-- "HurlWorkbench.Workspace.Validate" may construct it; everything else uses +-- the abstract type and accessors exported by +-- "HurlWorkbench.Workspace.Context". +module HurlWorkbench.Workspace.Context.Internal + ( WorkspaceContext (..), + ValidatedWorkspace (..), + ) +where + +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Types + +-- | A decoded workspace together with where it was loaded from. It has not +-- been semantically validated. +data WorkspaceContext = WorkspaceContext + { -- | Canonical absolute path of @hurl-workbench.dhall@. + manifestPath :: !FilePath, + -- | Canonical directory containing the manifest. + workspaceRoot :: !WorkspaceRoot, + workspace :: !Workspace + } + deriving stock (Generic, Eq, Show) + +-- | A workspace that passed every semantic check, indexed by +-- category-specific names. +data ValidatedWorkspace = ValidatedWorkspace + { context :: !WorkspaceContext, + parameterIndex :: !(Map ParameterName Parameter), + fragmentIndex :: !(Map FragmentName Fragment), + -- | Canonical absolute path of each fragment file, inside the root. + fragmentFiles :: !(Map FragmentName FilePath), + workflowIndex :: !(Map WorkflowName Workflow), + recipeIndex :: !(Map RecipeName Recipe), + matrixIndex :: !(Map MatrixName Matrix), + checkIndex :: !(Map CheckName Check), + checkExecutables :: !(Map CheckName FilePath), + serviceIndex :: !(Map ServiceName Service), + suiteIndex :: !(Map SuiteName Suite) + } + deriving stock (Generic, Eq, Show) diff --git a/src/HurlWorkbench/Workspace/Decode.hs b/src/HurlWorkbench/Workspace/Decode.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workspace/Decode.hs @@ -0,0 +1,221 @@ +-- | Evaluate a @hurl-workbench.dhall@ manifest and decode it into a +-- 'Workspace'. +-- +-- Decoding checks @schemaVersion@ on the evaluated expression before the +-- typed decode, so a manifest written for another schema version is +-- reported as such instead of as an opaque Dhall type mismatch. +module HurlWorkbench.Workspace.Decode + ( decodeWorkspaceFile, + ) +where + +import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try) +import Data.ByteString qualified as ByteString +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Void (Void) +import Dhall qualified +import Dhall.Core qualified as Dhall.Core +import Dhall.Map qualified +import Dhall.Parser (Src) +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Error (WorkspaceError (..)) +import HurlWorkbench.Workspace.Types (Check, Workspace, supportedSchemaVersion) +import Numeric.Natural (Natural) +import System.FilePath (takeDirectory) + +-- | Read, evaluate, version-check, and decode a manifest. Relative imports +-- inside the manifest resolve against the manifest's own directory. No +-- JSON or YAML fallback exists. +decodeWorkspaceFile :: FilePath -> IO (Either WorkspaceError Workspace) +decodeWorkspaceFile path = do + readResult <- trySync (ByteString.readFile path) + case readResult of + Left exception -> pure (Left (ManifestUnreadable path (renderException exception))) + Right bytes -> case Text.Encoding.decodeUtf8' bytes of + Left exception -> pure (Left (ManifestUnreadable path (renderException exception))) + Right source -> decodeSource source + where + settings = + Dhall.defaultInputSettings + & Dhall.rootDirectory + .~ takeDirectory path + & Dhall.sourceName + .~ path + + decoder = Dhall.auto @Workspace + + decodeSource source = do + evaluated <- trySync $ do + parsed <- Dhall.parseWithSettings settings source + resolved <- Dhall.resolveWithSettings settings parsed + Dhall.typecheckWithSettings settings resolved + pure resolved + case evaluated of + Left exception -> pure (Left (DhallFailure path (renderException exception))) + Right resolved -> do + let normalized = Dhall.normalizeWithSettings settings resolved + case schemaVersionOf normalized of + Nothing -> pure (Left (MissingSchemaVersion path)) + Just version + | version /= supportedSchemaVersion -> + pure (Left (UnsupportedSchemaVersion path version supportedSchemaVersion)) + | otherwise -> decodeTyped (normalizeChecks (normalizeParameterKinds (normalizeCommandPolicies (normalizeSuiteLifecycle normalized)))) + + decodeTyped normalized = do + expected <- trySync $ do + Dhall.typecheckWithSettings settings normalized + Dhall.expectWithSettings settings decoder normalized + pure $ case expected of + Left exception -> Left (DhallFailure path (renderException exception)) + Right () -> case Dhall.toMonadic (Dhall.extract decoder normalized) of + Right workspace -> Right workspace + Left errors -> Left (DhallFailure path (renderException errors)) + +-- | Find a literal @schemaVersion : Natural@ field on a normalized record. +schemaVersionOf :: Dhall.Core.Expr Src Void -> Maybe Natural +schemaVersionOf = \case + Dhall.Core.RecordLit fields -> + case Dhall.Core.recordFieldValue <$> Dhall.Map.lookup "schemaVersion" fields of + Just (Dhall.Core.NaturalLit version) -> Just version + _ -> Nothing + _ -> Nothing + +-- | Like 'try', but never intercepts asynchronous exceptions. +trySync :: IO a -> IO (Either SomeException a) +trySync action = do + result <- try action + case result of + Left exception + | Just (_ :: SomeAsyncException) <- fromException exception -> throwIO exception + other -> pure other + +-- | Render a library exception as plain text. Dhall colors some messages +-- with ANSI escape sequences, which are removed so redirected output stays +-- readable. +renderException :: (Show e) => e -> Text +renderException = stripAnsi . Text.pack . show + +-- | Remove ANSI CSI sequences such as @ESC[1;31m@. +stripAnsi :: Text -> Text +stripAnsi text = case Text.breakOn "\ESC[" text of + (before, rest) + | Text.null rest -> before + | otherwise -> + let afterIntroducer = Text.drop 2 rest + (_, final) = Text.span (\c -> c >= ' ' && c <= '?') afterIntroducer + in before <> stripAnsi (Text.drop 1 final) + +-- | Upgrade only the managed-service subtree, including the command types in +-- readiness unions and empty-list annotations. User expressions are typechecked +-- before this pass; explicit policy fields are never replaced. +normalizeCommandPolicies :: Dhall.Core.Expr Src Void -> Dhall.Core.Expr Src Void +normalizeCommandPolicies (Dhall.Core.RecordLit fields) = + Dhall.Core.RecordLit + ( Dhall.Map.fromList + [(key, if key `elem` ["checks", "services", "suites"] then field {Dhall.Core.recordFieldValue = upgrade (Dhall.Core.recordFieldValue field)} else field) | (key, field) <- Dhall.Map.toList fields] + ) + where + policyType = Dhall.Core.Union (Dhall.Map.fromList [("Inherit", Nothing), ("Clean", Just (Dhall.Core.App Dhall.Core.List Dhall.Core.Text))]) + inherited = Dhall.Core.Field policyType (Dhall.Core.makeFieldSelection "Inherit") + upgrade expression = + let nested = runIdentity (Dhall.Core.subExpressions (Identity . upgrade) expression) + add value record = + if all (\key -> isJust (Dhall.Map.lookup key record)) ["executable", "arguments", "workingDirectory", "environment"] + && not (isJust (Dhall.Map.lookup "environmentPolicy" record)) + then Dhall.Map.insert "environmentPolicy" (Dhall.Core.makeRecordField value) record + else record + in case nested of + Dhall.Core.RecordLit record -> Dhall.Core.RecordLit (add inherited record) + Dhall.Core.Record record -> Dhall.Core.Record (add policyType record) + other -> other +normalizeCommandPolicies other = other + +-- | Version-1 additive conversion, scoped to suites. Preserve explicit fields +-- and widen only the known Hurl run union (including empty-list annotations). +-- Both the original expression and the converted expression are typechecked. +normalizeSuiteLifecycle :: Dhall.Core.Expr Src Void -> Dhall.Core.Expr Src Void +normalizeSuiteLifecycle (Dhall.Core.RecordLit fields) = + Dhall.Core.RecordLit + ( Dhall.Map.fromList + [(key, if key == "suites" then field {Dhall.Core.recordFieldValue = upgrade (Dhall.Core.recordFieldValue field)} else field) | (key, field) <- Dhall.Map.toList fields] + ) + where + list = Dhall.Core.App Dhall.Core.List + record = Dhall.Core.Record . Dhall.Map.fromList . map (\(key, value) -> (key, Dhall.Core.makeRecordField value)) + union names = Dhall.Core.Union (Dhall.Map.fromList [(key, value) | (key, value) <- names]) + policyType = union [("SharedState", Nothing), ("IndependentState", Nothing)] + commandType = + record + [ ("executable", Dhall.Core.Text), + ("arguments", list Dhall.Core.Text), + ("workingDirectory", Dhall.Core.App Dhall.Core.Optional Dhall.Core.Text), + ("environmentPolicy", union [("Inherit", Nothing), ("Clean", Just (list Dhall.Core.Text))]), + ("environment", list (record [("variable", Dhall.Core.Text), ("parameter", Dhall.Core.Text)])) + ] + stepType = union [(key, Just Dhall.Core.Text) | key <- ["Stop", "Start", "Restart"]] + defaults = + [ ("fileRootParameter", Dhall.Core.App Dhall.Core.Optional Dhall.Core.Text, Dhall.Core.App Dhall.Core.None Dhall.Core.Text), + ("isolation", policyType, Dhall.Core.Field policyType (Dhall.Core.makeFieldSelection "SharedState")), + ("services", list Dhall.Core.Text, Dhall.Core.ListLit (Just (list Dhall.Core.Text)) mempty), + ("setup", list commandType, Dhall.Core.ListLit (Just (list commandType)) mempty), + ("teardown", list commandType, Dhall.Core.ListLit (Just (list commandType)) mempty), + ("commandTimeoutSeconds", Dhall.Core.Natural, Dhall.Core.NaturalLit 60), + ("cleanupTimeoutSeconds", Dhall.Core.Natural, Dhall.Core.NaturalLit 30) + ] + add isType fields_ = + if all (\key -> isJust (Dhall.Map.lookup key fields_)) ["name", "runs", "service", "failFast", "description"] + then foldl (\acc (key, type_, value) -> if isJust (Dhall.Map.lookup key acc) then acc else Dhall.Map.insert key (Dhall.Core.makeRecordField (if isType then type_ else value)) acc) fields_ defaults + else fields_ + upgrade expression = + let nested = runIdentity (Dhall.Core.subExpressions (Identity . upgrade) expression) + in case nested of + Dhall.Core.RecordLit fields_ -> Dhall.Core.RecordLit (add False fields_) + Dhall.Core.Record fields_ -> Dhall.Core.Record (add True fields_) + Dhall.Core.Union alternatives + | all (\key -> Dhall.Map.lookup key alternatives == Just (Just Dhall.Core.Text)) ["Workflow", "Recipe", "Matrix"], + not (isJust (Dhall.Map.lookup "Service" alternatives)) -> + Dhall.Core.Union (Dhall.Map.insert "Service" (Just stepType) alternatives) + other -> other +normalizeSuiteLifecycle other = other + +-- | Widen the legacy parameter kind in values and empty typed lists. The +-- original and upgraded expressions both pass Dhall type checking. +normalizeParameterKinds :: Dhall.Core.Expr Src Void -> Dhall.Core.Expr Src Void +normalizeParameterKinds expression = + let nested = runIdentity (Dhall.Core.subExpressions (Identity . normalizeParameterKinds) expression) + record key type_ = Dhall.Core.Record (Dhall.Map.fromList [(key, Dhall.Core.makeRecordField type_)]) + generator = + Dhall.Core.Union + ( Dhall.Map.fromList + [ ("Uuid4", Nothing), + ("Uuid7", Nothing), + ("TypeId", Just (record "prefix" Dhall.Core.Text)), + ("Rfc3339Now", Nothing), + ("RandomAlphanumeric", Just (record "length" Dhall.Core.Natural)) + ] + ) + in case nested of + Dhall.Core.Union alternatives + | Dhall.Map.toList alternatives == [("Plain", Nothing), ("Secret", Nothing)] -> + Dhall.Core.Union (Dhall.Map.insert "Generated" (Just generator) alternatives) + other -> other + +-- | Add the absent category and widen legacy run unions, including annotations +-- on empty lists. Original and upgraded expressions are both typechecked. +normalizeChecks :: Dhall.Core.Expr Src Void -> Dhall.Core.Expr Src Void +normalizeChecks (Dhall.Core.RecordLit fields) = + let checkList = Dhall.Core.App Dhall.Core.List checkType + withChecks = if isJust (Dhall.Map.lookup "checks" fields) then fields else Dhall.Map.insert "checks" (Dhall.Core.makeRecordField (Dhall.Core.ListLit (Just checkList) mempty)) fields + in Dhall.Core.RecordLit (Dhall.Map.fromList [(key, if key == "suites" then field {Dhall.Core.recordFieldValue = upgrade (Dhall.Core.recordFieldValue field)} else field) | (key, field) <- Dhall.Map.toList withChecks]) + where + checkType = case toList (Dhall.expected (Dhall.auto @Check)) of type_ : _ -> type_; [] -> error "invalid check decoder" + upgrade expression = + let nested = runIdentity (Dhall.Core.subExpressions (Identity . upgrade) expression) + in case nested of + Dhall.Core.Union alternatives + | all (\key -> Dhall.Map.lookup key alternatives == Just (Just Dhall.Core.Text)) ["Workflow", "Recipe", "Matrix"], + not (isJust (Dhall.Map.lookup "Check" alternatives)) -> + Dhall.Core.Union (Dhall.Map.insert "Check" (Just Dhall.Core.Text) alternatives) + other -> other +normalizeChecks other = other diff --git a/src/HurlWorkbench/Workspace/Discover.hs b/src/HurlWorkbench/Workspace/Discover.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workspace/Discover.hs @@ -0,0 +1,62 @@ +-- | Locate the workspace manifest. +-- +-- An explicit @--workspace FILE@ always wins. Otherwise the start directory +-- and each of its parents are searched for 'manifestFileName', stopping at +-- the filesystem root. Neither @$HOME@, a global configuration directory, +-- nor the network is ever consulted. +module HurlWorkbench.Workspace.Discover + ( WorkspaceSource (..), + manifestFileName, + discoverWorkspace, + workspaceSourcePath, + ) +where + +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Error (WorkspaceError (..)) +import System.Directory (doesFileExist, makeAbsolute) +import System.FilePath (normalise, takeDirectory, ()) + +-- | Where the manifest came from. +data WorkspaceSource + = -- | Named with @--workspace FILE@. + ExplicitWorkspace !FilePath + | -- | Found by walking up from the start directory. + DiscoveredWorkspace !FilePath + deriving stock (Generic, Eq, Show) + +-- | The manifest file name searched for during discovery. +manifestFileName :: FilePath +manifestFileName = "hurl-workbench.dhall" + +-- | The absolute manifest path of a source. +workspaceSourcePath :: WorkspaceSource -> FilePath +workspaceSourcePath = \case + ExplicitWorkspace path -> path + DiscoveredWorkspace path -> path + +-- | @discoverWorkspace explicit startDirectory@. A relative explicit path is +-- resolved against @startDirectory@. +discoverWorkspace :: Maybe FilePath -> FilePath -> IO (Either WorkspaceError WorkspaceSource) +discoverWorkspace explicit startDirectory = do + start <- normalise <$> makeAbsolute startDirectory + case explicit of + Just file -> do + let candidate = normalise (start file) + exists <- doesFileExist candidate + pure $ + if exists + then Right (ExplicitWorkspace candidate) + else Left (ManifestNotFound candidate) + Nothing -> walk start start + where + walk start directory = do + let candidate = directory manifestFileName + exists <- doesFileExist candidate + let parent = takeDirectory directory + if exists + then pure (Right (DiscoveredWorkspace candidate)) + else + if parent == directory + then pure (Left (NoWorkspaceFound start)) + else walk start parent diff --git a/src/HurlWorkbench/Workspace/Error.hs b/src/HurlWorkbench/Workspace/Error.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workspace/Error.hs @@ -0,0 +1,53 @@ +-- | Failures that prevent a workspace from being located or decoded at all. +-- Semantic problems in a decoded workspace are reported separately as +-- 'HurlWorkbench.Workspace.Validate.ValidationIssue' values. +module HurlWorkbench.Workspace.Error + ( WorkspaceError (..), + renderWorkspaceError, + ) +where + +import Data.Text qualified as Text +import HurlWorkbench.Prelude +import Numeric.Natural (Natural) + +-- | Why a workspace could not be discovered, read, or decoded. +data WorkspaceError + = -- | An explicit @--workspace FILE@ does not name an existing file. + ManifestNotFound !FilePath + | -- | No @hurl-workbench.dhall@ exists in the start directory or any parent. + NoWorkspaceFound !FilePath + | -- | The manifest exists but could not be read as UTF-8 text. + ManifestUnreadable !FilePath !Text + | -- | Dhall parsing, import resolution, type checking, or decoding failed. + DhallFailure !FilePath !Text + | -- | The manifest's top level is not a record with a @schemaVersion@. + MissingSchemaVersion !FilePath + | -- | The manifest declares a schema version this build does not support. + UnsupportedSchemaVersion !FilePath !Natural !Natural + deriving stock (Generic, Eq, Show) + +-- | Render an error for a human, naming the manifest path. +renderWorkspaceError :: WorkspaceError -> Text +renderWorkspaceError = \case + ManifestNotFound path -> + "workspace manifest not found: " <> Text.pack path + NoWorkspaceFound start -> + "no hurl-workbench.dhall found in " + <> Text.pack start + <> " or any parent directory (use --workspace FILE to name one)" + ManifestUnreadable path reason -> + "cannot read workspace manifest " <> Text.pack path <> ": " <> reason + DhallFailure path reason -> + "invalid Dhall in workspace manifest " <> Text.pack path <> ":\n" <> Text.strip reason + MissingSchemaVersion path -> + "workspace manifest " + <> Text.pack path + <> " must evaluate to a record with a Natural schemaVersion field" + UnsupportedSchemaVersion path found supported -> + "workspace manifest " + <> Text.pack path + <> " declares schemaVersion " + <> Text.pack (show found) + <> ", but this hurl-workbench supports only schemaVersion " + <> Text.pack (show supported) diff --git a/src/HurlWorkbench/Workspace/Types.hs b/src/HurlWorkbench/Workspace/Types.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workspace/Types.hs @@ -0,0 +1,410 @@ +-- | The decoded, pre-validation representation of a @hurl-workbench.dhall@ +-- workspace. Every field corresponds one-to-one to the Dhall schema under +-- @schema/@ at the repository root. +-- +-- These values describe existing Hurl source; they never describe HTTP +-- methods, URLs, bodies, captures, or assertions. Semantic guarantees +-- (unique names, resolved references, safe paths) only hold once a +-- 'Workspace' has been turned into a +-- 'HurlWorkbench.Workspace.Context.ValidatedWorkspace'. +module HurlWorkbench.Workspace.Types + ( -- * Workspace + Workspace (..), + supportedSchemaVersion, + + -- * Category-specific names + ParameterName (..), + FragmentName (..), + WorkflowName (..), + RecipeName (..), + MatrixName (..), + MatrixCaseName (..), + CheckName (..), + ServiceName (..), + SuiteName (..), + WorkspaceRoot (..), + + -- * Plain Hurl values + HurlValueLiteral, + HurlValueLiteralError (..), + mkHurlValueLiteral, + hurlValueLiteralText, + renderHurlValueLiteralError, + + -- * Entities + Parameter (..), + ParameterKind (..), + Generator (..), + TypeIdOptions (..), + RandomOptions (..), + Fragment (..), + Workflow (..), + Binding (..), + Safety (..), + Recipe (..), + MatrixCase (..), + Matrix (..), + EnvironmentBinding (..), + EnvironmentPolicy (..), + CommandSpec (..), + HttpReadiness (..), + CommandReadiness (..), + Readiness (..), + Check (..), + Service (..), + RunReference (..), + ServiceStep (..), + suiteServices, + IsolationPolicy (..), + Suite (..), + ) +where + +import Data.Text qualified as Text +import Dhall (FromDhall (..), InterpretOptions (..), defaultInterpretOptions, genericAutoWith) +import HurlWorkbench.Prelude +import Numeric.Natural (Natural) + +-- | The only @schemaVersion@ this build understands. +supportedSchemaVersion :: Natural +supportedSchemaVersion = 1 + +-- | A complete workspace manifest after Dhall evaluation and decoding. +data Workspace = Workspace + { schemaVersion :: !Natural, + parameters :: ![Parameter], + fragments :: ![Fragment], + workflows :: ![Workflow], + recipes :: ![Recipe], + matrices :: ![Matrix], + checks :: ![Check], + services :: ![Service], + suites :: ![Suite] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Name of an externally injected Hurl variable. +newtype ParameterName = ParameterName {unParameterName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Name of a fragment: one file containing complete Hurl entries. +newtype FragmentName = FragmentName {unFragmentName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Name of a workflow: an ordered list of fragments. +newtype WorkflowName = WorkflowName {unWorkflowName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Name of a recipe: a workflow plus plain bindings and a safety class. +newtype RecipeName = RecipeName {unRecipeName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Name of a matrix: a recipe applied to several binding sets. +newtype MatrixName = MatrixName {unMatrixName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Name of one case inside a matrix. Unique only within its matrix. +newtype MatrixCaseName = MatrixCaseName {unMatrixCaseName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +newtype CheckName = CheckName {unCheckName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Name of a managed service process. +newtype ServiceName = ServiceName {unServiceName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Name of a suite: a collection of workflow, recipe, or matrix runs. +newtype SuiteName = SuiteName {unSuiteName :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Canonical absolute directory containing @hurl-workbench.dhall@. +newtype WorkspaceRoot = WorkspaceRoot {unWorkspaceRoot :: FilePath} + deriving stock (Generic, Eq, Ord, Show) + +-- | A plain (non-secret) Hurl variable value that survives transport through +-- a Hurl 8 variables file unchanged. +-- +-- Hurl reads such files line by line, trims each line, and splits it at the +-- first @=@. The remaining text is then inferred by Hurl as @true@, +-- @false@, @null@, an integer, a float, or a string. The smart constructor +-- therefore rejects CR, LF, and NUL characters and leading or trailing +-- whitespace; an @=@ inside the value is fine. The text is otherwise passed +-- through as written and Hurl's inference applies. +-- +-- Values decoded from Dhall are checked by semantic validation, which +-- reports the offending location; runtime values must go through +-- 'mkHurlValueLiteral'. +newtype HurlValueLiteral = HurlValueLiteral Text + deriving stock (Generic, Eq, Ord, Show) + deriving newtype (FromDhall) + +-- | Why a text value cannot be a 'HurlValueLiteral'. +data HurlValueLiteralError + = -- | The value contains a carriage return, line feed, or NUL character. + ContainsLineBreakOrNul + | -- | The value begins or ends with whitespace that Hurl would trim. + SurroundingWhitespace + deriving stock (Generic, Eq, Show) + +-- | Check the lossless single-line transport rule. +mkHurlValueLiteral :: Text -> Either HurlValueLiteralError HurlValueLiteral +mkHurlValueLiteral value + | Text.any (`elem` ['\r', '\n', '\0']) value = Left ContainsLineBreakOrNul + | hasSurroundingWhitespace = Left SurroundingWhitespace + | otherwise = Right (HurlValueLiteral value) + where + hasSurroundingWhitespace = case (Text.uncons value, Text.unsnoc value) of + (Just (first, _), Just (_, final)) -> isTrimmed first || isTrimmed final + _ -> False + -- Hurl uses Rust's `str::trim`, which trims Unicode White_Space. + isTrimmed c = Text.null (Text.strip (Text.singleton c)) || c `elem` ['\x85', '\x2028', '\x2029'] + +-- | The literal text written to a Hurl variables file. +hurlValueLiteralText :: HurlValueLiteral -> Text +hurlValueLiteralText (HurlValueLiteral value) = value + +-- | Human-readable explanation of a 'HurlValueLiteralError'. +renderHurlValueLiteralError :: HurlValueLiteralError -> Text +renderHurlValueLiteralError = \case + ContainsLineBreakOrNul -> "value contains a line break or NUL character, which Hurl variable files cannot carry" + SurroundingWhitespace -> "value has leading or trailing whitespace, which Hurl variable files would trim" + +-- | Whether a parameter's value may be committed and displayed. +data ParameterKind + = Plain + | Secret + | Generated !Generator + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +-- | Declarative generation; never evaluated during inspection. +data Generator = Uuid4 | Uuid7 | TypeId TypeIdOptions | Rfc3339Now | RandomAlphanumeric RandomOptions + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +newtype TypeIdOptions = TypeIdOptions {prefix :: Text} + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +newtype RandomOptions = RandomOptions {randomLength :: Natural} + deriving stock (Generic, Eq, Ord, Show) + +instance FromDhall RandomOptions where + autoWith _ = genericAutoWith defaultInterpretOptions {fieldModifier = \name -> if name == "randomLength" then "length" else name} + +-- | An externally injected Hurl variable. +data Parameter = Parameter + { name :: !ParameterName, + description :: !(Maybe Text), + kind :: !ParameterKind, + -- | Committed default; never allowed for a secret. + defaultValue :: !(Maybe HurlValueLiteral), + -- | Environment variable that supplies the value at run time. + environment :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | A file of one or more complete Hurl entries, relative to the workspace +-- root. +data Fragment = Fragment + { name :: !FragmentName, + path :: !FilePath, + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | An ordered composition of fragments and the parameters it consumes. +data Workflow = Workflow + { name :: !WorkflowName, + fragments :: ![FragmentName], + parameters :: ![ParameterName], + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | A plain value bound to a parameter. +data Binding = Binding + { parameter :: !ParameterName, + value :: !HurlValueLiteral + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Whether running a recipe may change remote state. +data Safety + = ReadOnly + | Mutating + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass (FromDhall) + +-- | A workflow with committed plain bindings and a safety classification. +data Recipe = Recipe + { name :: !RecipeName, + workflow :: !WorkflowName, + bindings :: ![Binding], + safety :: !Safety, + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | One named set of bindings layered over a matrix's recipe. +data MatrixCase = MatrixCase + { name :: !MatrixCaseName, + bindings :: ![Binding] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | A recipe applied to several binding sets. +data Matrix = Matrix + { name :: !MatrixName, + recipe :: !RecipeName, + cases :: ![MatrixCase], + failFast :: !Bool, + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Export a workspace parameter to a child process under @variable@. +data EnvironmentBinding = EnvironmentBinding + { variable :: !Text, + parameter :: !ParameterName + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Inherit the parent environment, or select required inherited names. +data EnvironmentPolicy = Inherit | Clean [Text] + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | A process invocation as executable plus argv, with an independent environment policy. +data CommandSpec = CommandSpec + { executable :: !Text, + arguments :: ![Text], + workingDirectory :: !(Maybe FilePath), + environmentPolicy :: !EnvironmentPolicy, + environment :: ![EnvironmentBinding] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Poll an HTTP URL until it answers with the expected status. +data HttpReadiness = HttpReadiness + { url :: !Text, + expectedStatus :: !Natural, + intervalMilliseconds :: !Natural, + timeoutSeconds :: !Natural + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | Run a command until it exits successfully. +data CommandReadiness = CommandReadiness + { command :: !CommandSpec, + intervalMilliseconds :: !Natural, + timeoutSeconds :: !Natural + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | How to decide that a service is ready. Dhall alternatives are @Http@ and +-- @Command@. +data Readiness + = HttpReadinessCheck !HttpReadiness + | CommandReadinessCheck !CommandReadiness + deriving stock (Generic, Eq, Show) + +instance FromDhall Readiness where + autoWith _ = genericAutoWith (stripConstructorAffixes "Readiness" "Check") + +-- | A single executable assertion owned by the workspace. +data Check = Check + { name :: !CheckName, + command :: !CommandSpec, + expectedStatus :: !Natural, + timeoutSeconds :: !(Maybe Natural), + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | A managed process that suites can start and stop. +data Service = Service + { name :: !ServiceName, + command :: !CommandSpec, + readiness :: !Readiness, + shutdownTimeoutSeconds :: !Natural, + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | What a suite runs. Dhall alternatives are @Workflow@, @Recipe@, and +-- @Matrix@. +data ServiceStep = Stop !ServiceName | Start !ServiceName | Restart !ServiceName + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +data RunReference + = WorkflowRun !WorkflowName + | RecipeRun !RecipeName + | MatrixRun !MatrixName + | CheckRun !CheckName + | ServiceRun !ServiceStep + deriving stock (Generic, Eq, Show) + +instance FromDhall RunReference where + autoWith _ = genericAutoWith (stripConstructorAffixes "" "Run") + +-- | Application state sharing between expanded suite scenarios. +data IsolationPolicy = SharedState | IndependentState + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +-- | A named collection of runs, optionally against a managed service. +data Suite = Suite + { name :: !SuiteName, + fileRootParameter :: !(Maybe ParameterName), + runs :: ![RunReference], + service :: !(Maybe ServiceName), + services :: ![ServiceName], + setup :: ![CommandSpec], + teardown :: ![CommandSpec], + commandTimeoutSeconds :: !Natural, + cleanupTimeoutSeconds :: !Natural, + isolation :: !IsolationPolicy, + failFast :: !Bool, + description :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromDhall) + +suiteServices :: Suite -> [ServiceName] +suiteServices Suite {service, services} = if null services then maybe [] pure service else services + +-- | Map Haskell constructor names such as @HttpReadinessCheck@ to Dhall +-- alternative names such as @Http@. +stripConstructorAffixes :: Text -> Text -> InterpretOptions +stripConstructorAffixes infix_ suffix = + defaultInterpretOptions {constructorModifier = strip} + where + strip constructor = + let withoutSuffix = fromMaybe constructor (Text.stripSuffix suffix constructor) + in fromMaybe withoutSuffix (Text.stripSuffix infix_ withoutSuffix) diff --git a/src/HurlWorkbench/Workspace/Validate.hs b/src/HurlWorkbench/Workspace/Validate.hs new file mode 100644 --- /dev/null +++ b/src/HurlWorkbench/Workspace/Validate.hs @@ -0,0 +1,529 @@ +-- | Semantic validation of a decoded workspace. +-- +-- Validation accumulates every independent issue instead of stopping at the +-- first one. Issues are reported in a fixed category order (schema, +-- parameters, fragments, workflows, recipes, matrices, services, suites) and +-- by entity name within a category, so the same workspace always produces +-- the same report. +module HurlWorkbench.Workspace.Validate + ( ValidationIssue (..), + validateWorkspace, + renderValidationIssue, + + -- * Name rules + isValidEntityName, + isValidParameterName, + isValidEnvironmentName, + reservedParameterNames, + ) +where + +import Control.Exception (IOException, try) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.Generics.Labels () +import Data.List (sortOn) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import HurlWorkbench.Check.Template +import HurlWorkbench.Parameter.Generate (validateGenerator) +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context.Internal (ValidatedWorkspace (..), WorkspaceContext (..)) +import HurlWorkbench.Workspace.Types +import Numeric.Natural (Natural) +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, getPermissions) +import System.Directory qualified as Directory +import System.FilePath (isAbsolute, splitDirectories, takeExtension, ()) + +-- | One semantic problem, located by entity path such as +-- @workflows/list-properties@ or @matrices/by-mls/cases/west@. +data ValidationIssue = ValidationIssue + { location :: !Text, + message :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | @location: message@. +renderValidationIssue :: ValidationIssue -> Text +renderValidationIssue problem = problem ^. #location <> ": " <> problem ^. #message + +-- | Validate every category and, on success, build the typed indexes. +validateWorkspace :: WorkspaceContext -> IO (Either (NonEmpty ValidationIssue) ValidatedWorkspace) +validateWorkspace ctx = do + (fragmentIssues, fragmentFiles) <- validateFragments root ws + (checkIssues, checkExecutables) <- validateChecks root ws + serviceIssues <- validateServices root ws + phaseIssues <- fmap concat $ for (ws ^. #suites) $ \suite -> fmap concat $ for [("setup", suite ^. #setup), ("teardown", suite ^. #teardown)] $ \(phase, commands) -> fmap concat $ for (zip [0 :: Int ..] commands) $ \(ordinal, command) -> commandIssues root ws (unSuiteName (suite ^. #name)) ("suites/" <> unSuiteName (suite ^. #name) <> "/" <> phase <> "/" <> tshow ordinal) command + let issues = + concat + [ schemaIssues ws, + ordered (validateParameters ws), + ordered fragmentIssues, + ordered (validateWorkflows ws), + ordered (validateRecipes ws), + ordered (validateMatrices ws), + ordered checkIssues, + ordered serviceIssues, + ordered (validateSuites ws <> phaseIssues) + ] + pure $ case nonEmpty issues of + Just problems -> Left problems + Nothing -> + Right + ValidatedWorkspace + { context = ctx, + parameterIndex = indexBy (view #name) (ws ^. #parameters), + fragmentIndex = indexBy (view #name) (ws ^. #fragments), + fragmentFiles, + workflowIndex = indexBy (view #name) (ws ^. #workflows), + recipeIndex = indexBy (view #name) (ws ^. #recipes), + matrixIndex = indexBy (view #name) (ws ^. #matrices), + checkIndex = indexBy (view #name) (ws ^. #checks), + checkExecutables, + serviceIndex = indexBy (view #name) (ws ^. #services), + suiteIndex = indexBy (view #name) (ws ^. #suites) + } + where + ws = ctx ^. #workspace + root = ctx ^. #workspaceRoot + +-- | Issues tagged with the entity name used for ordering within a category. +type Tagged = [(Text, ValidationIssue)] + +ordered :: Tagged -> [ValidationIssue] +ordered = map snd . sortOn fst + +issue :: Text -> Text -> Text -> (Text, ValidationIssue) +issue key loc msg = (key, ValidationIssue {location = loc, message = msg}) + +-- | First declaration wins; duplicates are reported by validation. +indexBy :: (Ord k) => (a -> k) -> [a] -> Map k a +indexBy key = Map.fromListWith (\_new old -> old) . map (\a -> (key a, a)) + +schemaIssues :: Workspace -> [ValidationIssue] +schemaIssues ws = + [ ValidationIssue + { location = "schemaVersion", + message = + "unsupported schema version " + <> tshow (ws ^. #schemaVersion) + <> "; expected " + <> tshow supportedSchemaVersion + } + | ws ^. #schemaVersion /= supportedSchemaVersion + ] + +-------------------------------------------------------------------------------- +-- Names + +-- | Fragment, workflow, recipe, matrix, matrix-case, service, and suite names +-- match @[A-Za-z][A-Za-z0-9._-]*@. +isValidEntityName :: Text -> Bool +isValidEntityName name = case Text.uncons name of + Just (first, rest) -> isAsciiLetter first && Text.all (\c -> isAsciiLetter c || isDigit c || c `elem` ['.', '_', '-']) rest + Nothing -> False + +-- | Parameter names are Hurl-template-safe: @[A-Za-z_][A-Za-z0-9_-]*@ and not +-- one of 'reservedParameterNames'. +isValidParameterName :: Text -> Bool +isValidParameterName name = + name `notElem` reservedParameterNames && case Text.uncons name of + Just (first, rest) -> (isAsciiLetter first || first == '_') && Text.all (\c -> isAsciiLetter c || isDigit c || c `elem` ['_', '-']) rest + Nothing -> False + +-- | Hurl 8 template functions that cannot be shadowed by a variable. +reservedParameterNames :: [Text] +reservedParameterNames = ["getEnv", "newDate", "newUuid"] + +-- | Environment variable names: @[A-Za-z_][A-Za-z0-9_]*@. +isValidEnvironmentName :: Text -> Bool +isValidEnvironmentName name = case Text.uncons name of + Just (first, rest) -> (isAsciiLetter first || first == '_') && Text.all (\c -> isAsciiLetter c || isDigit c || c == '_') rest + Nothing -> False + +isAsciiLetter :: Char -> Bool +isAsciiLetter c = isAsciiLower c || isAsciiUpper c + +-- | Check a name's syntax and uniqueness within one category. +nameIssues :: Text -> (Text -> Bool) -> Text -> [Text] -> Tagged +nameIssues category valid rule names = + [ issue name (category <> "/" <> name) ("invalid " <> categoryLabel <> " name; names must match " <> rule) + | name <- Set.toList (Set.fromList names), + not (valid name) + ] + <> [ issue name (category <> "/" <> name) ("duplicate " <> categoryLabel <> " name declared " <> tshow count <> " times") + | (name, count) <- Map.toList (Map.fromListWith (+) [(name, 1 :: Int) | name <- names]), + count > 1 + ] + where + categoryLabel = case category of + "parameters" -> "parameter" + "fragments" -> "fragment" + "workflows" -> "workflow" + "recipes" -> "recipe" + "matrices" -> "matrix" + "services" -> "service" + "suites" -> "suite" + "cases" -> "matrix case" + other -> other + +entityNameRule :: Text +entityNameRule = "[A-Za-z][A-Za-z0-9._-]*" + +-------------------------------------------------------------------------------- +-- Parameters + +validateParameters :: Workspace -> Tagged +validateParameters ws = + nameIssues + "parameters" + isValidParameterName + "[A-Za-z_][A-Za-z0-9_-]* and must not be getEnv, newDate, or newUuid" + (map (unParameterName . view #name) (ws ^. #parameters)) + <> concatMap parameterIssues (ws ^. #parameters) + where + parameterIssues p = + let name = unParameterName (p ^. #name) + loc = "parameters/" <> name + in [ issue name loc "secret parameters must not have a committed defaultValue" + | p ^. #kind == Secret, + isJust (p ^. #defaultValue) + ] + <> [issue name loc "generated parameters must not have a committed defaultValue" | Generated _ <- [p ^. #kind], isJust (p ^. #defaultValue)] + <> [issue name loc problem | Generated generator <- [p ^. #kind], Left problem <- [validateGenerator generator]] + <> [ issue name (loc <> "/defaultValue") (renderHurlValueLiteralError err) + | Just value <- [p ^. #defaultValue], + Left err <- [literalCheck value] + ] + <> [ issue name (loc <> "/environment") ("invalid environment variable name " <> quote env) + | Just env <- [p ^. #environment], + not (isValidEnvironmentName env) + ] + +literalCheck :: HurlValueLiteral -> Either HurlValueLiteralError HurlValueLiteral +literalCheck = mkHurlValueLiteral . hurlValueLiteralText + +-------------------------------------------------------------------------------- +-- Fragments + +validateFragments :: WorkspaceRoot -> Workspace -> IO (Tagged, Map FragmentName FilePath) +validateFragments root ws = do + checked <- for (ws ^. #fragments) $ \fragment -> do + let name = unFragmentName (fragment ^. #name) + loc = "fragments/" <> name <> "/path" + result <- checkContainedPath root (fragment ^. #path) FileEntry + pure $ case result of + Left problem -> ([issue name loc problem], Nothing) + Right canonical + | takeExtension (fragment ^. #path) /= ".hurl" -> + ([issue name loc ("fragment path " <> quote (Text.pack (fragment ^. #path)) <> " must end in .hurl")], Nothing) + | otherwise -> ([], Just (fragment ^. #name, canonical)) + let names = map (unFragmentName . view #name) (ws ^. #fragments) + files = Map.fromListWith (\_new old -> old) (catMaybes (map snd checked)) + pure (nameIssues "fragments" isValidEntityName entityNameRule names <> concatMap fst checked, files) + +data EntryKind = FileEntry | DirectoryEntry + deriving stock (Eq, Show) + +-- | A relative path that canonicalizes inside the root and exists with the +-- expected kind. Symlinks are followed before the containment check, so a +-- link pointing outside the root is rejected. +checkContainedPath :: WorkspaceRoot -> FilePath -> EntryKind -> IO (Either Text FilePath) +checkContainedPath (WorkspaceRoot root) relative entryKind + | null relative = pure (Left "path must not be empty") + | isAbsolute relative = pure (Left ("path " <> shown <> " must be relative to the workspace root")) + | otherwise = do + canonical <- canonicalizePath (root relative) + if not (splitDirectories root `isPrefixOfList` splitDirectories canonical) + then pure (Left ("path " <> shown <> " escapes the workspace root")) + else do + exists <- case entryKind of + FileEntry -> doesFileExist canonical + DirectoryEntry -> doesDirectoryExist canonical + pure $ + if exists + then Right canonical + else Left ("path " <> shown <> " does not exist as a " <> kindName) + where + shown = quote (Text.pack relative) + kindName = case entryKind of + FileEntry -> "regular file" + DirectoryEntry -> "directory" + +isPrefixOfList :: (Eq a) => [a] -> [a] -> Bool +isPrefixOfList prefix xs = take (length prefix) xs == prefix + +-------------------------------------------------------------------------------- +-- Workflows + +validateWorkflows :: Workspace -> Tagged +validateWorkflows ws = + nameIssues "workflows" isValidEntityName entityNameRule (map (unWorkflowName . view #name) (ws ^. #workflows)) + <> concatMap workflowIssues (ws ^. #workflows) + where + fragmentNames = Set.fromList (map (view #name) (ws ^. #fragments)) + parameterNames = Set.fromList (map (view #name) (ws ^. #parameters)) + workflowIssues w = + let name = unWorkflowName (w ^. #name) + loc = "workflows/" <> name + in [issue name (loc <> "/fragments") "workflow must list at least one fragment" | null (w ^. #fragments)] + <> [ issue name (loc <> "/fragments") ("unknown fragment " <> quote (unFragmentName f)) + | f <- w ^. #fragments, + f `Set.notMember` fragmentNames + ] + <> [ issue name (loc <> "/parameters") ("unknown parameter " <> quote (unParameterName p)) + | p <- w ^. #parameters, + p `Set.notMember` parameterNames + ] + <> [ issue name (loc <> "/parameters") ("parameter " <> quote (unParameterName p) <> " is listed more than once") + | p <- duplicates (w ^. #parameters) + ] + +-------------------------------------------------------------------------------- +-- Bindings, recipes, and matrices + +-- | Check one binding set against the parameters declared by a workflow. +bindingIssues :: Workspace -> Maybe Workflow -> Text -> Text -> [Binding] -> Tagged +bindingIssues ws selected key loc bindings = + [ issue key (loc <> "/bindings") ("parameter " <> quote (unParameterName p) <> " is bound more than once") + | p <- duplicates (map (view #parameter) bindings) + ] + <> concatMap one bindings + where + parametersByName = indexBy (view #name) (ws ^. #parameters) + one b = + let pname = b ^. #parameter + bloc = loc <> "/bindings/" <> unParameterName pname + declared = case selected of + -- An unresolved workflow is reported where it is referenced. + Nothing -> True + Just w -> pname `elem` w ^. #parameters + in [ issue key bloc ("parameter is not declared by workflow " <> quote (maybe "" (unWorkflowName . view #name) selected)) + | not declared, + Map.member pname parametersByName + ] + <> [ issue key bloc "secret parameters cannot be bound to committed values" + | Just p <- [Map.lookup pname parametersByName], + p ^. #kind == Secret + ] + <> [issue key bloc "generated parameters cannot be bound to committed values" | Just p <- [Map.lookup pname parametersByName], Generated _ <- [p ^. #kind]] + <> [ issue key bloc "unknown parameter" + | Map.notMember pname parametersByName + ] + <> [ issue key bloc (renderHurlValueLiteralError err) + | Left err <- [literalCheck (b ^. #value)] + ] + +validateRecipes :: Workspace -> Tagged +validateRecipes ws = + nameIssues "recipes" isValidEntityName entityNameRule (map (unRecipeName . view #name) (ws ^. #recipes)) + <> concatMap recipeIssues (ws ^. #recipes) + where + workflowsByName = indexBy (view #name) (ws ^. #workflows) + recipeIssues r = + let name = unRecipeName (r ^. #name) + loc = "recipes/" <> name + selected = Map.lookup (r ^. #workflow) workflowsByName + in [ issue name (loc <> "/workflow") ("unknown workflow " <> quote (unWorkflowName (r ^. #workflow))) + | isNothing selected + ] + <> bindingIssues ws selected name loc (r ^. #bindings) + +validateMatrices :: Workspace -> Tagged +validateMatrices ws = + nameIssues "matrices" isValidEntityName entityNameRule (map (unMatrixName . view #name) (ws ^. #matrices)) + <> concatMap matrixIssues (ws ^. #matrices) + where + recipesByName = indexBy (view #name) (ws ^. #recipes) + workflowsByName = indexBy (view #name) (ws ^. #workflows) + matrixIssues m = + let name = unMatrixName (m ^. #name) + loc = "matrices/" <> name + recipe = Map.lookup (m ^. #recipe) recipesByName + selected = recipe >>= \r -> Map.lookup (r ^. #workflow) workflowsByName + caseNames = map (unMatrixCaseName . view #name) (m ^. #cases) + in [ issue name (loc <> "/recipe") ("unknown recipe " <> quote (unRecipeName (m ^. #recipe))) + | isNothing recipe + ] + <> [issue name (loc <> "/cases") "matrix must have at least one case" | null (m ^. #cases)] + <> map (\(_, i) -> (name, i & #location %~ ((loc <> "/") <>))) (nameIssues "cases" isValidEntityName entityNameRule caseNames) + <> concat + [ bindingIssues ws selected name (loc <> "/cases/" <> unMatrixCaseName (c ^. #name)) (c ^. #bindings) + | c <- m ^. #cases + ] + +-------------------------------------------------------------------------------- +-- Checks + +validateChecks :: WorkspaceRoot -> Workspace -> IO (Tagged, Map CheckName FilePath) +validateChecks root ws = do + checked <- for (ws ^. #checks) $ \check -> do + let name = unCheckName (check ^. #name) + loc = "checks/" <> name + spec = check ^. #command + relative = Text.unpack (spec ^. #executable) + common <- commandIssues root ws name (loc <> "/command") spec + inspected <- + try @IOException $ + if Text.any (== '\0') (spec ^. #executable) + then pure (Left "executable path must not contain NUL") + else + if ".." `elem` splitDirectories relative + then pure (Left "executable path must not contain parent traversal") + else checkContainedPath root relative FileEntry + let target = either (const (Left "could not inspect check executable")) id inspected + executableResult <- case target of + Left problem -> pure (Left problem) + Right path -> do + permissions <- getPermissions path + pure (if Directory.executable permissions then Right path else Left "check file must be executable") + let problems = + common + <> [issue name (loc <> "/command/executable") problem | Left problem <- [executableResult]] + <> [issue name (loc <> "/expectedStatus") "expected status must be between 0 and 255" | check ^. #expectedStatus > 255] + <> maybe [] (positive name (loc <> "/timeoutSeconds")) (check ^. #timeoutSeconds) + <> concat [argumentIssues name (loc <> "/command/arguments/" <> tshow ordinal) arg | (ordinal, arg) <- zip [0 :: Int ..] (spec ^. #arguments)] + pure (problems, (check ^. #name,) <$> either (const Nothing) Just executableResult) + pure (nameIssues "checks" isValidEntityName entityNameRule (map (unCheckName . view #name) (ws ^. #checks)) <> concatMap fst checked, Map.fromList (mapMaybe snd checked)) + where + argumentIssues key loc arg = case parseTemplate arg of + Left problem -> [issue key loc problem] + Right templateParts -> + concat + [ case filter ((== name) . view #name) (ws ^. #parameters) of + [] -> [issue key loc ("unknown parameter " <> quote (unParameterName name))] + parameter : _ -> [issue key loc "only Plain parameters may appear in check arguments" | parameter ^. #kind /= Plain] + | Placeholder name <- templateParts + ] + +-------------------------------------------------------------------------------- +-- Services + +validateServices :: WorkspaceRoot -> Workspace -> IO Tagged +validateServices root ws = do + perService <- for (ws ^. #services) $ \s -> do + let name = unServiceName (s ^. #name) + loc = "services/" <> name + commandProblems <- commandIssues root ws name (loc <> "/command") (s ^. #command) + readinessProblems <- case s ^. #readiness of + HttpReadinessCheck http -> + pure $ + [issue name (loc <> "/readiness/url") "readiness URL must not be empty" | Text.null (Text.strip (http ^. #url))] + <> [ issue name (loc <> "/readiness/expectedStatus") "expected HTTP status must be between 100 and 599" + | http ^. #expectedStatus < 100 || http ^. #expectedStatus > 599 + ] + <> [issue name (loc <> "/readiness/url") "generated parameters cannot be used in readiness URLs" | p <- ws ^. #parameters, Generated _ <- [p ^. #kind], ("{{" <> unParameterName (p ^. #name) <> "}}") `Text.isInfixOf` (http ^. #url)] + <> positive name (loc <> "/readiness/intervalMilliseconds") (http ^. #intervalMilliseconds) + <> positive name (loc <> "/readiness/timeoutSeconds") (http ^. #timeoutSeconds) + CommandReadinessCheck check -> do + problems <- commandIssues root ws name (loc <> "/readiness/command") (check ^. #command) + pure $ + problems + <> positive name (loc <> "/readiness/intervalMilliseconds") (check ^. #intervalMilliseconds) + <> positive name (loc <> "/readiness/timeoutSeconds") (check ^. #timeoutSeconds) + pure (commandProblems <> readinessProblems <> positive name (loc <> "/shutdownTimeoutSeconds") (s ^. #shutdownTimeoutSeconds)) + pure (nameIssues "services" isValidEntityName entityNameRule (map (unServiceName . view #name) (ws ^. #services)) <> concat perService) + +positive :: Text -> Text -> Natural -> Tagged +positive key loc n = [issue key loc "must be greater than zero" | n == 0] <> [issue key loc "exceeds supported timer range" | n > fromIntegral (maxBound @Int `div` 1000000)] + +commandIssues :: WorkspaceRoot -> Workspace -> Text -> Text -> CommandSpec -> IO Tagged +commandIssues root ws key loc spec = do + workingDirectoryProblems <- case spec ^. #workingDirectory of + Nothing -> pure [] + Just dir -> do + result <- checkContainedPath root dir DirectoryEntry + pure [issue key (loc <> "/workingDirectory") problem | Left problem <- [result]] + pure $ + [issue key (loc <> "/executable") "executable must not be empty" | Text.null (Text.strip (spec ^. #executable))] + <> [issue key loc "process arguments must not contain NUL" | any (Text.any (== '\0')) (spec ^. #executable : spec ^. #arguments)] + <> [issue key loc "generated parameters cannot be used by suite-scoped commands" | b <- spec ^. #environment, p <- ws ^. #parameters, p ^. #name == b ^. #parameter, Generated _ <- [p ^. #kind]] + <> policyProblems + <> workingDirectoryProblems + <> [ issue key (loc <> "/environment") ("environment variable " <> quote v <> " is bound more than once") + | v <- duplicates (map (view #variable) (spec ^. #environment)) + ] + <> concat + [ [ issue key (loc <> "/environment/" <> b ^. #variable) "invalid environment variable name" + | not (isValidEnvironmentName (b ^. #variable)) + ] + <> [ issue key (loc <> "/environment/" <> b ^. #variable) ("unknown parameter " <> quote (unParameterName (b ^. #parameter))) + | (b ^. #parameter) `Set.notMember` parameterNames + ] + | b <- spec ^. #environment + ] + where + policyProblems = case spec ^. #environmentPolicy of + Inherit -> [] + Clean names -> + [issue key (loc <> "/environmentPolicy") ("invalid inherited environment variable name " <> quote n) | n <- names, not (isValidEnvironmentName n)] + <> [issue key (loc <> "/environmentPolicy") ("inherited environment variable " <> quote n <> " is selected more than once") | n <- duplicates names] + parameterNames = Set.fromList (map (view #name) (ws ^. #parameters)) + +-------------------------------------------------------------------------------- +-- Suites + +validateSuites :: Workspace -> Tagged +validateSuites ws = + nameIssues "suites" isValidEntityName entityNameRule (map (unSuiteName . view #name) (ws ^. #suites)) + <> concatMap suiteIssues (ws ^. #suites) + where + workflows = Set.fromList (map (view #name) (ws ^. #workflows)) + recipes = Set.fromList (map (view #name) (ws ^. #recipes)) + matrices = Set.fromList (map (view #name) (ws ^. #matrices)) + checks = Set.fromList (map (view #name) (ws ^. #checks)) + services = Set.fromList (map (view #name) (ws ^. #services)) + suiteIssues s = + let name = unSuiteName (s ^. #name) + loc = "suites/" <> name + in [issue name (loc <> "/runs") "suite must have at least one run" | all (\case ServiceRun _ -> True; _ -> False) (s ^. #runs)] + <> [issue name (loc <> "/service") "independent-state suites cannot declare a shared managed service" | s ^. #isolation == IndependentState, not (null (suiteServices s))] + <> [issue name (loc <> "/services") "service and nonempty services cannot both be supplied" | isJust (s ^. #service), not (null (s ^. #services))] + <> [issue name (loc <> "/services") ("duplicate service " <> quote (unServiceName svc)) | svc <- duplicates (suiteServices s)] + <> [issue name (loc <> "/fileRootParameter") problem | Just parameter <- [s ^. #fileRootParameter], problem <- fileRootIssues parameter] + <> positive name (loc <> "/commandTimeoutSeconds") (s ^. #commandTimeoutSeconds) + <> positive name (loc <> "/cleanupTimeoutSeconds") (s ^. #cleanupTimeoutSeconds) + <> [issue name (loc <> "/commandTimeoutSeconds") "timeout exceeds supported microsecond range" | s ^. #commandTimeoutSeconds > fromIntegral (maxBound @Int `div` 1000000)] + <> [issue name (loc <> "/cleanupTimeoutSeconds") "timeout exceeds supported microsecond range" | s ^. #cleanupTimeoutSeconds > fromIntegral (maxBound @Int `div` 1000000)] + <> map (issue name (loc <> "/runs")) (transitions (Set.fromList (suiteServices s)) (s ^. #runs)) + <> mapMaybe (fmap (issue name (loc <> "/runs")) . unresolvedRun) (s ^. #runs) + <> [ issue name (loc <> "/service") ("unknown service " <> quote (unServiceName svc)) + | svc <- suiteServices s, + svc `Set.notMember` services + ] + fileRootIssues parameter = + ["invalid parameter name" | not (isValidParameterName (unParameterName parameter))] + <> case filter ((== parameter) . view #name) (ws ^. #parameters) of + [] -> ["unknown file-root parameter " <> quote (unParameterName parameter)] + definition : _ -> ["file-root parameter must be Plain" | definition ^. #kind /= Plain] + transitions initial = go initial + where + go _ [] = [] + go running (ServiceRun step : remaining) = + let (svc, requiresRunning, next) = case step of + Stop n -> (n, True, Set.delete n running) + Start n -> (n, False, Set.insert n running) + Restart n -> (n, True, running) + problems = + ["lifecycle service does not belong to suite: " <> quote (unServiceName svc) | svc `Set.notMember` initial] + <> ["invalid lifecycle transition for " <> quote (unServiceName svc) | Set.member svc running /= requiresRunning] + in problems <> go next remaining + go running (_ : remaining) = go running remaining + unresolvedRun = \case + WorkflowRun w | w `Set.notMember` workflows -> Just ("unknown workflow " <> quote (unWorkflowName w)) + RecipeRun r | r `Set.notMember` recipes -> Just ("unknown recipe " <> quote (unRecipeName r)) + CheckRun c | c `Set.notMember` checks -> Just ("unknown check " <> quote (unCheckName c)) + MatrixRun m | m `Set.notMember` matrices -> Just ("unknown matrix " <> quote (unMatrixName m)) + _ -> Nothing + +-------------------------------------------------------------------------------- +-- Helpers + +duplicates :: (Ord a) => [a] -> [a] +duplicates xs = [x | (x, count) <- Map.toList (Map.fromListWith (+) [(x, 1 :: Int) | x <- xs]), count > 1] + +quote :: Text -> Text +quote t = "\"" <> t <> "\"" + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show diff --git a/test/HurlWorkbench/Check/RunTest.hs b/test/HurlWorkbench/Check/RunTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Check/RunTest.hs @@ -0,0 +1,253 @@ +module HurlWorkbench.Check.RunTest (tests) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (cancel, waitCatch, withAsync) +import Control.Exception (IOException, try) +import Data.Bits ((.&.)) +import Data.ByteString qualified as Bytes +import Data.Generics.Labels () +import Data.IORef +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Version (makeVersion) +import HurlWorkbench.Check.Resolve +import HurlWorkbench.Check.Run +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Batch +import HurlWorkbench.Service.Resolve (ServiceError (..)) +import HurlWorkbench.Suite.Resolve +import HurlWorkbench.Suite.Run +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Directory (canonicalizePath, createDirectoryIfMissing, createFileLink, doesFileExist, removeFile) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files (fileMode, getFileStatus, setFileMode) +import System.Posix.Signals (nullSignal, signalProcess) +import System.Timeout qualified as Timeout +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "executable checks" + [ testCase "normal zero/nonzero matches, mismatch, private separate captures and redacted Show" $ + fixture $ \root workspace -> for_ [(0, 0, CheckPassed), (7, 7, CheckPassed), (0, 7, CheckMismatch), (7, 0, CheckMismatch)] $ \(expected, actual, outcome) -> do + let directory = root show expected <> "-" <> show actual + createDirectoryIfMissing True (directory "checks" "parity") + check <- resolved workspace (definition [Text.pack (show actual)]) + result <- runCheck directory (check & #expectedStatus .~ expected) + result ^. #outcome @?= outcome + result ^. #actualStatus @?= Just actual + result ^. #cleanupDiagnostics @?= [] + for_ ["stdout", "stderr"] $ \stream -> do + let path = directory "checks" "parity" stream + mode <- fileMode <$> getFileStatus path + mode .&. 0o777 @?= 0o600 + content <- Bytes.readFile path + assertBool "separate stream" ((if stream == "stdout" then "private-output" else "private-error") `Bytes.isInfixOf` content) + assertBool "resolved command redacted" (not ("sensitive-argument" `Text.isInfixOf` Text.pack (show check))), + testCase "signal termination never matches an expected normal exit" $ + fixture $ \root workspace -> do + check <- resolved workspace (definition ["signal"] & #expectedStatus .~ 15) + result <- runCheck root check + result ^. #outcome @?= CheckSignalled + result ^. #actualStatus @?= Just (-15) + checkExitCode result @?= ExitFailure 143, + testCase "timeout includes descendant cleanup and allows no live survivor" $ + fixture $ \root workspace -> do + check <- resolved workspace (definition ["timeout"]) + began <- getCurrentTime + result <- bounded (runCheck root (check & #timeout .~ 0.2)) + ended <- getCurrentTime + result ^. #outcome @?= CheckTimedOut + assertBool "bounded" (diffUTCTime ended began < 12) + assertStopped root, + testCase "normal leader exit still kills a TERM-ignoring descendant" $ + fixture $ \root workspace -> do + check <- resolved workspace (definition ["orphan"]) + result <- bounded (runCheck root check) + result ^. #outcome @?= CheckMismatch + result ^. #actualStatus @?= Just 9 + assertStopped root, + testCase "cancellation retains an observed cancelled outcome after cleanup" $ + fixture $ \root workspace -> do + check <- resolved workspace (definition ["timeout"]) + observed <- newIORef Nothing + withAsync (runCheckObserved root check (writeIORef observed . Just)) $ \worker -> do + bounded (waitFor (root "child.pid")) + bounded (cancel worker) + waitCatch worker >>= \case Left _ -> pure (); Right _ -> assertFailure "cancel swallowed" + result <- readIORef observed >>= maybe (assertFailure "no partial result") pure + result ^. #outcome @?= CheckCancelled + assertStopped root, + testCase "cancellation during descendant cleanup still joins cleanup and observes cancellation" $ + fixture $ \root workspace -> do + check <- resolved workspace (definition ["orphan"]) + observed <- newIORef Nothing + withAsync (runCheckObserved root check (writeIORef observed . Just)) $ \worker -> do + bounded (waitFor (root "child.pid")) + -- The leader has exited; its descendant holds the TERM grace open. + threadDelay 200000 + bounded (cancel worker) + waitCatch worker >>= \case Left _ -> pure (); Right _ -> assertFailure "cancel swallowed" + result <- readIORef observed >>= maybe (assertFailure "no cleanup observation") pure + result ^. #outcome @?= CheckCancelled + assertStopped root, + testCase "spawn race and capture collision are distinct start failures" $ + fixture $ \root workspace -> do + check <- resolved workspace (definition ["0"]) + removeFile (root "check.py") + runCheck root check >>= (\result -> result ^. #outcome @?= CheckStartFailed) + runCheck root check >>= (\result -> result ^. #outcome @?= CheckStartFailed), + testCase "cleanup diagnostics do not replace a primary mismatch" $ + fixture $ \root workspace -> do + check <- resolved workspace (definition ["7"]) + result <- runCheckObservedWith (const (pure (Left (ServicePhaseFailed "injected")))) root check (const (pure ())) + result ^. #outcome @?= CheckMismatch + result ^. #actualStatus @?= Just 7 + result ^. #cleanupDiagnostics @?= ["process-group-cleanup-failed"] + checkExitCode result @?= ExitFailure 7, + testCase "path, channel, name, status and timeout refusals are located and deterministic" $ + fixture $ \root workspace -> do + createFileLink (root "check.py") (root "inside") + withSystemTempDirectory "check-outside" $ \outside -> do + writeFile (outside "outside") "outside" + createFileLink (outside "outside") (root "escape") + for_ ["", "\0", "/bin/sh", "../check.py", "checks", "missing", "escape"] $ \path -> reject workspace (definition [] & #command . #executable .~ path) "/command/executable" + validateChanged workspace [definition [] & #command . #executable .~ "inside"] >>= either (assertFailure . show) (const (pure ())) + setFileMode (root "check.py") 0o600 + reject workspace (definition []) "/command/executable" + setFileMode (root "check.py") 0o700 + for_ ["{{secret}}", "{{generated}}", "{{unknown}}", "{{ plain }}", "{{plain", "{{}}", "x}}y{{plain}}"] $ \value -> reject workspace (definition [value]) "/command/arguments/0" + reject workspace (definition [] & #expectedStatus .~ 256) "/expectedStatus" + reject workspace (definition [] & #timeoutSeconds .~ Just 0) "/timeoutSeconds" + reject workspace (definition [] & #timeoutSeconds .~ Just (10 ^ (30 :: Int))) "/timeoutSeconds" + validateChanged workspace [definition [], definition []] >>= \case Left _ -> pure (); Right _ -> assertFailure "duplicate accepted", + testCase "resolution preserves argv elements and suite-wide defaults without recipe bindings" $ + fixture $ \_ workspace -> do + check <- resolved workspace (definition ["prefix={{plain}}", "sensitive-argument"]) + check ^. #processConfig . #arguments @?= ["prefix=one argument", "sensitive-argument"] + assertBool "secret absent from argv" (not ("secret-sentinel" `Text.isInfixOf` Text.pack (show (check ^. #processConfig . #arguments)))), + testCase "a check status 4 cannot masquerade as lifecycle failure when summary writing fails" $ + fixture $ \root workspace -> do + changed <- validateChanged workspace [definition ["summary-error"]] >>= either (assertFailure . show) pure + result <- runSuiteWith validate forbidden capabilities changed (suiteRequest root) >>= either (assertFailure . show) pure + result ^. #selectedExitCode @?= ExitFailure 3 + assertBool "summary error retained" (isJust (result ^. #summaryError)) + [check ^. #actualStatus | CheckStep check <- result ^. #steps] @?= [Just 4], + testCase "checks-only suites, late preflight, report requirement and duplicate occurrence refusal" $ + fixture $ \root workspace -> do + let req = suiteRequest root + result <- runSuiteWith validate forbidden capabilities workspace req >>= either (assertFailure . show) pure + result ^. #cases @?= [] + result ^. #selectedExitCode @?= ExitSuccess + [checkStatus check | CheckStep check <- result ^. #steps] @?= ["passed"] + for_ + [ req & #suiteOptions . #reportDirectory .~ Nothing, + req & #suiteOptions . #overwriteReports .~ False + ] + $ \bad -> + prepareSuiteWith validate capabilities workspace bad >>= \case Left _ -> pure (); Right _ -> assertFailure "report refusal missing" + let ctx = validatedContext workspace + late <- validateWorkspace (ctx & #workspace . #checks %~ map (\check -> check & #command . #environmentPolicy .~ Clean ["HURL_WORKBENCH_NO_CHECK_ENV_8765"])) >>= either (assertFailure . show) pure + prepareSuiteWith validate capabilities late (req & #suiteOptions . #overwriteReports .~ True) >>= \case Left _ -> pure (); Right _ -> assertFailure "late environment accepted" + duplicate <- validateWorkspace (ctx & #workspace . #suites %~ map (\suite -> suite & #runs .~ [CheckRun (CheckName "parity"), CheckRun (CheckName "parity")])) >>= either (assertFailure . show) pure + prepareSuiteWith validate capabilities duplicate req >>= \case Left _ -> pure (); Right _ -> assertFailure "duplicate occurrence accepted" + ] + +fixture :: (FilePath -> ValidatedWorkspace -> IO a) -> IO a +fixture action = withSystemTempDirectory "executable-check" $ \directory -> do + root <- canonicalizePath directory + schema <- canonicalizePath "schema/package.dhall" + Text.IO.writeFile (root "hurl-workbench.dhall") ("let S = " <> Text.pack schema <> " in S.Workspace::{ schemaVersion = 1, parameters = [ S.Parameter::{name = \"plain\", defaultValue = Some \"one argument\"}, S.Parameter::{name = \"secret\", kind = S.ParameterKind.Secret}, S.Parameter::{name = \"generated\", kind = S.ParameterKind.Generated S.Generator.Uuid4} ], checks = [ S.Check::{name = \"parity\", command = S.CommandSpec::{executable = \"check.py\", arguments = [\"0\"]}} ], suites = [S.Suite::{name = \"only\", runs = [S.RunReference.Check \"parity\"]}] }") + Text.IO.writeFile (root "check.py") script + setFileMode (root "check.py") 0o700 + createDirectoryIfMissing True (root "checks" "parity") + ctx <- loadWorkspaceContext (ExplicitWorkspace (root "hurl-workbench.dhall")) >>= either (assertFailure . show) pure + workspace <- validateWorkspace ctx >>= either (assertFailure . show) pure + action root workspace + +script :: Text +script = + Text.unlines + [ "#!/usr/bin/env python3", + "import os, sys, time, signal", + "mode = sys.argv[1] if len(sys.argv) > 1 else '0'", + "if mode == 'summary-error': os.mkdir('reports/only/summary.json'); raise SystemExit(4)", + "if mode == 'signal': os.kill(os.getpid(), signal.SIGTERM)", + "print('private-output', flush=True); print('private-error', file=sys.stderr, flush=True)", + "if mode in ('timeout', 'orphan'):", + " pid = os.fork()", + " if pid == 0:", + " signal.signal(signal.SIGTERM, signal.SIG_IGN)", + " open('child.pid','w').write(str(os.getpid()))", + " while True: time.sleep(0.01)", + " while not os.path.exists('child.pid'): time.sleep(0.005)", + " if mode == 'orphan': raise SystemExit(9)", + " while True: time.sleep(0.01)", + "raise SystemExit(int(mode) if mode.isdigit() else 0)" + ] + +definition :: [Text] -> Check +definition arguments = Check (CheckName "parity") (CommandSpec "check.py" arguments Nothing Inherit []) 0 Nothing Nothing + +resolved :: ValidatedWorkspace -> Check -> IO ResolvedCheck +resolved workspace check = do + changed <- validateChanged workspace [check] >>= either (assertFailure . show) pure + ambient <- getEnvironment + prepareCheck ambient changed emptyBindingInput (CheckName "parity") >>= either (assertFailure . show) pure + +validateChanged :: ValidatedWorkspace -> [Check] -> IO (Either (NonEmpty ValidationIssue) ValidatedWorkspace) +validateChanged workspace checks = validateWorkspace (validatedContext workspace & #workspace . #checks .~ checks) + +reject :: ValidatedWorkspace -> Check -> Text -> IO () +reject workspace check suffix = do + first <- validateChanged workspace [check] + second <- validateChanged workspace [check] + first @?= second + case first of + Left issues -> assertBool "located refusal" (any (Text.isSuffixOf suffix . view #location) issues) + Right _ -> assertFailure "invalid check accepted" + +bounded :: IO a -> IO a +bounded action = Timeout.timeout 15000000 action >>= maybe (assertFailure "check exceeded bound") pure + +waitFor :: FilePath -> IO () +waitFor path = doesFileExist path >>= \exists -> unless exists (threadDelay 5000 >> waitFor path) + +assertStopped :: FilePath -> IO () +assertStopped root = do + pid <- read <$> readFile (root "child.pid") + -- Linux orphan zombies cannot execute; PID 1 is responsible for reaping them. + let stopped = do + present <- try @IOException (signalProcess nullSignal pid) + case present of + Left _ -> pure () + Right () -> do + status <- try @IOException (readFile ("/proc/" <> show pid <> "/stat")) + case status of + Right value | ") Z" `Text.isInfixOf` Text.pack value -> pure () + _ -> threadDelay 10000 >> stopped + bounded stopped + +suiteRequest :: FilePath -> SuiteRequest +suiteRequest root = SuiteRequest (SuiteName "only") Nothing Nothing emptyBindingInput defaultHurlOptions (SuiteOptions (either (error . show) id (mkPositiveInt 2)) Nothing False True mempty (Just (root "reports")) False) + +capabilities :: HurlfmtCapabilities +capabilities = HurlfmtCapabilities (HurlfmtExecutable "true") (makeVersion [8, 0, 1]) + +validate :: HurlfmtCapabilities -> a -> IO (Either HurlfmtError ()) +validate _ _ = pure (Right ()) + +forbidden :: HurlRunner +forbidden = HurlRunner (const (assertFailure "checks-only suite started Hurl")) diff --git a/test/HurlWorkbench/Hurl/RunTest.hs b/test/HurlWorkbench/Hurl/RunTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Hurl/RunTest.hs @@ -0,0 +1,308 @@ +module HurlWorkbench.Hurl.RunTest (tests) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (cancel, replicateConcurrently_, waitCatch, withAsync) +import Control.Exception (IOException, bracket, try) +import Control.Monad (replicateM_) +import Data.Bits ((.&.)) +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Data.Version (Version, makeVersion) +import HurlWorkbench.Hurl.Capabilities +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Parameter.Generate +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.FileRoot +import HurlWorkbench.Workflow.Render +import HurlWorkbench.Workflow.Resolve +import HurlWorkbench.Workspace.Context (WorkspaceContext (..)) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate (renderValidationIssue, validateWorkspace) +import System.Directory + ( canonicalizePath, + doesDirectoryExist, + doesFileExist, + getPermissions, + setOwnerExecutable, + setPermissions, + ) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files (accessModes, fileMode, getFileStatus) +import System.Posix.Signals (nullSignal, signalProcess) +import System.Posix.Types (FileMode) +import System.Timeout qualified as Timeout +import Test.Tasty (TestTree, inOrderTestGroup, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = testGroup "Hurl execution" [capabilityTests, inOrderTestGroup "runner" runnerTests] + +capabilityTests :: TestTree +capabilityTests = + testGroup + "capabilities" + [ testCase "parses Hurl 8 version output" $ do + parseHurlVersion "hurl 8.0.1 libcurl/8.7.1" @?= Just (makeVersion [8, 0, 1]) + parseHurlVersion "not a version" @?= Nothing, + testCase "warns for a later major without rejecting it" $ + assertBool "later-major warning" (not (null (hurlCapabilityWarnings (capabilities "hurl" (makeVersion [9, 0, 0]))))) + ] + +runnerTests :: [TestTree] +runnerTests = + [ testCase "argv uses the explicit canonical body root independently of source root" $ + withSystemTempDirectory "hurl-file-root-source" $ \directory -> + withSystemTempDirectory "hurl-file-root-body" $ \body -> do + executable <- writeFakeHurl directory + rendered <- renderedFixture directory + root <- validateFileRoot body (Just body) >>= either (assertFailure . show) pure + let logPath = directory "explicit" + withEnvironment [("FAKE_HURL_LOG", logPath), ("FAKE_EXIT_CODE", "0")] $ + runHurl (mkHurlRunner (capabilities executable (makeVersion [8, 0, 1]))) (baseRequest root rendered) >>= either (assertFailure . show) (const (pure ())) + arguments <- Text.lines <$> Text.IO.readFile (logPath <> ".args") + assertBool "canonical body root reaches argv" (hasPair "--file-root" (Text.pack (fileRootPath root)) arguments), + testCase "short-lived parallel children retain their real exit statuses" $ + withSystemTempDirectory "hurl-fast-exit" $ \dir -> do + let executable = dir "instant-hurl" + writeFile executable "#!/bin/sh\nexit 7\n" + permissions <- getPermissions executable + setPermissions executable (setOwnerExecutable True permissions) + rendered <- renderedFixture dir + root <- validateFileRoot dir Nothing >>= either (assertFailure . show) pure + replicateConcurrently_ 4 $ + replicateM_ 12 $ + runHurl (mkHurlRunner (capabilities executable (makeVersion [8, 0, 1]))) (baseRequest root rendered) >>= \case + Right result -> result ^. #exitCode @?= ExitFailure 7 + Left err -> assertFailure (Text.unpack (renderRunStartError err)), + testCase "cancellation of a live captured Hurl process is bounded and reaps its group" $ + withSystemTempDirectory "hurl-cancel-capture" $ \dir -> do + let executable = dir "blocked-hurl" + marker = dir "running" + writeFile executable ("#!/usr/bin/env python3\nimport os, sys, time\nsys.stdout.write('private stdout\\n'); sys.stdout.flush()\nsys.stderr.write('private stderr\\n'); sys.stderr.flush()\nopen(" <> show marker <> ", 'w').write(str(os.getpid()))\ntime.sleep(60)\n") + permissions <- getPermissions executable + setPermissions executable (setOwnerExecutable True permissions) + rendered <- renderedFixture dir + root <- validateFileRoot dir Nothing >>= either (assertFailure . show) pure + let waitStarted = doesFileExist marker >>= \ready -> unless ready (threadDelay 10000 >> waitStarted) + withAsync (runHurl (mkHurlRunner (capabilities executable (makeVersion [8, 0, 1]))) (baseRequest root rendered)) $ \worker -> do + Timeout.timeout 3000000 waitStarted >>= maybe (assertFailure "Hurl did not start") pure + Timeout.timeout 4000000 (cancel worker) >>= maybe (assertFailure "capture cleanup blocked on a live pipe") pure + waitCatch worker >>= \case Left _ -> pure (); Right _ -> assertFailure "cancelled Hurl returned normally" + pid <- read <$> readFile marker + alive <- try @IOException (signalProcess nullSignal pid) + assertBool "Hurl was reaped" (either (const True) (const False) alive), + testCase "constructs secure argv, filters HURL environment, captures output, and cleans temporary files" $ + withSystemTempDirectory "hurl-workbench-run-test" $ \dir -> do + executable <- writeFakeHurl dir + rendered <- renderedFixture dir + root <- validateFileRoot dir Nothing >>= either (assertFailure . show) pure + secret <- requireSecret "super-secret-fixture" + generated <- generateValue defaultGeneratorEnvironment (TypeId (TypeIdOptions "rcp")) >>= either (assertFailure . Text.unpack) pure + let runLog = dir "fake" + request = + (baseRequest root rendered) + { bindings = + ResolvedBindings + { variables = Map.fromList [(ParameterName "base_url", literal "http://127.0.0.1"), (ParameterName "recipientId", generated)], + secrets = Map.singleton (ParameterName "token") secret + }, + mode = TestMode + } + withEnvironment + [ ("FAKE_HURL_LOG", runLog), + ("FAKE_EXIT_CODE", "23"), + ("HURL_TEST", "1"), + ("HURL_OUTPUT", dir "hostile-output"), + ("HURL_SECRET_TOKEN", "ambient-secret") + ] + $ runHurl (mkHurlRunner (capabilities executable (makeVersion [8, 0, 1]))) request + >>= \case + Left err -> assertFailure (Text.unpack (renderRunStartError err)) + Right result -> do + result ^. #exitCode @?= ExitFailure 23 + result ^. #capturedOutput + @?= Just (CapturedRunOutput "fake stdout\n" "fake stderr\n") + arguments <- Text.lines <$> Text.IO.readFile (runLog <> ".args") + assertBool "test mode" ("--test" `elem` arguments) + assertBool "file root" (hasPair "--file-root" (Text.pack dir) arguments) + assertBool "variables file" ("--variables-file" `elem` arguments) + assertBool "secrets file" ("--secrets-file" `elem` arguments) + assertBool "secret absent from argv" (not (any (Text.isInfixOf "super-secret-fixture") arguments)) + delivered <- Text.IO.readFile (runLog <> ".variables") + assertBool "generated literal delivered unchanged" (("recipientId=" <> hurlValueLiteralText generated) `Text.isInfixOf` delivered) + hurlEnvironment <- Text.IO.readFile (runLog <> ".hurl-env") + hurlEnvironment @?= "" + modes <- Text.lines <$> Text.IO.readFile (runLog <> ".modes") + assertBool "all generated files were 0600" (not (null modes) && all (Text.isSuffixOf " 600") modes) + let generatedPaths = map (Text.unpack . fst . Text.breakOn " ") modes + remains <- traverse doesFileExist generatedPaths + assertBool "temporary files removed" (not (or remains)), + testCase "prepares response and report targets with owner-only permissions" $ + withSystemTempDirectory "hurl-workbench-target-test" $ \dir -> do + executable <- writeFakeHurl dir + rendered <- renderedFixture dir + root <- validateFileRoot dir Nothing >>= either (assertFailure . show) pure + let runLog = dir "fake" + response = dir "response.txt" + junit = dir "junit.xml" + html = dir "html-report" + json = dir "json-report" + tap = dir "report.tap" + curl = dir "requests.sh" + request = + (baseRequest root rendered) + { outputPolicy = ResponseFile response, + reportTargets = [JUnitReport junit, HtmlReport html, JsonReport json, TapReport tap], + options = defaultHurlOptions {curlExportPath = Just curl} + } + withEnvironment [("FAKE_HURL_LOG", runLog), ("FAKE_EXIT_CODE", "0")] $ + runHurl (mkHurlRunner (capabilities executable (makeVersion [8, 0, 1]))) request + >>= either (assertFailure . Text.unpack . renderRunStartError) (const (pure ())) + ByteString.Char8.readFile response >>= (@?= "fake response\n") + filePermissions response >>= (@?= 0o600) + filePermissions junit >>= (@?= 0o600) + filePermissions tap >>= (@?= 0o600) + filePermissions curl >>= (@?= 0o600) + directoryPermissions html >>= (@?= 0o700) + directoryPermissions json >>= (@?= 0o700) + ByteString.Char8.readFile junit >>= (@?= "\n\n") + ByteString.Char8.readFile tap >>= (@?= "TAP version 13\n1..0\n") + arguments <- Text.lines <$> Text.IO.readFile (runLog <> ".args") + assertBool "client mode omits --test" ("--test" `notElem` arguments) + assertBool "output flag" (hasPair "--output" (Text.pack response) arguments) + assertBool "JUnit flag" (hasPair "--report-junit" (Text.pack junit) arguments) + assertBool "HTML flag" (hasPair "--report-html" (Text.pack html) arguments) + assertBool "JSON flag" (hasPair "--report-json" (Text.pack json) arguments) + assertBool "TAP flag" (hasPair "--report-tap" (Text.pack tap) arguments) + assertBool "curl flag" (hasPair "--curl" (Text.pack curl) arguments), + testCase "inherits streams only for the interactive policy" $ + withSystemTempDirectory "hurl-workbench-inherit-test" $ \dir -> do + executable <- writeFakeHurl dir + rendered <- renderedFixture dir + root <- validateFileRoot dir Nothing >>= either (assertFailure . show) pure + let runLog = dir "fake" + request = (baseRequest root rendered) {outputPolicy = InheritRunOutput} + withEnvironment [("FAKE_HURL_LOG", runLog), ("FAKE_EXIT_CODE", "7"), ("FAKE_QUIET", "1")] $ + runHurl (mkHurlRunner (capabilities executable (makeVersion [8, 0, 1]))) request + >>= \case + Left err -> assertFailure (Text.unpack (renderRunStartError err)) + Right result -> do + result ^. #exitCode @?= ExitFailure 7 + result ^. #capturedOutput @?= Nothing, + testCase "represents a spawn failure separately from a child exit" $ + withSystemTempDirectory "hurl-workbench-spawn-test" $ \dir -> do + rendered <- renderedFixture dir + root <- validateFileRoot dir Nothing >>= either (assertFailure . show) pure + runHurl (mkHurlRunner (capabilities (dir "missing-hurl") (makeVersion [8, 0, 1]))) (baseRequest root rendered) + >>= \case + Left HurlSpawnFailed {} -> pure () + other -> assertFailure ("expected HurlSpawnFailed, got " <> show other), + testCase "rejects dangerous passthrough arguments and duplicate report formats before spawn" $ + withSystemTempDirectory "hurl-workbench-options-test" $ \dir -> do + mkAllowedHurlArgument "--secret=value" @?= Left (UnsupportedHurlArgument "--secret=value") + mkAllowedHurlArgument "--test" @?= Left (UnsupportedHurlArgument "--test") + rendered <- renderedFixture dir + root <- validateFileRoot dir Nothing >>= either (assertFailure . show) pure + let request = (baseRequest root rendered) {reportTargets = [JUnitReport "one.xml", JUnitReport "two.xml"]} + runHurl (mkHurlRunner (capabilities (dir "must-not-start") (makeVersion [8, 0, 1]))) request + >>= \case + Left (InvalidRunOptions issues) -> + assertBool "duplicate format" (DuplicateReportFormat "JUnit" `elem` toList issues) + other -> assertFailure ("expected option rejection, got " <> show other) + ] + +baseRequest :: FileRoot -> RenderedWorkflow -> RunRequest +baseRequest root rendered = + RunRequest + { renderedWorkflow = rendered, + fileRoot = root, + mode = ClientMode, + bindings = ResolvedBindings Map.empty Map.empty, + options = defaultHurlOptions, + outputPolicy = CaptureRunOutput, + reportTargets = [] + } + +capabilities :: FilePath -> Version -> HurlCapabilities +capabilities executable version = + HurlCapabilities + executable + version + (HurlfmtCapabilities (HurlfmtExecutable "unused-hurlfmt") (makeVersion [8, 0, 1])) + +renderedFixture :: FilePath -> IO RenderedWorkflow +renderedFixture directory = do + canonicalRoot <- canonicalizePath directory + let fragmentPath = canonicalRoot "request.hurl" + fragment = Fragment (FragmentName "request") "request.hurl" Nothing + workflow = Workflow (WorkflowName "request") [FragmentName "request"] [] Nothing + workspace = Workspace supportedSchemaVersion [] [fragment] [workflow] [] [] [] [] [] + context = WorkspaceContext (canonicalRoot "hurl-workbench.dhall") (WorkspaceRoot canonicalRoot) workspace + Text.IO.writeFile fragmentPath "GET http://127.0.0.1/health\n" + validated <- + validateWorkspace context + >>= either (assertFailure . Text.unpack . Text.unlines . map renderValidationIssue . toList) pure + resolved <- either (assertFailure . Text.unpack . renderWorkflowError) pure (resolveWorkflow validated (WorkflowName "request")) + renderWorkflow resolved >>= either (assertFailure . Text.unpack . renderRenderError) pure + +writeFakeHurl :: FilePath -> IO FilePath +writeFakeHurl directory = do + let executable = directory "fake-hurl" + Text.IO.writeFile + executable + ( Text.unlines + [ "#!/bin/sh", + "log=$FAKE_HURL_LOG", + "printf '%s\\n' \"$@\" > \"$log.args\"", + "env | grep '^HURL_' > \"$log.hurl-env\" || true", + ": > \"$log.modes\"", + "mode_of() { if stat -f '%Lp' \"$1\" >/dev/null 2>&1; then stat -f '%Lp' \"$1\"; else stat -c '%a' \"$1\"; fi; }", + "for arg in \"$@\"; do", + " case \"$arg\" in *.hurl|*.env) printf '%s %s\\n' \"$arg\" \"$(mode_of \"$arg\")\" >> \"$log.modes\" ;; esac", + "done", + "previous=''", + "for arg in \"$@\"; do", + " if [ \"$previous\" = '--output' ]; then printf 'fake response\\n' > \"$arg\"; fi", + " if [ \"$previous\" = '--variables-file' ]; then cat \"$arg\" > \"$log.variables\"; fi", + " previous=$arg", + "done", + "if [ \"${FAKE_QUIET:-0}\" != '1' ]; then printf 'fake stdout\\n'; printf 'fake stderr\\n' >&2; fi", + "exit \"${FAKE_EXIT_CODE:-0}\"" + ] + ) + permissions <- getPermissions executable + setPermissions executable (setOwnerExecutable True permissions) + pure executable + +literal :: Text -> HurlValueLiteral +literal value = either (error . show) id (mkHurlValueLiteral value) + +requireSecret :: Text -> IO SecretValue +requireSecret value = either (assertFailure . show) pure (mkSecretValue value) + +hasPair :: Text -> Text -> [Text] -> Bool +hasPair first second values = any (== [first, second]) (zipWith (\a b -> [a, b]) values (drop 1 values)) + +filePermissions :: FilePath -> IO FileMode +filePermissions path = (.&. accessModes) . fileMode <$> getFileStatus path + +directoryPermissions :: FilePath -> IO FileMode +directoryPermissions path = do + exists <- doesDirectoryExist path + unless exists (assertFailure ("missing directory " <> path)) + filePermissions path + +withEnvironment :: [(String, String)] -> IO a -> IO a +withEnvironment values action = bracket save restore (const applyAndRun) + where + save = traverse (\(name, _value) -> (name,) <$> lookupEnv name) values + restore previous = for_ previous $ \(name, old) -> maybe (unsetEnv name) (setEnv name) old + applyAndRun = traverse_ (uncurry setEnv) values >> action diff --git a/test/HurlWorkbench/Parameter/GenerateTest.hs b/test/HurlWorkbench/Parameter/GenerateTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Parameter/GenerateTest.hs @@ -0,0 +1,129 @@ +module HurlWorkbench.Parameter.GenerateTest (tests) where + +import Control.Exception (AsyncException (ThreadKilled), throwIO, try) +import Data.Bits ((.&.)) +import Data.ByteString qualified as BS +import Data.Generics.Labels () +import Data.IORef +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Version (makeVersion) +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Hurl.Run (defaultHurlOptions) +import HurlWorkbench.Parameter.Generate +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Prepare +import HurlWorkbench.Run.Selection +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +fixed :: GeneratorEnvironment +fixed = GeneratorEnvironment (pure (posixSecondsToUTCTime 1645557742.123)) (\n -> pure (BS.replicate n 255)) + +textValue :: Either Text HurlValueLiteral -> Either Text Text +textValue = fmap hurlValueLiteralText + +tests :: TestTree +tests = + testGroup + "generated parameters" + [ testCase "RFC UUID4 and UUID7 layouts use independent expected bytes" $ do + fmap formatUuid (uuid4Bytes (replicate 16 255)) @?= Right "ffffffff-ffff-4fff-bfff-ffffffffffff" + let expected = [1, 127, 34, 226, 121, 171, 127, 255, 191, 255, 255, 255, 255, 255, 255, 255] + uuid7Bytes 1645557741995 (replicate 16 255) @?= Right expected + uuid7Bytes (-1) (replicate 16 0) @?= Left "UUID7 timestamp outside 48-bit range" + assertBool "overflow rejected" (isLeft (uuid7Bytes (2 ^ (48 :: Int)) (replicate 16 0))), + testCase "TypeID big endian vector and leading zero bits" $ do + encodeTypeId (replicate 16 255) @?= "7zzzzzzzzzzzzzzzzzzzzzzzzz" + encodeTypeId (replicate 16 0) @?= Text.replicate 26 "0" + result <- generateValue fixed (TypeId (TypeIdOptions "rcp")) + case textValue result of + Right value -> do + let alphabet = "0123456789abcdefghjkmnpqrstvwxyz" + number = foldl (\acc c -> acc * 32 + fromIntegral (fromMaybe (-100) (Text.findIndex (== c) alphabet))) (0 :: Integer) (Text.unpack (Text.drop 4 value)) + (number `div` (2 ^ (76 :: Int))) .&. 15 @?= 7 + (number `div` (2 ^ (62 :: Int))) .&. 3 @?= 2 + Left err -> assertFailure (Text.unpack err), + testCase "prefix and length constraints" $ do + for_ ["", "a", Text.replicate 63 "a", "a__z"] $ \p -> validateGenerator (TypeId (TypeIdOptions p)) @?= Right () + for_ ["_a", "a_", "A", "a1", Text.replicate 64 "a"] $ \p -> assertBool "bad prefix" (isLeft (validateGenerator (TypeId (TypeIdOptions p)))) + for_ [0, 4097] $ \n -> assertBool "bad length" (isLeft (validateGenerator (RandomAlphanumeric (RandomOptions n)))), + testCase "all outputs are literals, timestamp has fixed milliseconds" $ do + fmap textValue (generateValue fixed Rfc3339Now) >>= (@?= Right "2022-02-22T19:22:22.123Z") + for_ [Uuid4, Uuid7, TypeId (TypeIdOptions ""), TypeId (TypeIdOptions (Text.replicate 63 "a"))] $ \g -> generateValue fixed g >>= assertBool "valid literal" . not . isLeft, + testCase "random sampling rejects 248..255 and terminates for broken entropy" $ do + let env = fixed {entropyBytes = \n -> pure (BS.pack (take n (cycle [248, 255, 0, 61, 62, 247])))} + fmap textValue (generateValue env (RandomAlphanumeric (RandomOptions 4))) >>= (@?= Right "A9A9") + generateValue fixed (RandomAlphanumeric (RandomOptions 1)) >>= assertBool "bounded" . isLeft, + testCase "short entropy, IO failure, and cancellation" $ do + for_ [fixed {entropyBytes = \_ -> pure BS.empty}, fixed {entropyBytes = \_ -> ioError (userError "sensitive bytes")}] $ \env -> do + result <- generateValue env Uuid4 + assertBool "fails redacted" (isLeft result && not ("sensitive" `Text.isInfixOf` Text.pack (show result))) + result <- try @AsyncException (generateValue (fixed {entropyBytes = \_ -> throwIO ThreadKilled}) Uuid4) + case result of Left ThreadKilled -> pure (); _ -> assertFailure "cancellation swallowed", + testCase "declarations reject committed values and suite command references" $ do + context <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/minimal/hurl-workbench.dhall") >>= either (assertFailure . show) pure + let name = ParameterName "fresh" + parameter = Parameter name Nothing (Generated Uuid7) Nothing Nothing + literal = either (error . show) id (mkHurlValueLiteral "committed") + base = context & #workspace . #parameters %~ (parameter :) + workflow = Workflow (WorkflowName "generated") [FragmentName "health"] [name] Nothing + recipe = Recipe (RecipeName "generated") (WorkflowName "generated") [] ReadOnly Nothing + command = CommandSpec "true" [] Nothing Inherit [EnvironmentBinding "FRESH" name] + service = Service (ServiceName "generated") command (HttpReadinessCheck (HttpReadiness "http://localhost/health" 200 10 1)) 1 Nothing + manifest = base & #workspace . #workflows %~ (workflow :) & #workspace . #recipes .~ [recipe] + for_ + [ context & #workspace . #parameters %~ ((parameter & #defaultValue .~ Just literal) :), + manifest & #workspace . #recipes .~ [recipe & #bindings .~ [Binding name literal]], + manifest & #workspace . #matrices .~ [Matrix (MatrixName "generated") (RecipeName "generated") [MatrixCase (MatrixCaseName "one") [Binding name literal]] False Nothing], + context & #workspace . #parameters %~ ((parameter & #name .~ ParameterName "newUuid") :), + base & #workspace . #services .~ [service], + base & #workspace . #services .~ [service & #command . #environment .~ [] & #readiness .~ HttpReadinessCheck (HttpReadiness "http://localhost/{{fresh}}" 200 10 1)], + base & #workspace . #parameters %~ map (\p -> if p ^. #name == name then p & #kind .~ Generated (TypeId (TypeIdOptions "Bad")) else p) + ] + $ \candidate -> validateWorkspace candidate >>= assertBool "invalid manifest" . isLeft, + testCase "resolution generates once per name and overrides consume no entropy" $ do + context <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/minimal/hurl-workbench.dhall") >>= either (assertFailure . show) pure + let parameter = Parameter (ParameterName "fresh") Nothing (Generated Uuid4) Nothing Nothing + validated <- validateWorkspace (context & #workspace . #parameters %~ (parameter :) & #workspace . #workflows %~ map (\w -> w & #parameters %~ (ParameterName "fresh" :))) >>= either (assertFailure . show) pure + calls <- newIORef (0 :: Int) + let env = fixed {entropyBytes = \n -> do modifyIORef' calls (+ 1); count <- readIORef calls; pure (BS.replicate n (fromIntegral count))} + resolve = resolveParametersWithGenerator env validated (Set.singleton (ParameterName "fresh")) + first <- resolve emptyBindingInput >>= either (assertFailure . show) pure + readIORef calls >>= (@?= 1) + second <- resolve emptyBindingInput >>= either (assertFailure . show) pure + assertBool "fresh executions" (first /= second) + let literal = either (error . show) id (mkHurlValueLiteral "reproduce") + third <- resolve (emptyBindingInput & #plainOverrides .~ Map.singleton (ParameterName "fresh") literal) >>= either (assertFailure . show) pure + third ^. #variables @?= Map.singleton (ParameterName "fresh") literal + readIORef calls >>= (@?= 2) + show first @?= "ResolvedBindings " + failure <- resolveParametersWithGenerator (fixed {entropyBytes = \_ -> ioError (userError "private")}) validated (Set.singleton (ParameterName "fresh")) emptyBindingInput + case failure of + Left err -> assertBool "names kind, redacts cause" ("Uuid4" `Text.isInfixOf` renderBindingError err && not ("private" `Text.isInfixOf` renderBindingError err)) + Right _ -> assertFailure "expected generator failure" + let broken = fixed {entropyBytes = \_ -> ioError (userError "private")} + format = HurlfmtCapabilities (HurlfmtExecutable "unused") (makeVersion [8, 0, 1]) + preparation <- prepareSelectionWithGenerator broken (\_ _ -> pure (Right ())) format validated emptyBindingInput defaultHurlOptions (SelectWorkflow (WorkflowName "check-health")) + assertBool "generation failure is a preparation failure before spawn" (isLeft preparation) + withSystemTempDirectory "generated-overrides" $ \directory -> do + let firstFile = directory "first.env" + secondFile = directory "second.env" + Text.IO.writeFile firstFile "fresh=first\n" + Text.IO.writeFile secondFile "fresh=second\n" + result <- resolveParametersWithGenerator broken validated (Set.singleton (ParameterName "fresh")) (emptyBindingInput & #variableFiles .~ [firstFile, secondFile]) >>= either (assertFailure . show) pure + fmap hurlValueLiteralText (result ^. #variables) @?= Map.singleton (ParameterName "fresh") "second" + resolve (emptyBindingInput & #secretEnvironmentOverrides .~ Map.singleton (ParameterName "fresh") "SECRET") >>= assertBool "secret channel rejected" . isLeft + ] + where + isLeft (Left _) = True; isLeft _ = False diff --git a/test/HurlWorkbench/Parameter/ParameterTest.hs b/test/HurlWorkbench/Parameter/ParameterTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Parameter/ParameterTest.hs @@ -0,0 +1,161 @@ +module HurlWorkbench.Parameter.ParameterTest (tests) where + +import Control.Exception (bracket) +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import HurlWorkbench.Parameter.Properties +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Error (renderWorkspaceError) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, inOrderTestGroup, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = testGroup "parameters" [propertiesTests, resolutionTests] + +propertiesTests :: TestTree +propertiesTests = + testGroup + "properties files" + [ testCase "ignores comments and preserves additional equals signs" $ do + let input = " # comment\n\nalpha=one=two\ntop=10\n" + parseVariableProperties "values.env" input + @?= Right + ( Map.fromList + [ (ParameterName "alpha", literal "one=two"), + (ParameterName "top", literal "10") + ] + ), + testCase "rejects duplicate names in one file" $ + case parseVariableProperties "values.env" "top=1\ntop=2\n" of + Left (DuplicatePropertyName VariableProperties "values.env" 2 (ParameterName "top")) -> pure () + other -> assertFailure ("expected duplicate property error, got " <> show other), + testCase "secret errors never retain the secret text" $ do + let secret = "do-not-print-me" :: Text + result = parseSecretProperties "secrets.env" (Text.Encoding.encodeUtf8 ("token=" <> secret <> "\ntoken=again\n")) + assertBool "redacts first secret" (not (secret `Text.isInfixOf` Text.pack (show result))) + ] + +resolutionTests :: TestTree +resolutionTests = + inOrderTestGroup + "resolution" + [ testCase "applies explicit, later-file, environment, and default precedence" $ + withSystemTempDirectory "hurl-workbench-bindings" $ \dir -> + withEnvironment + [ ("EXAMPLE_CLIENT_ID", "environment-id"), + ("EXAMPLE_CLIENT_SECRET", "environment-secret"), + ("OVERRIDE_SECRET", "explicit-secret") + ] + $ do + ByteString.writeFile (dir "first.env") "client_id=file-id\ntop=10\n" + ByteString.writeFile (dir "second.env") "top=20\n" + ByteString.writeFile (dir "secrets.env") "client_secret=file-secret\n" + workspace <- fullWorkspace + workflow <- requireWorkflow workspace (WorkflowName "list-properties") + let input = + BindingInput + { plainOverrides = Map.singleton (ParameterName "client_id") (literal "explicit-id"), + secretEnvironmentOverrides = Map.singleton (ParameterName "client_secret") "OVERRIDE_SECRET", + variableFiles = [dir "first.env", dir "second.env"], + secretFiles = [dir "secrets.env"] + } + resolveWorkflowBindings workspace workflow input >>= \case + Left err -> assertFailure (Text.unpack (renderBindingError err)) + Right resolved -> do + fmap hurlValueLiteralText (resolved ^. #variables) + @?= Map.fromList + [ (ParameterName "auth_url", "https://auth.example.test"), + (ParameterName "base_url", "https://api.example.test"), + (ParameterName "client_id", "explicit-id"), + (ParameterName "top", "20") + ] + Map.keys (resolved ^. #secrets) @?= [ParameterName "client_secret"] + show resolved @?= "ResolvedBindings ", + testCase "reports every missing workflow parameter in sorted order" $ + withUnsetEnvironment ["EXAMPLE_CLIENT_ID", "EXAMPLE_CLIENT_SECRET"] $ do + workspace <- fullWorkspace + workflow <- requireWorkflow workspace (WorkflowName "list-properties") + workflow ^. #parameters + @?= map ParameterName ["auth_url", "client_id", "client_secret", "base_url", "top"] + lookupEnv "EXAMPLE_CLIENT_ID" >>= (@?= Nothing) + lookupEnv "EXAMPLE_CLIENT_SECRET" >>= (@?= Nothing) + resolveWorkflowBindings workspace workflow emptyBindingInput >>= \case + Left (BindingIssues issues) -> + mapMaybe missingName (toList issues) + @?= [ParameterName "client_id", ParameterName "client_secret"] + other -> assertFailure ("expected missing binding issues, got " <> show other), + testCase "rejects unexpected and wrong-channel bindings" $ do + workspace <- fullWorkspace + let input = + emptyBindingInput + { plainOverrides = + Map.fromList + [ (ParameterName "client_secret", literal "not-secret-channel"), + (ParameterName "not_declared", literal "unused") + ] + } + resolveParameters workspace (Set.singleton (ParameterName "client_secret")) input >>= \case + Left (BindingIssues issues) -> do + assertBool "wrong channel" (any isKindMismatch issues) + assertBool "unexpected" (any isUnexpected issues) + other -> assertFailure ("expected binding issues, got " <> show other), + testCase "a malformed secret environment value is redacted" $ + withEnvironment [("BAD_SECRET", " hidden ")] $ do + workspace <- fullWorkspace + let input = emptyBindingInput {secretEnvironmentOverrides = Map.singleton (ParameterName "client_secret") "BAD_SECRET"} + resolveParameters workspace (Set.singleton (ParameterName "client_secret")) input >>= \case + Left err -> assertBool "does not reveal value" (not ("hidden" `Text.isInfixOf` renderBindingError err)) + Right _ -> assertFailure "expected the secret to be rejected" + ] + +literal :: Text -> HurlValueLiteral +literal value = case mkHurlValueLiteral value of + Left err -> error (show err) + Right valid -> valid + +fullWorkspace :: IO ValidatedWorkspace +fullWorkspace = do + loaded <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/full/hurl-workbench.dhall") + context <- either (assertFailure . Text.unpack . renderWorkspaceError) pure loaded + validateWorkspace context >>= either (assertFailure . Text.unpack . Text.unlines . map renderValidationIssue . toList) pure + +requireWorkflow :: ValidatedWorkspace -> WorkflowName -> IO Workflow +requireWorkflow workspace name = maybe (assertFailure "workflow fixture missing") pure (lookupWorkflow name workspace) + +withEnvironment :: [(String, String)] -> IO a -> IO a +withEnvironment values action = bracket save restore (const applyAndRun) + where + save = traverse (\(name, _value) -> (name,) <$> lookupEnv name) values + restore previous = for_ previous $ \(name, old) -> maybe (unsetEnv name) (setEnv name) old + applyAndRun = traverse_ (uncurry setEnv) values >> action + +withUnsetEnvironment :: [String] -> IO a -> IO a +withUnsetEnvironment names action = bracket save restore (const (traverse_ unsetEnv names >> action)) + where + save = traverse (\name -> (name,) <$> lookupEnv name) names + restore previous = for_ previous $ \(name, old) -> maybe (unsetEnv name) (setEnv name) old + +isKindMismatch :: BindingIssue -> Bool +isKindMismatch BindingKindMismatch {} = True +isKindMismatch _ = False + +isUnexpected :: BindingIssue -> Bool +isUnexpected UnexpectedBinding {} = True +isUnexpected _ = False + +missingName :: BindingIssue -> Maybe ParameterName +missingName (MissingBinding name) = Just name +missingName (MissingBindingEnvironment name _environment _source) = Just name +missingName _ = Nothing diff --git a/test/HurlWorkbench/Run/FileRootTest.hs b/test/HurlWorkbench/Run/FileRootTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Run/FileRootTest.hs @@ -0,0 +1,54 @@ +module HurlWorkbench.Run.FileRootTest (tests) where + +import Control.Exception (bracket_) +import HurlWorkbench.Prelude +import HurlWorkbench.Run.FileRoot +import System.Directory (canonicalizePath, createDirectory, createDirectoryLink, removeDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files (setFileMode) +import System.Posix.User (getEffectiveUserID) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "file roots" + [ testCase "validates relative Unicode and symlink roots and redacts Show" $ + withSystemTempDirectory "file-root" $ \base -> do + let path = base "private 雪 payload" + createDirectory path + createDirectoryLink path (base "alias") + root <- validateFileRoot base (Just "alias") >>= either (assertFailure . show) pure + canonicalizePath path >>= (@?= fileRootPath root) + show root @?= "FileRoot " + checkFileRootOutputs root [base "separate"] >>= (@?= Right ()) + for_ [path, path "new/report", base, base "alias/new"] $ \target -> + checkFileRootOutputs root [target] >>= assertBool "overlap refused" . isLeft, + testCase "missing, file, and empty roots fail" $ + withSystemTempDirectory "file-root" $ \base -> do + writeFile (base "file") "payload" + for_ ["missing", "file", ""] $ \path -> + validateFileRoot base (Just path) >>= assertBool "root refused" . isLeft, + testCase "effective read and search permissions are required" $ + withSystemTempDirectory "file-root" $ \base -> do + uid <- getEffectiveUserID + if uid == 0 + then putStrLn "UNSUPPORTED: root bypasses permission denial; public CLI check uses an unprivileged identity" + else for_ [0o300, 0o600] $ \mode -> + bracket_ (setFileMode base mode) (setFileMode base 0o700) $ + validateFileRoot base (Just base) >>= assertBool "permission refusal" . isLeft, + testCase "default root permits workspace reports and retains a snapshot" $ + withSystemTempDirectory "file-root" $ \base -> do + root <- validateFileRoot base Nothing >>= either (assertFailure . show) pure + checkFileRootOutputs root [base "report"] >>= (@?= Right ()) + let child = base "ephemeral" + createDirectory child + selected <- validateFileRoot base (Just child) >>= either (assertFailure . show) pure + removeDirectory child + assertBool "retains selected root without recreating it" (not (null (fileRootPath selected))) + ] + where + isLeft (Left _) = True + isLeft _ = False diff --git a/test/HurlWorkbench/Run/SelectionTest.hs b/test/HurlWorkbench/Run/SelectionTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Run/SelectionTest.hs @@ -0,0 +1,277 @@ +module HurlWorkbench.Run.SelectionTest (tests) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (atomically, modifyTVar', newEmptyTMVarIO, newTVarIO, putTMVar, readTVar, readTVarIO, takeTMVar, writeTVar) +import Control.Exception (bracket) +import Data.Bits ((.&.)) +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Version (makeVersion) +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Artifact +import HurlWorkbench.Run.Batch +import HurlWorkbench.Run.FileRoot +import HurlWorkbench.Run.Prepare +import HurlWorkbench.Run.Selection +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Error (renderWorkspaceError) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files + ( accessModes, + fileMode, + getFileStatus, + ownerExecuteMode, + ownerReadMode, + ownerWriteMode, + unionFileModes, + ) +import System.Posix.Types qualified +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "run selection and preparation" + [ testCase "explicit roots survive matrix preparation and artifact overlap is refused" $ + withSystemTempDirectory "matrix-file-root" $ \directory -> do + root <- validateFileRoot directory (Just directory) >>= either (assertFailure . show) pure + prepared <- preparedMatrixAt (Just root) + for_ prepared $ \ready -> do + ready ^. #fileRoot @?= root + buildBatchCase TestMode CaptureRunOutput [] ready ^. #request . #fileRoot @?= root + prepareResponseArtifacts (directory "nested") True prepared >>= \case + Left _ -> pure () + Right _ -> assertFailure "artifact preparation accepted input overlap", + testCase "expands matrix cases in declaration order with case-over-recipe layers" $ do + workspace <- fullWorkspace + case resolveSelection workspace (SelectMatrix (MatrixName "property-page-sizes")) of + Left err -> assertFailure (Text.unpack (renderSelectionError err)) + Right expanded -> do + let runs = NonEmpty.toList expanded + map (view #displayName) runs @?= ["property-page-sizes/small", "property-page-sizes/large"] + map (view #artifactStem) runs @?= ["property-page-sizes" "small", "property-page-sizes" "large"] + map (view #safety) runs @?= [Classified ReadOnly, Classified ReadOnly] + map (map (view #source) . view #bindingLayers) runs + @?= [ [CommittedBinding "matrix \"property-page-sizes\" case \"small\"", CommittedBinding "recipe \"top-properties\""], + [CommittedBinding "matrix \"property-page-sizes\" case \"large\"", CommittedBinding "recipe \"top-properties\""] + ], + testCase "applies runtime, file, matrix, recipe, environment, and default precedence" $ + withSystemTempDirectory "hurl-workbench-layered-bindings" $ \directory -> do + workspace <- fullWorkspace + expanded <- case resolveSelection workspace (SelectMatrix (MatrixName "property-page-sizes")) of + Left err -> assertFailure (Text.unpack (renderSelectionError err)) + Right value -> pure (NonEmpty.head value) + let layers = expanded ^. #bindingLayers + top = ParameterName "top" + clientId = ParameterName "client_id" + recipeOnly = drop 1 layers + topValue result = hurlValueLiteralText <$> Map.lookup top (result ^. #variables) + resolveParametersWithLayers workspace (Set.singleton top) [] emptyBindingInput >>= requireBindings >>= ((@?= Just "5") . topValue) + resolveParametersWithLayers workspace (Set.singleton top) recipeOnly emptyBindingInput >>= requireBindings >>= ((@?= Just "10") . topValue) + resolveParametersWithLayers workspace (Set.singleton top) layers emptyBindingInput >>= requireBindings >>= ((@?= Just "1") . topValue) + ByteString.writeFile (directory "values.env") "top=20\n" + let fileInput = emptyBindingInput {variableFiles = [directory "values.env"]} + resolveParametersWithLayers workspace (Set.singleton top) layers fileInput >>= requireBindings >>= ((@?= Just "20") . topValue) + let explicitInput = fileInput {plainOverrides = Map.singleton top (literal "30")} + resolveParametersWithLayers workspace (Set.singleton top) layers explicitInput >>= requireBindings >>= ((@?= Just "30") . topValue) + let committedClient = BindingLayer (CommittedBinding "recipe test") (Map.singleton clientId (literal "committed-id")) + resolveParametersWithLayers workspace (Set.singleton clientId) [committedClient] emptyBindingInput >>= requireBindings >>= \resolved -> + (hurlValueLiteralText <$> Map.lookup clientId (resolved ^. #variables)) @?= Just "committed-id", + testCase "prepares every matrix case before building the shared request shape" $ + withEnvironment [("PREPARE_SELECTION_SECRET", "fixture-secret")] $ do + workspace <- fullWorkspace + let input = + emptyBindingInput + { plainOverrides = Map.singleton (ParameterName "client_id") (literal "fixture-id"), + secretEnvironmentOverrides = Map.singleton (ParameterName "client_secret") "PREPARE_SELECTION_SECRET" + } + prepared <- + prepareSelection + trueCapabilities + workspace + input + defaultHurlOptions + (SelectMatrix (MatrixName "property-page-sizes")) + case prepared of + Left errors -> assertFailure (Text.unpack (Text.unlines (map renderPreparationError (toList errors)))) + Right runs -> do + map (view #displayName) (NonEmpty.toList runs) @?= ["property-page-sizes/small", "property-page-sizes/large"] + map (fmap hurlValueLiteralText . Map.lookup (ParameterName "top") . view #variables . view #bindings) (NonEmpty.toList runs) + @?= [Just "1", Just "100"] + let batchCase = buildBatchCase TestMode CaptureRunOutput [] (NonEmpty.head runs) + batchCase ^. #name @?= "property-page-sizes/small" + batchCase ^. #request . #mode @?= TestMode, + testCase "bounds concurrency and returns results in declaration order" $ do + cases <- syntheticCases ["slow", "fast", "middle"] + active <- newTVarIO (0 :: Int) + maximumActive <- newTVarIO (0 :: Int) + let runner = HurlRunner $ \request -> do + atomically $ do + modifyTVar' active (+ 1) + current <- readTVar active + observed <- readTVar maximumActive + writeTVar maximumActive (max current observed) + threadDelay (if requestPath request == Just "slow" then 150000 else 20000) + atomically (modifyTVar' active (subtract 1)) + pure (Right (RunResult ExitSuccess 0 (Just (CapturedRunOutput "" "")))) + result <- runBatch runner (BatchOptions (positive 2) False) cases + readTVarIO maximumActive >>= (@?= 2) + map (view #name) (toList (result ^. #cases)) @?= ["slow", "fast", "middle"] + map (view #outcome) (toList (result ^. #cases)) @?= replicate 3 CasePassed + result ^. #selectedExitCode @?= ExitSuccess, + testCase "keeps one hundred scheduled cases within the requested job limit" $ do + let names = ["case-" <> Text.pack (show number) | number <- [1 .. 100 :: Int]] + cases <- syntheticCases names + active <- newTVarIO (0 :: Int) + maximumActive <- newTVarIO (0 :: Int) + let runner = HurlRunner $ \_request -> do + atomically $ do + modifyTVar' active (+ 1) + current <- readTVar active + modifyTVar' maximumActive (max current) + threadDelay 1000 + atomically (modifyTVar' active (subtract 1)) + pure (Right (RunResult ExitSuccess 0 Nothing)) + result <- runBatch runner (BatchOptions (positive 7) False) cases + readTVarIO maximumActive >>= (@?= 7) + map (view #name) (toList (result ^. #cases)) @?= names + map (view #outcome) (toList (result ^. #cases)) @?= replicate 100 CasePassed, + testCase "fail-fast stops queue scheduling and marks untouched cases skipped" $ do + cases <- syntheticCases ["first", "active", "third", "fourth", "fifth"] + starts <- newTVarIO (0 :: Int) + activeStarted <- newEmptyTMVarIO + failurePublished <- newEmptyTMVarIO + let runner = HurlRunner $ \request -> do + atomically (modifyTVar' starts (+ 1)) + if requestPath request == Just "first" + then atomically (takeTMVar activeStarted) >> pure (Right (RunResult (ExitFailure 7) 0 Nothing)) + else do + atomically (putTMVar activeStarted ()) + atomically (takeTMVar failurePublished) + pure (Right (RunResult ExitSuccess 0 Nothing)) + observe caseIndex _ = when (caseIndex == 0) (atomically (putTMVar failurePublished ())) + result <- runBatchObserved runner (BatchOptions (positive 2) True) cases observe + readTVarIO starts >>= (@?= 2) + map (view #outcome) (toList (result ^. #cases)) + @?= [ CaseFailed (ExitFailure 7), + CasePassed, + CaseSkipped FailFastTriggered, + CaseSkipped FailFastTriggered, + CaseSkipped FailFastTriggered + ] + result ^. #selectedExitCode @?= ExitFailure 7, + testCase "rejects non-positive worker counts" $ do + mkPositiveInt 0 @?= Left (NonPositiveJobs 0) + positiveIntValue (positive 1) @?= 1, + testCase "prepares collision-checked owner-only response artifacts" $ + withSystemTempDirectory "hurl-workbench-artifacts" $ \directory -> do + prepared <- preparedMatrix + let outputDirectory = directory "responses" + smallPath = outputDirectory "property-page-sizes" "small.response" + expected = smallPath :| [outputDirectory "property-page-sizes" "large.response"] + prepareResponseArtifacts outputDirectory False prepared >>= \case + Left errors -> assertFailure (Text.unpack (Text.unlines (map renderArtifactError (toList errors)))) + Right paths -> do + paths @?= expected + traverse filePermissions expected >>= (@?= (ownerFileMode :| [ownerFileMode])) + directoryPermissions outputDirectory >>= (@?= ownerDirectoryMode) + directoryPermissions (outputDirectory "property-page-sizes") >>= (@?= ownerDirectoryMode) + ByteString.writeFile smallPath "keep-me" + prepareResponseArtifacts outputDirectory False prepared >>= \case + Left errors -> map renderArtifactError (toList errors) @?= map (renderArtifactError . ArtifactAlreadyExists) (toList expected) + Right _ -> assertFailure "expected existing artifacts to be rejected" + ByteString.readFile smallPath >>= (@?= "keep-me") + prepareResponseArtifacts outputDirectory True prepared >>= \case + Left errors -> assertFailure (Text.unpack (Text.unlines (map renderArtifactError (toList errors)))) + Right _ -> ByteString.readFile smallPath >>= (@?= "") + ] + +trueCapabilities :: HurlfmtCapabilities +trueCapabilities = HurlfmtCapabilities (HurlfmtExecutable "true") (makeVersion [8, 0, 1]) + +literal :: Text -> HurlValueLiteral +literal value = either (error . show) id (mkHurlValueLiteral value) + +requireBindings :: Either BindingError ResolvedBindings -> IO ResolvedBindings +requireBindings = either (assertFailure . Text.unpack . renderBindingError) pure + +positive :: Int -> PositiveInt +positive value = either (error . show) id (mkPositiveInt value) + +syntheticCases :: [Text] -> IO (NonEmpty BatchCase) +syntheticCases names = do + prepared <- preparedMatrix + let base = NonEmpty.head prepared + makeCase name = + let original = buildBatchCase ClientMode (ResponseFile (Text.unpack name)) [] base + in BatchCase + { name, + artifactStem = original ^. #artifactStem, + request = original ^. #request + } + maybe (assertFailure "synthetic case list must be non-empty") pure (nonEmpty (map makeCase names)) + +preparedMatrix :: IO (NonEmpty PreparedRun) +preparedMatrix = preparedMatrixAt Nothing + +preparedMatrixAt :: Maybe FileRoot -> IO (NonEmpty PreparedRun) +preparedMatrixAt selected = + withSystemTempDirectory "hurl-workbench-batch-bindings" $ \directory -> do + let secretsPath = directory "secrets.env" + ByteString.writeFile secretsPath "client_secret=fixture-secret\n" + workspace <- fullWorkspace + let input = + emptyBindingInput + { plainOverrides = Map.singleton (ParameterName "client_id") (literal "fixture-id"), + secretFiles = [secretsPath] + } + let prepare = case selected of + Nothing -> prepareSelectionWith (\_ _ -> pure (Right ())) + Just root -> prepareSelectionAtFileRootWith root (\_ _ -> pure (Right ())) + prepare trueCapabilities workspace input defaultHurlOptions (SelectMatrix (MatrixName "property-page-sizes")) >>= \case + Left errors -> assertFailure (Text.unpack (Text.unlines (map renderPreparationError (toList errors)))) + Right prepared -> pure prepared + +requestPath :: RunRequest -> Maybe FilePath +requestPath request = case request ^. #outputPolicy of + ResponseFile path -> Just path + _ -> Nothing + +filePermissions :: FilePath -> IO System.Posix.Types.FileMode +filePermissions path = (.&. accessModes) . fileMode <$> getFileStatus path + +directoryPermissions :: FilePath -> IO System.Posix.Types.FileMode +directoryPermissions = filePermissions + +ownerFileMode :: System.Posix.Types.FileMode +ownerFileMode = ownerReadMode `unionFileModes` ownerWriteMode + +ownerDirectoryMode :: System.Posix.Types.FileMode +ownerDirectoryMode = ownerFileMode `unionFileModes` ownerExecuteMode + +fullWorkspace :: IO ValidatedWorkspace +fullWorkspace = do + loaded <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/full/hurl-workbench.dhall") + context <- either (assertFailure . Text.unpack . renderWorkspaceError) pure loaded + validateWorkspace context >>= either (assertFailure . Text.unpack . Text.unlines . map renderValidationIssue . toList) pure + +withEnvironment :: [(String, String)] -> IO a -> IO a +withEnvironment values action = bracket save restore (const applyAndRun) + where + save = traverse (\(name, _value) -> (name,) <$> lookupEnv name) values + restore previous = for_ previous $ \(name, old) -> maybe (unsetEnv name) (setEnv name) old + applyAndRun = traverse_ (uncurry setEnv) values >> action diff --git a/test/HurlWorkbench/Service/RunTest.hs b/test/HurlWorkbench/Service/RunTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Service/RunTest.hs @@ -0,0 +1,391 @@ +module HurlWorkbench.Service.RunTest (tests, runIsolatedScenario) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (cancel, withAsync) +import Control.Exception (IOException, try) +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.Generics.Labels () +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Service.Environment (selectEnvironment) +import HurlWorkbench.Service.Resolve +import HurlWorkbench.Service.Run +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Error (renderWorkspaceError) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Directory (canonicalizePath, doesFileExist, findExecutable, removeFile) +import System.Environment (getEnvironment, getExecutablePath) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Signals (nullSignal, signalProcess) +import System.Posix.Types (ProcessID) +import System.Process.Typed (proc, readProcessStdout, readProcessStdout_, runProcess, runProcess_, setEnv) +import System.Timeout qualified as Timeout +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "managed services" + [ environmentTests, + testCase "resolves suite bindings while rejecting secret URL placeholders" $ do + workspace <- fullWorkspace + secret <- either (assertFailure . show) pure (mkSecretValue "never-print-this") + let bindings = + ResolvedBindings + (Map.singleton (ParameterName "top") (literal "43123")) + (Map.singleton (ParameterName "client_secret") secret) + processSpec = + CommandSpec + "python3" + ["-c", "import time; time.sleep(60)"] + Nothing + Inherit + [EnvironmentBinding "SERVICE_TOKEN" (ParameterName "client_secret")] + httpReadiness url = HttpReadinessCheck (HttpReadiness url 200 20 2) + service = Service (ServiceName "fixture") processSpec (httpReadiness "http://127.0.0.1:{{top}}/health") 1 Nothing + case resolveService workspace bindings service of + Left err -> assertFailure (Text.unpack (renderServiceError err)) + Right resolved -> do + resolved ^. #readiness @?= ResolvedHttpReadiness "http://127.0.0.1:43123/health" 200 20000 2 + assertBool "resolved command show output redacts environment values" (not ("never-print-this" `Text.isInfixOf` Text.pack (show resolved))) + let secretReadiness :: Service + secretReadiness = + Service + (ServiceName "fixture") + processSpec + (httpReadiness "http://127.0.0.1/{{client_secret}}") + 1 + Nothing + resolveService workspace bindings secretReadiness + @?= Left (ServiceReadinessSecretPlaceholder (ParameterName "client_secret")), + testCase "polls HTTP status and terminates the process group after the callback" $ + withSystemTempDirectory "hurl-workbench-http-service" $ \directory -> do + port <- unusedPort + let readyPath = directory "ready" + countPath = directory "requests" + service = + directService + (pythonCommand [httpFixture, show port, readyPath, countPath]) + (ResolvedHttpReadiness (healthUrl port) 200 20000 3) + outcome <- withService service $ \handle -> do + alive <- processAlive (serviceProcessId handle) + assertBool "service is alive while callback runs" alive + readCount countPath + case outcome of + Left err -> assertFailure (Text.unpack (renderServiceError err)) + Right requestCount -> assertBool "readiness retried a non-200 response" (requestCount >= 2) + pid <- readFixturePid readyPath + assertProcessStopped pid, + testCase "supports command readiness probes" $ + withSystemTempDirectory "hurl-workbench-command-service" $ \directory -> do + let readyPath = directory "ready" + pidPath = directory "pid" + service = + directService + (pythonCommand [delayedMarkerFixture, readyPath, pidPath]) + ( ResolvedCommandReadiness + (pythonCommand [fileProbe, readyPath]) + 20000 + 3 + ) + outcome <- withService service (pure . serviceProcessId) + case outcome of + Left err -> assertFailure (Text.unpack (renderServiceError err)) + Right pid -> assertProcessStopped pid, + testCase "bounds a hanging readiness command and cleans up the service" $ + withSystemTempDirectory "hurl-workbench-readiness-timeout" $ \directory -> do + let pidPath = directory "pid" + service = + ( directService + (pythonCommand [pidSleepFixture, pidPath]) + (ResolvedCommandReadiness (pythonCommand [hangingProbe]) 10000 0.15) + ) + { shutdownTimeout = 0.2 + } + withService service (const (pure ())) >>= (@?= Left (ServiceReadinessTimedOut (ServiceName "fixture"))) + readFixturePid pidPath >>= assertProcessStopped, + testCase "reports a service that exits before readiness" $ do + let service = + directService + (pythonCommand ["import sys; sys.exit(7)"]) + (ResolvedCommandReadiness (pythonCommand ["import sys; sys.exit(1)"]) 10000 1) + withService service (const (pure ())) >>= \case + Left (ServiceExitedBeforeReady (ServiceName "fixture") _) -> pure () + other -> assertFailure ("expected an early-exit error, got " <> show other), + testCase "escalates from TERM to KILL when the service ignores TERM" $ + withSystemTempDirectory "hurl-workbench-service-kill" $ \directory -> do + let pidPath = directory "pid" + service = + ( directService + (pythonCommand [ignoreTermFixture, pidPath]) + (ResolvedCommandReadiness (pythonCommand ["import sys; sys.exit(0)"]) 10000 1) + ) + { shutdownTimeout = 0.1 + } + outcome <- withService service (pure . serviceProcessId) + case outcome of + Left err -> assertFailure (Text.unpack (renderServiceError err)) + Right pid -> assertProcessStopped pid, + testCase "cleanup kills a TERM-ignoring descendant after its leader exits" $ + withSystemTempDirectory "service-orphan" $ \directory -> do + let pidPath = directory "descendant" + code = + "import os, signal, sys, time; child = os.fork(); " + <> "exec(\"if child == 0:\\n signal.signal(signal.SIGTERM, signal.SIG_IGN)\\n open(sys.argv[1], 'w').write(str(os.getpid()))\\n while True: time.sleep(1)\\nelse:\\n while not os.path.exists(sys.argv[1]): time.sleep(0.01)\\n os._exit(7)\")" + service = (directService (pythonCommand [code, pidPath]) (ResolvedCommandReadiness (pythonCommand ["import time; time.sleep(0.2); raise SystemExit(1)"]) 10000 1)) {shutdownTimeout = 0.3} + withService service (const (assertFailure "orphaned service became ready" :: IO ())) >>= \case + Left (ServiceExitedBeforeReady _ _) -> pure () + other -> assertFailure ("expected early exit, got " <> show other) + pid <- readFixturePid pidPath + -- A killed orphan may briefly remain as an init-owned zombie on Linux. + alive <- processAlive pid + state <- if not alive then pure "" else snd <$> readProcessStdout (proc "ps" ["-p", show pid, "-o", "stat="]) + assertBool "descendant is terminated" (LazyByteString.null state || 'Z' `elem` LazyByteString.unpack state), + testCase "async cancellation waits for managed-service cleanup" $ + withSystemTempDirectory "hurl-workbench-service-cancel" $ \directory -> do + let pidPath = directory "pid" + callbackPath = directory "callback" + service = + directService + (pythonCommand [pidSleepFixture, pidPath]) + (ResolvedCommandReadiness (pythonCommand ["import sys; sys.exit(0)"]) 10000 1) + withAsync + ( withService service $ \_handle -> do + writeFile callbackPath "running" + threadDelay 10000000 + ) + $ \worker -> do + waitForFile callbackPath + pid <- readFixturePid pidPath + cancel worker + assertProcessStopped pid + ] + +directService :: ResolvedCommand -> ResolvedReadiness -> ResolvedService +directService processConfig readiness = + ResolvedService + { name = ServiceName "fixture", + processConfig, + readiness, + shutdownTimeout = 1 + } + +pythonCommand :: [String] -> ResolvedCommand +pythonCommand arguments = + ResolvedCommand + { executable = "python3", + arguments = "-c" : arguments, + workingDirectory = ".", + environmentPolicy = Inherit, + environment = [] + } + +healthUrl :: Int -> Text +healthUrl port = "http://127.0.0.1:" <> Text.pack (show port) <> "/health" + +unusedPort :: IO Int +unusedPort = do + output <- + readProcessStdout_ + ( proc + "python3" + [ "-c", + "import socket; s=socket.socket(); s.bind(('127.0.0.1', 0)); print(s.getsockname()[1]); s.close()" + ] + ) + case reads (LazyByteString.unpack output) of + [(port, _)] -> pure port + _ -> assertFailure "python failed to return an unused TCP port" + +processAlive :: ProcessID -> IO Bool +processAlive pid = either (const False) (const True) <$> try @IOException (signalProcess nullSignal pid) + +assertProcessStopped :: ProcessID -> IO () +assertProcessStopped pid = do + alive <- processAlive pid + assertBool ("process " <> show pid <> " is still alive") (not alive) + +waitForFile :: FilePath -> IO () +waitForFile path = do + result <- Timeout.timeout 2000000 loop + case result of + Nothing -> assertFailure ("timed out waiting for fixture file " <> path) + Just () -> pure () + where + loop = do + exists <- doesFileExist path + if exists then pure () else threadDelay 10000 >> loop + +readFixturePid :: FilePath -> IO ProcessID +readFixturePid path = do + waitForFile path + read <$> readFile path + +readCount :: FilePath -> IO Int +readCount path = do + waitForFile path + read <$> readFile path + +literal :: Text -> HurlValueLiteral +literal value = either (error . show) id (mkHurlValueLiteral value) + +fullWorkspace :: IO ValidatedWorkspace +fullWorkspace = do + loaded <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/full/hurl-workbench.dhall") + context <- either (assertFailure . Text.unpack . renderWorkspaceError) pure loaded + validateWorkspace context >>= either (assertFailure . Text.unpack . Text.unlines . map renderValidationIssue . toList) pure + +httpFixture :: String +httpFixture = + unlines + [ "import http.server, os, sys, threading", + "port, ready, count = int(sys.argv[1]), sys.argv[2], sys.argv[3]", + "open(ready, 'w').write(str(os.getpid()))", + "threading.Timer(0.25, lambda: open(ready + '.status', 'w').close()).start()", + "class Handler(http.server.BaseHTTPRequestHandler):", + " def do_GET(self):", + " n = int(open(count).read()) if os.path.exists(count) else 0", + " open(count, 'w').write(str(n + 1))", + " self.send_response(200 if os.path.exists(ready + '.status') else 503)", + " self.end_headers()", + " def log_message(self, format, *args): pass", + "http.server.ThreadingHTTPServer(('127.0.0.1', port), Handler).serve_forever()" + ] + +delayedMarkerFixture :: String +delayedMarkerFixture = + unlines + [ "import os, sys, threading, time", + "ready, pid = sys.argv[1], sys.argv[2]", + "open(pid, 'w').write(str(os.getpid()))", + "threading.Timer(0.2, lambda: open(ready, 'w').close()).start()", + "time.sleep(60)" + ] + +pidSleepFixture :: String +pidSleepFixture = "import os, sys, time; open(sys.argv[1], 'w').write(str(os.getpid())); time.sleep(60)" + +fileProbe :: String +fileProbe = "import os, sys; sys.exit(0 if os.path.exists(sys.argv[1]) else 1)" + +hangingProbe :: String +hangingProbe = "import time; time.sleep(60)" + +ignoreTermFixture :: String +ignoreTermFixture = + "import os, signal, sys, time; signal.signal(signal.SIGTERM, signal.SIG_IGN); open(sys.argv[1], 'w').write(str(os.getpid())); time.sleep(60)" + +environmentTests :: TestTree +environmentTests = + testGroup + "environment policies" + [ testCase "private parent selects empty values, overrides selected values, and excludes sentinels" $ + withSystemTempDirectory "private-policy-parent" $ \directory -> do + binary <- nativeBinary directory + runner <- getExecutablePath + let privateEnvironment = [("SELECTED", ""), ("BOUND", "private-ambient-sentinel"), ("REI_PG_CONNECTION_STRING", "private-rei-sentinel"), ("REI_CONFIG", "private-config-sentinel"), ("MORI_API_URL", "private-mori-sentinel")] + runProcess (setEnv privateEnvironment (proc runner ["--clean-environment-scenario", binary, directory])) >>= (@?= ExitSuccess), + testCase "old and clean manifests reach native children through validation and resolution" $ + withSystemTempDirectory "policy-roundtrip" $ \directory -> do + binary <- nativeBinary directory + schema <- canonicalizePath "schema/package.dhall" + let clean = ", environmentPolicy = < Inherit | Clean : List Text >.Clean ([] : List Text)" + for_ [("", "", "inherit", "inherit"), (clean, clean, "[]", "[]"), ("", clean, "inherit", "[]"), (clean, "", "[]", "inherit")] $ \(policy, probePolicy, expected, probeExpected) -> do + let command policyField expectation mode marker = "{ executable = " <> show binary <> ", arguments = " <> show ["--environment-fixture", mode, marker, expectation] <> ", workingDirectory = None Text, environment = [] : List { variable : Text, parameter : Text }" <> policyField <> " }" + source = "let Schema = " <> schema <> " in Schema.Workspace.default // { schemaVersion = 1, services = [ { name = \"fixture\", command = " <> command policy expected "service" (directory "service") <> ", readiness = < Command : { command : " <> commandType probePolicy <> ", intervalMilliseconds : Natural, timeoutSeconds : Natural } | Http : { url : Text, expectedStatus : Natural, intervalMilliseconds : Natural, timeoutSeconds : Natural } >.Command { command = " <> command probePolicy probeExpected "probe" (directory "probe") <> ", intervalMilliseconds = 10, timeoutSeconds = 2 }, shutdownTimeoutSeconds = 1, description = None Text } ] }" + path = directory "hurl-workbench.dhall" + writeFile path source + loaded <- loadWorkspaceContext (ExplicitWorkspace path) >>= either (assertFailure . show) pure + workspace <- validateWorkspace loaded >>= either (assertFailure . show) pure + service <- maybe (assertFailure "missing fixture") pure (lookupService (ServiceName "fixture") workspace) + resolved <- either (assertFailure . show) pure (resolveService workspace (ResolvedBindings Map.empty Map.empty) service) + result <- withService resolved (pure . serviceProcessId) + either (assertFailure . show) assertProcessStopped result + removeFile (directory "service"), + testCase "selection requires inherited names and overlays explicit bindings" $ do + selectEnvironment Inherit [("A", "ambient"), ("B", "")] [("A", "explicit")] @?= Right [("A", "explicit"), ("B", "")] + selectEnvironment (Clean []) [("PATH", "hidden")] [] @?= Right [] + selectEnvironment (Clean ["B", "A"]) [("A", "ambient"), ("B", ""), ("HOME", "hidden")] [("A", "explicit")] @?= Right [("A", "explicit"), ("B", "")] + selectEnvironment (Clean ["MISSING"]) [] [("MISSING", "explicit")] @?= Left ["MISSING"], + testCase "native clean service and readiness have exact independent environments" $ + withSystemTempDirectory "clean-native" $ \directory -> do + binary <- nativeBinary directory + let native :: String -> FilePath -> [String] -> ResolvedCommand + native mode marker names = ResolvedCommand binary ["--environment-fixture", mode, marker, show (sort names)] "." (Clean []) [] + serviceCommand = native "service" (directory "service") ["BOUND"] & #environment .~ [("BOUND", "private-bound-sentinel")] + readinessCommand = native "retry" (directory "probe") [] + service = directService serviceCommand (ResolvedCommandReadiness readinessCommand 10000 2) + result <- withService service (pure . serviceProcessId) + case result of + Left err -> assertFailure (show err) + Right pid -> assertProcessStopped pid + readFile (directory "probe.attempts") >>= (@?= "2") + assertBool "resolved metadata redacts bound secret" (not ("private-bound-sentinel" `Text.isInfixOf` Text.pack (show service))), + testCase "native inherited children retain ambient variable names" $ + withSystemTempDirectory "inherit-native" $ \directory -> do + binary <- nativeBinary directory + let command mode path = ResolvedCommand binary ["--environment-fixture", mode, path, "inherit"] "." Inherit [] + result <- withService (directService (command "service" (directory "service")) (ResolvedCommandReadiness (command "probe" (directory "probe")) 10000 2)) (pure . serviceProcessId) + either (assertFailure . show) assertProcessStopped result, + testCase "clean cancellation and failed readiness finish service cleanup" $ + withSystemTempDirectory "clean-cleanup" $ \directory -> do + binary <- nativeBinary directory + let servicePath = directory "service" + command mode marker = ResolvedCommand binary ["--environment-fixture", mode, marker, "[]"] "." (Clean []) [] + service probe = directService (command "service" servicePath) (ResolvedCommandReadiness probe 10000 0.3) + withService (service (command "service" (directory "hanging-probe"))) (const (pure ())) >>= (@?= Left (ServiceReadinessTimedOut (ServiceName "fixture"))) + readFixturePid servicePath >>= assertProcessStopped + removeFile servicePath + withAsync (withService (service (command "probe" (directory "probe"))) (\_ -> writeFile (directory "callback") "ready" >> threadDelay 10000000)) $ \worker -> do + waitForFile (directory "callback") + pid <- readFixturePid servicePath + cancel worker + assertProcessStopped pid, + testCase "failure diagnostics redact bound secret values" $ do + let bound = pythonCommand [] & #environmentPolicy .~ Clean [] & #environment .~ [("BOUND", "private-bound-sentinel")] + absent = bound & #executable .~ "/missing/clean-environment-executable" + missing = bound & #environmentPolicy .~ Clean ["HURL_WORKBENCH_TEST_ABSENT_972638"] + for_ [(absent, bound), (bound, absent), (missing, bound)] $ \(command, probe) -> do + outcome <- withService (directService command (ResolvedCommandReadiness probe 10000 1)) (const (pure ())) + case outcome of + Left err -> assertBool "diagnostics exclude secret" (not ("private-bound-sentinel" `Text.isInfixOf` (renderServiceError err <> Text.pack (show err)))) + Right () -> assertFailure "expected command failure", + testCase "missing service or readiness names fail before startup" $ + withSystemTempDirectory "clean-missing" $ \directory -> do + binary <- nativeBinary directory + let marker = directory "started" + command = ResolvedCommand binary ["--environment-fixture", "service", marker, "[]"] "." (Clean []) [] + missing = command & #environmentPolicy .~ Clean ["HURL_WORKBENCH_TEST_ABSENT_972638"] + for_ [(missing, command, "command"), (command, missing, "readiness command")] $ \(serviceCommand, probe, phase) -> do + withService (directService serviceCommand (ResolvedCommandReadiness probe 10000 1)) (const (pure ())) + >>= (@?= Left (ServiceEnvironmentMissing (ServiceName "fixture") phase ["HURL_WORKBENCH_TEST_ABSENT_972638"])) + doesFileExist marker >>= (@?= False) + ] + +nativeBinary :: FilePath -> IO FilePath +nativeBinary directory = do + let binary = directory "environment-fixture" + compiler <- findExecutable "cc" >>= maybe (assertFailure "cc is required for native environment tests") pure + ambient <- getEnvironment + runProcess_ (setEnv ambient (proc compiler ["test/fixtures/processes/environment.c", "-o", binary])) + pure binary + +commandType :: String -> String +commandType policy = + "{ executable : Text, arguments : List Text, workingDirectory : Optional Text, environment : List { variable : Text, parameter : Text }" <> (if null policy then "" else ", environmentPolicy : < Inherit | Clean : List Text >") <> " }" + +-- | Invoked in a subprocess whose environment belongs exclusively to this test. +runIsolatedScenario :: FilePath -> FilePath -> IO () +runIsolatedScenario binary directory = do + let serviceCommand = ResolvedCommand binary ["--environment-fixture", "service", directory "service", "[\"BOUND\",\"SELECTED\"]"] "." (Clean ["SELECTED", "BOUND"]) [("BOUND", "private-bound-sentinel")] + probe = ResolvedCommand binary ["--environment-fixture", "probe", directory "probe", "[\"SELECTED\"]"] "." (Clean ["SELECTED"]) [] + result <- withService (directService serviceCommand (ResolvedCommandReadiness probe 10000 2)) (pure . serviceProcessId) + either (assertFailure . show) assertProcessStopped result diff --git a/test/HurlWorkbench/Suite/LifecycleTest.hs b/test/HurlWorkbench/Suite/LifecycleTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Suite/LifecycleTest.hs @@ -0,0 +1,354 @@ +module HurlWorkbench.Suite.LifecycleTest (tests) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (cancel, waitCatch, withAsync) +import Control.Concurrent.MVar (newMVar, withMVar) +import Control.Concurrent.STM +import Control.Exception (IOException, bracket_, try) +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Version (makeVersion) +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Batch +import HurlWorkbench.Suite.Resolve +import HurlWorkbench.Suite.Run +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Directory (doesFileExist) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Signals (nullSignal, signalProcess) +import System.Timeout qualified as Timeout +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "ordered multi-service lifecycle" + [ testCase "jobs=2 batches drain around restart and cleanup follows new acquisition order" $ + fixture $ \directory original -> do + workspace <- changed original $ \ws -> ws & #suites %~ map (\suite -> suite & #runs .~ [RecipeRun (RecipeName "r1"), RecipeRun (RecipeName "r2"), ServiceRun (Restart (ServiceName "s1")), RecipeRun (RecipeName "r3"), RecipeRun (RecipeName "r4")]) + eventLock <- newMVar () + active <- newTVarIO (0 :: Int) + peak <- newTVarIO (0 :: Int) + calls <- newTVarIO (0 :: Int) + let runner = HurlRunner $ \_ -> bracket_ + (atomically (modifyTVar' active (+ 1) >> readTVar active >>= \n -> modifyTVar' peak (max n))) + (atomically (modifyTVar' active (subtract 1))) + $ do + ordinal <- atomically (modifyTVar' calls (+ 1) >> readTVar calls) + withMVar eventLock $ \_ -> appendFile (directory "events") ("hurl-start-" <> show ordinal <> "\n") + threadDelay 80000 + withMVar eventLock $ \_ -> appendFile (directory "events") ("hurl-end-" <> show ordinal <> "\n") + pure (Right success) + result <- run directory workspace 2 runner + result ^. #selectedExitCode @?= ExitSuccess + readTVarIO peak >>= (@?= 2) + events <- lines <$> readFile (directory "events") + take 7 events @?= ["setup", "s1-start", "s1-ready", "s2-start", "s2-ready", "s3-start", "s3-ready"] + take 3 (drop 11 events) @?= ["s1-stop", "s1-start", "s1-ready"] + drop (length events - 4) events @?= ["s1-stop", "s3-stop", "s2-stop", "teardown"] + [event ^. #action | LifecycleStep event <- result ^. #steps] @?= ["restart"] + map (view #outcome) (toList (result ^. #cases)) @?= replicate 4 CasePassed + raw <- ByteString.readFile (directory "reports" "failure" "summary.json") + assertBool "private output not serialized" (not ("private-phaseSpec-sentinel" `ByteString.isInfixOf` raw)) + ByteString.readFile (directory "reports" "failure" "phases" "setup" "0" "stdout") >>= (@?= "private-phaseSpec-sentinel\n") + assertStopped directory, + testCase "Stop and Start are barriers and intentional monitor retirement succeeds" $ + fixture $ \directory original -> do + workspace <- changed original $ \ws -> ws & #suites %~ map (\suite -> suite & #runs .~ [ServiceRun (Stop (ServiceName "s2")), RecipeRun (RecipeName "r1"), ServiceRun (Start (ServiceName "s2")), RecipeRun (RecipeName "r2")]) + result <- run directory workspace 1 passingRunner + result ^. #selectedExitCode @?= ExitSuccess + [event ^. #action | LifecycleStep event <- result ^. #steps] @?= ["stop", "start"] + assertStopped directory, + testCase "second and third readiness failures clean the failing group first" $ + for_ ["s2", "s3"] $ \failed -> fixture $ \directory original -> do + workspace <- changed original $ \ws -> ws & #services %~ map (\definition -> if definition ^. #name == ServiceName failed then definition & #readiness .~ CommandReadinessCheck (CommandReadiness (pythonSpec "raise SystemExit(1)") 10 1) else definition) + result <- run directory workspace 1 forbidden + result ^. #selectedExitCode @?= ExitFailure 4 + events <- lines <$> readFile (directory "events") + let count = if failed == "s2" then 2 else 3 + drop (1 + 2 * count) events @?= (reverse (take count ["s1-stop", "s2-stop", "s3-stop"]) <> ["teardown"]) + assertStopped directory, + testCase "setup failure skips later setup and services, attempts every teardown" $ + fixture $ \directory original -> do + workspace <- changed original $ \ws -> + ws + & #suites + %~ map + ( \suite -> + suite + & #setup + .~ [phaseSpec directory "setup-failed" 9, phaseSpec directory "unreachable" 0] + & #teardown + .~ [phaseSpec directory "teardown-failed" 7, phaseSpec directory "teardown-last" 0] + ) + result <- run directory workspace 1 forbidden + result ^. #selectedExitCode @?= ExitFailure 4 + result ^. #primaryFailure @?= Just "setup-failed" + map (view #status) (result ^. #phases) @?= [CommandFailed, CommandSkipped, CommandFailed, CommandPassed] + lines <$> readFile (directory "events") >>= (@?= ["setup-failed", "teardown-failed", "teardown-last"]), + testCase "Hurl primary failure survives failing teardown and fail-fast skips barriers" $ + fixture $ \directory original -> do + workspace <- changed original $ \ws -> + ws + & #suites + %~ map + ( \suite -> + suite + & #failFast + .~ True + & #runs + .~ [RecipeRun (RecipeName "r1"), ServiceRun (Restart (ServiceName "s1")), RecipeRun (RecipeName "r2")] + & #teardown + .~ [phaseSpec directory "teardown" 8] + ) + result <- run directory workspace 1 (HurlRunner (const (pure (Right (success & #exitCode .~ ExitFailure 5))))) + result ^. #selectedExitCode @?= ExitFailure 4 + result ^. #primaryFailure @?= Just "hurl-failed" + [event ^. #status | LifecycleStep event <- result ^. #steps] @?= ["skipped"] + map (view #outcome) (toList (result ^. #cases)) @?= [CaseFailed (ExitFailure 5), CaseSkipped FailFastTriggered] + assertStopped directory, + testCase "keep-going reaches later batches after ordinary Hurl failures" $ + fixture $ \directory original -> do + workspace <- changed original $ \ws -> ws & #suites %~ map (\suite -> suite & #runs .~ [RecipeRun (RecipeName "r1"), ServiceRun (Restart (ServiceName "s1")), RecipeRun (RecipeName "r2")]) + result <- run directory workspace 1 (HurlRunner (const (pure (Right (success & #exitCode .~ ExitFailure 5))))) + result ^. #selectedExitCode @?= ExitFailure 5 + [event ^. #status | LifecycleStep event <- result ^. #steps] @?= ["passed"] + map (view #outcome) (toList (result ^. #cases)) @?= replicate 2 (CaseFailed (ExitFailure 5)), + testCase "unexpected leader death cancels active children and preserves completed cases" $ + fixture $ \directory original -> do + calls <- newTVarIO (0 :: Int) + active <- newTVarIO (0 :: Int) + blocked <- newEmptyTMVarIO + let runner = HurlRunner $ \_ -> do + ordinal <- atomically (modifyTVar' calls (+ 1) >> readTVar calls) + if ordinal == 1 + then pure (Right success) + else bracket_ + (atomically (modifyTVar' active (+ 1))) + (atomically (modifyTVar' active (subtract 1))) + $ do + writeFile (directory "s1-die") "die" + _ <- atomically (takeTMVar blocked) + pure (Right success) + result <- bounded (run directory original 1 runner) + result ^. #selectedExitCode @?= ExitFailure 4 + readTVarIO active >>= (@?= 0) + map (view #outcome) (take 1 (toList (result ^. #cases))) @?= [CasePassed] + assertStopped directory, + testCase "cancellation reaps all services before teardown and writes partial summary" $ + fixture $ \directory original -> do + started <- newEmptyTMVarIO + blocked <- newEmptyTMVarIO + let runner = HurlRunner $ \_ -> do + atomically (putTMVar started ()) + _ <- atomically (takeTMVar blocked) + pure (Right success) + withAsync (run directory original 1 runner) $ \worker -> do + bounded (atomically (takeTMVar started)) + bounded (cancel worker) + waitCatch worker >>= \case Left _ -> pure (); Right _ -> assertFailure "cancellation was swallowed" + events <- lines <$> readFile (directory "events") + drop (length events - 4) events @?= ["s3-stop", "s2-stop", "s1-stop", "teardown"] + summary <- ByteString.readFile (directory "reports" "failure" "summary.json") + assertBool "cancelled summary retained" ("cancelled" `ByteString.isInfixOf` summary) + assertStopped directory, + testCase "teardown collectively expires and records remaining skips" $ + fixture $ \directory original -> do + workspace <- changed original $ \ws -> + ws + & #suites + %~ map + ( \suite -> + suite + & #cleanupTimeoutSeconds + .~ 1 + & #teardown + .~ [pythonSpec "import time; time.sleep(30)", phaseSpec directory "unreachable-teardown" 0] + ) + result <- bounded (run directory workspace 1 passingRunner) + result ^. #selectedExitCode @?= ExitFailure 4 + map (view #status) (filter ((== "teardown") . view #phase) (result ^. #phases)) @?= [CommandTimedOut, CommandSkipped] + assertStopped directory, + testCase "service restarts and teardown retain the preflight environment snapshot" $ + fixture $ \directory original -> do + previous <- lookupEnv "HURL_WORKBENCH_SNAPSHOT_TEST" + let restore = maybe (unsetEnv "HURL_WORKBENCH_SNAPSHOT_TEST") (setEnv "HURL_WORKBENCH_SNAPSHOT_TEST") previous + bracket_ (setEnv "HURL_WORKBENCH_SNAPSHOT_TEST" "initial") restore $ do + workspace <- changed original $ \ws -> + ws + & #services + %~ map + ( \definition -> + definition + & #command + . #arguments + %~ ( \args -> case args of + [flag, code] -> [flag, "import os; assert os.environ['HURL_WORKBENCH_SNAPSHOT_TEST'] == 'initial'; " <> code] + _ -> args + ) + ) + & #suites + %~ map + ( \suite -> + suite + & #runs + .~ [RecipeRun (RecipeName "r1"), ServiceRun (Restart (ServiceName "s1")), RecipeRun (RecipeName "r2")] + & #teardown + .~ [pythonSpec "import os; assert os.environ['HURL_WORKBENCH_SNAPSHOT_TEST'] == 'initial'"] + ) + let runner = HurlRunner (\_ -> setEnv "HURL_WORKBENCH_SNAPSHOT_TEST" "changed" >> pure (Right success)) + result <- run directory workspace 1 runner + result ^. #selectedExitCode @?= ExitSuccess, + testCase "all late phase environments are preflighted before setup" $ + fixture $ \directory original -> do + workspace <- changed original $ \ws -> ws & #suites %~ map (\suite -> suite & #teardown .~ [pythonSpec "pass" & #environmentPolicy .~ Clean ["HURL_WORKBENCH_MISSING_PHASE_918273"]]) + result <- runSuiteWith validate forbidden capabilities workspace (suiteRequest directory 1) + case result of Left _ -> pure (); Right _ -> assertFailure "bad late pythonSpec accepted" + doesFileExist (directory "events") >>= (@?= False), + testCase "external mode rejects lifecycle steps and bypasses all phases otherwise" $ + fixture $ \directory original -> do + let req = suiteRequest directory 1 & #suiteOptions . #manageService .~ False + result <- runSuiteWith validate passingRunner capabilities original req >>= requireResult + result ^. #services @?= [] + result ^. #phases @?= [] + doesFileExist (directory "events") >>= (@?= False) + workspace <- changed original $ \ws -> ws & #suites %~ map (\suite -> suite & #runs %~ (ServiceRun (Restart (ServiceName "s1")) :)) + rejected <- runSuiteWith validate forbidden capabilities workspace (req & #suiteOptions . #overwriteReports .~ True) + case rejected of Left err -> assertBool "external lifecycle refusal" (SuiteExternalLifecycle `elem` toList (err ^. #issues)); Right _ -> assertFailure "external restart accepted", + testCase "invalid transitions, duplicate services, ambiguous sugar, and zero budgets are rejected" $ + fixture $ \_ original -> for_ + [ \suite -> suite & #runs %~ (ServiceRun (Start (ServiceName "s1")) :), + \suite -> suite & #runs %~ (ServiceRun (Stop (ServiceName "unknown")) :), + \suite -> suite & #services .~ [ServiceName "s1", ServiceName "s1"], + \suite -> suite & #service .~ Just (ServiceName "s1"), + \suite -> suite & #commandTimeoutSeconds .~ 0, + \suite -> suite & #cleanupTimeoutSeconds .~ 0 + ] + $ \change -> do + result <- validateWorkspace (validatedContext original & #workspace . #suites %~ map change) + case result of Left _ -> pure (); Right _ -> assertFailure "invalid lifecycle accepted" + ] + +fixture :: (FilePath -> ValidatedWorkspace -> IO a) -> IO a +fixture action = withSystemTempDirectory "multi-service" $ \directory -> do + context <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/suite-failure/hurl-workbench.dhall") >>= either (assertFailure . show) pure + original <- validateWorkspace context >>= either (assertFailure . show) pure + workspace <- changed original $ \ws -> + ws + & #services + .~ map (serviceSpec directory) ["s1", "s2", "s3"] + & #recipes + .~ [recipe & #name .~ RecipeName name | recipe <- ws ^. #recipes, name <- ["r1", "r2", "r3", "r4"]] + & #suites + %~ map + ( \suite -> + suite + & #service + .~ Nothing + & #services + .~ map ServiceName ["s1", "s2", "s3"] + & #runs + .~ map (RecipeRun . RecipeName) ["r1", "r2", "r3", "r4"] + & #setup + .~ [phaseSpec directory "setup" 0] + & #teardown + .~ [phaseSpec directory "teardown" 0] + ) + action directory workspace + +changed :: ValidatedWorkspace -> (Workspace -> Workspace) -> IO ValidatedWorkspace +changed original change = validateWorkspace (validatedContext original & #workspace %~ change) >>= either (assertFailure . show) pure + +pythonSpec :: Text -> CommandSpec +pythonSpec code = CommandSpec "python3" ["-c", code] Nothing Inherit [] + +phaseSpec :: FilePath -> String -> Int -> CommandSpec +phaseSpec directory label exitCode = pythonSpec (Text.pack ("open(" <> show (directory "events") <> ", 'a').write(" <> show (label <> "\n") <> "); print('private-phaseSpec-sentinel'); raise SystemExit(" <> show exitCode <> ")")) + +serviceSpec :: FilePath -> Text -> Service +serviceSpec directory name = + Service + (ServiceName name) + (pythonSpec script) + (CommandReadinessCheck (CommandReadiness (pythonSpec probe) 10 2)) + 1 + Nothing + where + prefix = directory Text.unpack name + probe = Text.pack ("import os; raise SystemExit(0 if os.path.exists(" <> show (prefix <> "-ready") <> ") else 1)") + script = + Text.unlines + [ "import os, signal, time", + "prefix = " <> Text.pack (show prefix), + "events = " <> Text.pack (show (directory "events")), + "def event(value):", + " with open(events, 'a') as out: out.write(value + '\\n')", + "def stop(*args):", + " event('" <> name <> "-stop')", + " if os.path.exists(prefix + '-ready'): os.unlink(prefix + '-ready')", + " raise SystemExit(0)", + "signal.signal(signal.SIGTERM, stop)", + "open(prefix + '-pid', 'a').write(str(os.getpid()) + '\\n')", + "event('" <> name <> "-start')", + "time.sleep(0.03)", + "event('" <> name <> "-ready')", + "open(prefix + '-ready', 'w').write('ready')", + "while not os.path.exists(prefix + '-die'): time.sleep(0.01)", + "raise SystemExit(9)" + ] + +suiteRequest :: FilePath -> Int -> SuiteRequest +suiteRequest directory jobs = + SuiteRequest + (SuiteName "failure") + Nothing + Nothing + emptyBindingInput + defaultHurlOptions + (SuiteOptions (either (error . show) id (mkPositiveInt jobs)) Nothing False True Set.empty (Just (directory "reports")) False) + +capabilities :: HurlfmtCapabilities +capabilities = HurlfmtCapabilities (HurlfmtExecutable "true") (makeVersion [8, 0, 1]) + +validate :: HurlfmtCapabilities -> a -> IO (Either HurlfmtError ()) +validate _ _ = pure (Right ()) + +run :: FilePath -> ValidatedWorkspace -> Int -> HurlRunner -> IO SuiteResult +run directory workspace jobs runner = runSuiteWith validate runner capabilities workspace (suiteRequest directory jobs) >>= requireResult + +requireResult :: Either SuitePreflightError SuiteResult -> IO SuiteResult +requireResult = either (assertFailure . show) pure + +success :: RunResult +success = RunResult ExitSuccess 0.01 Nothing + +passingRunner :: HurlRunner +passingRunner = HurlRunner (const (pure (Right success))) + +forbidden :: HurlRunner +forbidden = HurlRunner (const (assertFailure "Hurl must not start")) + +bounded :: IO a -> IO a +bounded action = Timeout.timeout 12000000 action >>= maybe (assertFailure "lifecycle did not finish within 12 seconds") pure + +assertStopped :: FilePath -> IO () +assertStopped directory = for_ ["s1", "s2", "s3"] $ \name -> do + let path = directory name <> "-pid" + exists <- doesFileExist path + when exists $ do + pids <- map read . lines <$> readFile path + for_ pids $ \pid -> do + alive <- try @IOException (signalProcess nullSignal pid) + assertBool ("owned child survived: " <> show pid) (either (const True) (const False) alive) diff --git a/test/HurlWorkbench/Suite/RunTest.hs b/test/HurlWorkbench/Suite/RunTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Suite/RunTest.hs @@ -0,0 +1,359 @@ +module HurlWorkbench.Suite.RunTest (tests) where + +import Control.Concurrent.Async (AsyncCancelled (..), cancel, waitCatch, withAsync) +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newEmptyTMVarIO, newTVarIO, putTMVar, readTVar, readTVarIO, takeTMVar) +import Control.Exception (bracket_, fromException) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Version (makeVersion) +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Hurl.Run +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Batch +import HurlWorkbench.Run.FileRoot +import HurlWorkbench.Suite.Isolation +import HurlWorkbench.Suite.LifecycleTest qualified as LifecycleTest +import HurlWorkbench.Suite.Resolve +import HurlWorkbench.Suite.Run +import HurlWorkbench.Suite.Scenario (ScenarioInputs (..)) +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Error (renderWorkspaceError) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Directory (createDirectoryIfMissing, createDirectoryLink, doesPathExist) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "integration suites" + [ LifecycleTest.tests, + testCase "explicit suite roots reach every request and protect refusal-summary inputs" $ + withSystemTempDirectory "suite-file-root" $ \directory -> do + workspace <- loadValidated "test/fixtures/workspaces/isolation/hurl-workbench.dhall" + root <- validateFileRoot directory (Just directory) >>= either (assertFailure . show) pure + requests <- newTVarIO [] + let input = emptyBindingInput {plainOverrides = Map.singleton (ParameterName "baseUrl") (literal "http://fixture.test")} + request = SuiteRequest (SuiteName "reads") (Just root) Nothing input defaultHurlOptions (SuiteOptions (positive 2) Nothing False False Set.empty Nothing False) + _ <- runSuite (recordingRunner requests) trueCapabilities workspace request >>= requireSuite + observed <- readTVarIO requests + assertBool "all suite cases ran" (length observed > 1) + for_ observed $ \run -> run ^. #fileRoot @?= root + let forbidden _ _ = assertFailure "formatter ran before output preflight" + result <- runSuiteWith forbidden (HurlRunner (const (assertFailure "Hurl ran"))) trueCapabilities workspace (request & #suiteOptions . #reportDirectory .~ Just directory & #suiteOptions . #overwriteReports .~ True) + case result of + Left err -> assertBool "root failure" (all (\case SuiteFileRootFailed _ -> True; _ -> False) (err ^. #issues)) + Right _ -> assertFailure "suite accepted overlapping report root" + doesPathExist (directory "reads") >>= (@?= False), + testCase "parallel unsafe suites are refused before syntax, binding IO, service, or Hurl" $ do + workspace <- loadValidated "test/fixtures/workspaces/isolation/hurl-workbench.dhall" + let request name allowed manage = SuiteRequest (SuiteName name) Nothing Nothing emptyBindingInput defaultHurlOptions (SuiteOptions (positive 2) Nothing allowed manage Set.empty Nothing False) + forbidden _ _ = assertFailure "syntax validator called" + runner = HurlRunner (const (assertFailure "Hurl started")) + for_ [False, True] $ \allowed -> for_ [False, True] $ \manage -> do + for_ ["mixed", "single-write"] $ \name -> do + result <- runSuiteWith forbidden runner trueCapabilities workspace (request name allowed manage) + case result of + Left err -> do + let unsafe = [scenario | SuiteIsolationFailed (SharedStateParallelUnsafe scenario _) <- toList (err ^. #issues)] + unsafe @?= if name == "mixed" then ["dangerous-health", "writes/first", "writes/second", "health"] else ["dangerous-health"] + Right _ -> assertFailure "unsafe suite started" + for_ [1, 2] $ \jobs -> + runSuiteWith forbidden runner trueCapabilities workspace (request "independent" True False & #suiteOptions . #jobs .~ positive jobs) >>= \case + Left err -> toList (err ^. #issues) @?= [SuiteIsolationFailed IndependentStateHandoffRequired] + Right _ -> assertFailure "bare independent declaration started" + for_ [("reads", False, SuiteScenarioInputsUnexpected), ("independent", True, SuiteIndependentExternalRequired)] $ \(name, manage, issue) -> + runSuiteWith forbidden runner trueCapabilities workspace (request name True manage & #scenarioInputs .~ Just (ScenarioInputs [])) >>= \case + Left err -> toList (err ^. #issues) @?= [issue] + Right _ -> assertFailure "invalid isolation mode accepted" + for_ ["service-started", "readiness-started"] $ \marker -> + doesPathExist ("test/fixtures/workspaces/isolation" marker) >>= (@?= False), + testCase "parallel reads and serial authorized mutations remain supported" $ do + workspace <- loadValidated "test/fixtures/workspaces/isolation/hurl-workbench.dhall" + requests <- newTVarIO [] + let request name jobs allowed = SuiteRequest (SuiteName name) Nothing Nothing (emptyBindingInput {plainOverrides = Map.singleton (ParameterName "baseUrl") (literal "http://fixture.test")}) defaultHurlOptions (SuiteOptions (positive jobs) Nothing allowed False Set.empty Nothing False) + readResult <- runSuite (recordingRunner requests) trueCapabilities workspace (request "reads" 2 False) >>= requireSuite + readResult ^. #selectedExitCode @?= ExitSuccess + length <$> readTVarIO requests >>= (@?= 3) + write <- runSuite (recordingRunner requests) trueCapabilities workspace (request "single-write" 1 True) >>= requireSuite + write ^. #selectedExitCode @?= ExitSuccess + runSuite (recordingRunner requests) trueCapabilities workspace (request "single-write" 1 False) >>= \case + Left err -> assertBool "serial still requires opt-in" (any isUnsafe (err ^. #issues)) + Right _ -> assertFailure "unauthorized mutation started", + testCase "refusal and setup summaries contain logical cases and stable codes only" $ + withSystemTempDirectory "suite-preflight-summary" $ \directory -> do + workspace <- loadValidated "test/fixtures/workspaces/isolation/hurl-workbench.dhall" + let runner = HurlRunner (const (assertFailure "preflight started Hurl")) + request name root = SuiteRequest (SuiteName name) Nothing Nothing emptyBindingInput defaultHurlOptions (SuiteOptions (positive 2) Nothing True False Set.empty (Just root) False) + for_ [("mixed", "refused"), ("reads", "setup-failed")] $ \(name, status) -> do + let root = directory name + runSuiteWith (\_ _ -> pure (Right ())) runner trueCapabilities workspace (request (Text.pack name) root) >>= \case + Left _ -> pure () + Right _ -> assertFailure "preflight unexpectedly succeeded" + summary <- readJson (root name "summary.json") + field "status" summary @?= Aeson.String status + field "isolation" summary @?= Aeson.String "shared-state" + let cases = arrayValues (field "cases" summary) + assertBool "logical cases present" (not (null cases)) + for_ cases $ \logical -> do + field "status" logical @?= Aeson.String "not-started" + field "reports" logical @?= Aeson.toJSON ([] :: [Text]) + field "exitCode" logical @?= Aeson.Null + assertBool "scenario is explicit" (field "scenario" logical /= Aeson.Null), + testCase "unsafe report destinations and unknown suites preserve existing trees" $ + withSystemTempDirectory "suite-refusal-destination" $ \directory -> do + workspace <- loadValidated "test/fixtures/workspaces/isolation/hurl-workbench.dhall" + let outsideDirectory = directory "outside" + link = directory "link" + request name root = SuiteRequest (SuiteName name) Nothing Nothing emptyBindingInput defaultHurlOptions (SuiteOptions (positive 2) Nothing True False Set.empty (Just root) True) + runner = HurlRunner (const (assertFailure "unexpected execution")) + createDirectoryIfMissing True outsideDirectory + ByteString.writeFile (outsideDirectory "sentinel") "preserve" + createDirectoryLink outsideDirectory link + result <- runSuiteWith (\_ _ -> assertFailure "unexpected format") runner trueCapabilities workspace (request "mixed" (link "nested")) + case result of + Left err -> assertBool "symlink ancestor rejected" (any (\case SuiteReportPathIsSymbolicLink _ -> True; _ -> False) (err ^. #issues)) + Right _ -> assertFailure "unsafe destination accepted" + doesPathExist (outsideDirectory "nested") >>= (@?= False) + _ <- runSuite runner trueCapabilities workspace (request "unknown" outsideDirectory) + ByteString.readFile (outsideDirectory "sentinel") >>= (@?= "preserve") + doesPathExist (outsideDirectory "unknown") >>= (@?= False), + testCase "cancellation retains completed outcomes, joins workers, and propagates even if summary writing fails" $ + for_ [False, True] $ \breakSummary -> withSystemTempDirectory "suite-cancel-summary" $ \directory -> do + workspace <- loadValidated "test/fixtures/workspaces/isolation/hurl-workbench.dhall" + started <- newEmptyTMVarIO + blocked <- newEmptyTMVarIO + starts <- newTVarIO (0 :: Int) + active <- newTVarIO (0 :: Int) + let summaryPath = directory "reads" "summary.json" + literal_ = literal "private-plain-sentinel" + request = SuiteRequest (SuiteName "reads") Nothing Nothing (emptyBindingInput {plainOverrides = Map.singleton (ParameterName "baseUrl") literal_}) defaultHurlOptions (SuiteOptions (positive 1) Nothing False False Set.empty (Just directory) False) + runner = HurlRunner $ \_ -> do + ordinal <- atomically $ do + modifyTVar' starts (+ 1) + count <- readTVar starts + pure count + if ordinal == 1 + then pure (Right (RunResult ExitSuccess 0.01 (Just (CapturedRunOutput "private-captured-sentinel" "private-secret-sentinel")))) + else bracket_ + (atomically (modifyTVar' active (+ 1))) + (atomically (modifyTVar' active (subtract 1))) + $ do + when breakSummary (createDirectoryIfMissing True summaryPath) + atomically (putTMVar started ()) + _ <- atomically (takeTMVar blocked) + assertFailure "cancelled run resumed" + withAsync (runSuiteWith (\_ _ -> pure (Right ())) runner trueCapabilities workspace request) $ \worker -> do + atomically (takeTMVar started) + cancel worker + waitCatch worker >>= \case + Left err -> (fromException err :: Maybe AsyncCancelled) @?= Just AsyncCancelled + Right _ -> assertFailure "cancellation returned a SuiteResult" + readTVarIO active >>= (@?= 0) + readTVarIO starts >>= (@?= 2) + unless breakSummary $ do + raw <- ByteString.readFile summaryPath + for_ ["private-plain-sentinel", "private-captured-sentinel", "private-secret-sentinel"] $ \sentinel -> assertBool "summary redacted" (not (sentinel `ByteString.isInfixOf` raw)) + summary <- readJson summaryPath + field "status" summary @?= Aeson.String "cancelled" + let cases = arrayValues (field "cases" summary) + map (field "scenario") cases @?= map Aeson.String ["health-cases/first", "health-cases/second", "health-cases/third"] + map (field "status") cases @?= map Aeson.String ["passed", "cancelled", "cancelled"], + testCase "summary failure preserves a managed-service failure status" $ + withSystemTempDirectory "suite-service-summary-failure" $ \directory -> do + original <- failureWorkspace + let summaryPath = directory "failure" "summary.json" + context = validatedContext original + sabotage service = service & #command . #executable .~ "python3" & #command . #arguments .~ ["-c", "import os, sys; os.mkdir(sys.argv[1]); raise SystemExit(9)", Text.pack summaryPath] + workspace <- validateWorkspace (context & #workspace . #services %~ map sabotage) >>= either (assertFailure . show) pure + requests <- newTVarIO [] + let request = SuiteRequest (SuiteName "failure") Nothing Nothing emptyBindingInput defaultHurlOptions (SuiteOptions (positive 1) Nothing False True Set.empty (Just directory) False) + result <- runSuite (recordingRunner requests) trueCapabilities workspace request >>= requireSuite + result ^. #selectedExitCode @?= ExitFailure 4 + assertBool "summary failure retained" (isJust (result ^. #summaryError)) + readTVarIO requests >>= (@?= []), + testCase "missing managed environment skips Hurl; external service bypasses policy" $ do + original <- failureWorkspace + let context = validatedContext original + services = map (\service -> service & #command . #environmentPolicy .~ Clean ["HURL_WORKBENCH_TEST_ABSENT_972638"]) (validatedWorkspace original ^. #services) + workspace <- validateWorkspace (context & #workspace . #services .~ services) >>= either (assertFailure . show) pure + requests <- newTVarIO [] + let request = SuiteRequest (SuiteName "failure") Nothing Nothing emptyBindingInput defaultHurlOptions (SuiteOptions (positive 1) Nothing False True Set.empty Nothing False) + result <- runSuite (recordingRunner requests) trueCapabilities workspace request + case result of + Left err -> assertBool "missing environment rejected in preflight" (any (\case SuiteServiceResolutionFailed _ -> True; _ -> False) (err ^. #issues)) + Right _ -> assertFailure "missing managed environment accepted" + readTVarIO requests >>= (@?= []) + external <- runSuite (recordingRunner requests) trueCapabilities workspace (request & #suiteOptions . #manageService .~ False) >>= requireSuite + external ^. #selectedExitCode @?= ExitSuccess + length <$> readTVarIO requests >>= (@?= 1), + testCase "blocks unclassified runs before the managed service or Hurl starts" $ + withSystemTempDirectory "hurl-workbench-suite-gate" $ \directory -> do + ByteString.writeFile (directory "secrets.env") "client_secret=suite-secret\n" + workspace <- fullWorkspace + requests <- newTVarIO [] + result <- runSuite (recordingRunner requests) trueCapabilities workspace (fullSuiteRequest directory False True Set.empty Nothing False) + case result of + Left err -> + assertBool + "preflight identifies the unclassified workflow" + (any isUnsafe (toList (err ^. #issues))) + Right _ -> assertFailure "expected the suite safety gate to fail" + readTVarIO requests >>= (@?= []), + testCase "flattens runs, isolates reports, and writes a redacted atomic summary" $ + withSystemTempDirectory "hurl-workbench-suite-reports" $ \directory -> do + ByteString.writeFile (directory "secrets.env") "client_secret=suite-secret\n" + workspace <- fullWorkspace + requests <- newTVarIO [] + let reportRoot = directory "reports" + request = fullSuiteRequest directory True False (Set.fromList [JUnit, Json]) (Just reportRoot) False + result <- runSuite (recordingRunner requests) trueCapabilities workspace request >>= requireSuite + map (view #name) (toList (result ^. #cases)) + @?= ["list-members", "top-properties", "property-page-sizes/small", "property-page-sizes/large"] + result ^. #serviceOutcome @?= Nothing + result ^. #selectedExitCode @?= ExitSuccess + summary <- maybe (assertFailure "missing summary path") pure (result ^. #summaryPath) + rawSummary <- ByteString.readFile summary + assertBool "summary omits secret values" (not ("suite-secret" `ByteString.isInfixOf` rawSummary)) + assertBool "summary omits plain runtime values" (not ("suite-client" `ByteString.isInfixOf` rawSummary)) + assertBool "summary names relative report targets" ("property-page-sizes/small/junit.xml" `ByteString.isInfixOf` rawSummary) + observed <- readTVarIO requests + length observed @?= 4 + traverse_ assertTestRequest observed + traverse_ (traverse_ assertReportExists . requestReportPaths) observed + runSuite (recordingRunner requests) trueCapabilities workspace request >>= \case + Left err -> assertBool "existing suite report root is rejected" (any isExistingReport (toList (err ^. #issues))) + Right _ -> assertFailure "expected an existing report error" + overwritten <- runSuite (recordingRunner requests) trueCapabilities workspace (request & #suiteOptions . #overwriteReports .~ True) >>= requireSuite + overwritten ^. #selectedExitCode @?= ExitSuccess, + testCase "turns managed-service failure into exit 4 and prerequisite skips" $ do + workspace <- failureWorkspace + requests <- newTVarIO [] + let request = + SuiteRequest + { suiteName = SuiteName "failure", + fileRoot = Nothing, + scenarioInputs = Nothing, + bindingInput = emptyBindingInput, + hurlOptions = defaultHurlOptions, + suiteOptions = SuiteOptions (positive 1) Nothing False True Set.empty Nothing False + } + result <- runSuite (recordingRunner requests) trueCapabilities workspace request >>= requireSuite + result ^. #selectedExitCode @?= ExitFailure 4 + map (view #outcome) (toList (result ^. #cases)) @?= [CaseSkipped BatchPrerequisiteFailed] + case result ^. #serviceOutcome of + Just (ServiceFailed _) -> pure () + other -> assertFailure ("expected managed-service failure, got " <> show other) + readTVarIO requests >>= (@?= []) + ] + +fullSuiteRequest :: FilePath -> Bool -> Bool -> Set ReportFormat -> Maybe FilePath -> Bool -> SuiteRequest +fullSuiteRequest directory allowMutating manageService reportFormats reportDirectory overwriteReports = + SuiteRequest + { suiteName = SuiteName "smoke", + fileRoot = Nothing, + scenarioInputs = Nothing, + bindingInput = + emptyBindingInput + { plainOverrides = Map.singleton (ParameterName "client_id") (literal "suite-client"), + secretFiles = [directory "secrets.env"] + }, + hurlOptions = defaultHurlOptions, + suiteOptions = + SuiteOptions + { jobs = positive 1, + failFastOverride = Nothing, + allowMutating, + manageService, + reportFormats, + reportDirectory, + overwriteReports + } + } + +recordingRunner :: TVar [RunRequest] -> HurlRunner +recordingRunner requests = HurlRunner $ \request -> do + materializeReports request + atomically (modifyTVar' requests (request :)) + pure (Right (RunResult ExitSuccess 0.01 (Just (CapturedRunOutput "" "")))) + +materializeReports :: RunRequest -> IO () +materializeReports request = traverse_ create (request ^. #reportTargets) + where + create = \case + JUnitReport path -> ByteString.writeFile path "" + TapReport path -> ByteString.writeFile path "1..0\n" + HtmlReport path -> createDirectoryIfMissing True path >> ByteString.writeFile (path "index.html") "" + JsonReport path -> createDirectoryIfMissing True path >> ByteString.writeFile (path "report.json") "{}" + +requestReportPaths :: RunRequest -> [FilePath] +requestReportPaths request = map path (request ^. #reportTargets) + where + path = \case + JUnitReport value -> value + TapReport value -> value + HtmlReport value -> value + JsonReport value -> value + +assertTestRequest :: RunRequest -> IO () +assertTestRequest request = do + request ^. #mode @?= TestMode + length (request ^. #reportTargets) @?= 2 + +assertReportExists :: FilePath -> IO () +assertReportExists path = doesPathExist path >>= assertBool ("fake report target was not created: " <> path) + +requireSuite :: Either SuitePreflightError SuiteResult -> IO SuiteResult +requireSuite = either (assertFailure . Text.unpack . renderSuitePreflightError) pure + +isUnsafe :: SuitePreflightIssue -> Bool +isUnsafe SuiteUnsafeRun {} = True +isUnsafe _ = False + +isExistingReport :: SuitePreflightIssue -> Bool +isExistingReport SuiteReportPathExists {} = True +isExistingReport _ = False + +literal :: Text -> HurlValueLiteral +literal value = either (error . show) id (mkHurlValueLiteral value) + +positive :: Int -> PositiveInt +positive value = either (error . show) id (mkPositiveInt value) + +trueCapabilities :: HurlfmtCapabilities +trueCapabilities = HurlfmtCapabilities (HurlfmtExecutable "true") (makeVersion [8, 0, 1]) + +fullWorkspace :: IO ValidatedWorkspace +fullWorkspace = loadValidated "test/fixtures/workspaces/full/hurl-workbench.dhall" + +failureWorkspace :: IO ValidatedWorkspace +failureWorkspace = loadValidated "test/fixtures/workspaces/suite-failure/hurl-workbench.dhall" + +loadValidated :: FilePath -> IO ValidatedWorkspace +loadValidated path = do + loaded <- loadWorkspaceContext (ExplicitWorkspace path) + context <- either (assertFailure . Text.unpack . renderWorkspaceError) pure loaded + validateWorkspace context >>= either (assertFailure . Text.unpack . Text.unlines . map renderValidationIssue . toList) pure + +readJson :: FilePath -> IO Aeson.Value +readJson path = ByteString.readFile path >>= either assertFailure pure . Aeson.eitherDecodeStrict + +field :: Aeson.Key -> Aeson.Value -> Aeson.Value +field key (Aeson.Object object) = fromMaybe Aeson.Null (KeyMap.lookup key object) +field _ _ = Aeson.Null + +arrayValues :: Aeson.Value -> [Aeson.Value] +arrayValues (Aeson.Array values) = toList values +arrayValues _ = [] diff --git a/test/HurlWorkbench/Suite/ScenarioTest.hs b/test/HurlWorkbench/Suite/ScenarioTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Suite/ScenarioTest.hs @@ -0,0 +1,113 @@ +module HurlWorkbench.Suite.ScenarioTest (tests) where + +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import HurlWorkbench.Parameter.Resolve +import HurlWorkbench.Prelude +import HurlWorkbench.Run.Selection +import HurlWorkbench.Suite.Scenario +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Directory (createFileLink) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files (setFileMode) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "scenario handoff" + [ testCase "strict decoding never reveals malformed private input" $ do + for_ ["{private-endpoint", "{\"version\":1,\"scenarios\":[],\"private-secret\":1}", "{\"version\":1,\"scenarios\":[{\"scenario\":\"private-fixture\"}]}"] $ \bytes -> + decodeScenarioInputs bytes @?= Left ScenarioMalformedInput + decodeScenarioInputs "{\"version\":2,\"scenarios\":[]}" @?= Left ScenarioUnsupportedVersion + decodeScenarioInputs "{\"version\":1,\"scenarios\":[]}" @?= Right (ScenarioInputs []), + testCase "file loader requires a private regular file and rejects symlinks" $ + withSystemTempDirectory "scenario-file" $ \directory -> do + let path = directory "inputs.json" + ByteString.writeFile path "{\"version\":1,\"scenarios\":[]}" + setFileMode path 0o644 + loadScenarioInputs path >>= (@?= Left ScenarioFileNotPrivateRegular) + setFileMode path 0o600 + loadScenarioInputs path >>= (@?= Right (ScenarioInputs [])) + createFileLink path (directory "link") + loadScenarioInputs (directory "link") >>= (@?= Left ScenarioFileNotPrivateRegular) + loadScenarioInputs directory >>= (@?= Left ScenarioFileNotPrivateRegular) + loadScenarioInputs (directory "absent") >>= (@?= Left ScenarioFileUnreadable), + testCase "whole assignments reject incomplete, duplicate, invalid, and conflicting inputs" $ do + workspace <- loadValidated + runs <- either (assertFailure . show) (pure . toList) (resolveSelection workspace (SelectMatrix (MatrixName "writes"))) + let first_ = assignment "writes/first" "private-fixture-a" "http://EXAMPLE.test" + second_ = assignment "writes/second" "private-fixture-b" "http://other.test:81/" + check expected common entries = + verifyScenarioInputs workspace runs common (ScenarioInputs entries) >>= \case + Left err -> err @?= expected + Right _ -> assertFailure "invalid handoff verified" + verified <- verifyScenarioInputs workspace runs emptyBindingInput (ScenarioInputs [second_, first_]) >>= either (assertFailure . show) pure + assertBool "verified Show redacts runtime input" (not ("private" `Text.isInfixOf` Text.pack (show verified))) + assertBool "raw Show redacts runtime input" (not ("private" `Text.isInfixOf` Text.pack (show (ScenarioInputs [first_])))) + for_ runs $ \run -> do + input <- maybe (assertFailure "missing assigned input") pure (scenarioBindingInput verified run) + Map.keys (input ^. #plainOverrides) @?= [ParameterName "baseUrl"] + check ScenarioAssignmentMismatch emptyBindingInput [first_] + check ScenarioAssignmentMismatch emptyBindingInput [first_, first_] + check ScenarioAssignmentMismatch emptyBindingInput [first_, second_ & #scenario .~ "writes/extra"] + check ScenarioInvalidLabel emptyBindingInput [first_ & #scenario .~ "../private", second_] + check ScenarioDuplicateFixture emptyBindingInput [first_, second_ & #fixtureId .~ "private-fixture-a"] + check ScenarioInvalidFixture emptyBindingInput [first_ & #fixtureId .~ "private\nfixture", second_] + for_ ["http://example.TEST:80/", "HTTP://EXAMPLE.TEST", "http://example.test:080/"] $ \endpoint -> + check ScenarioDuplicateEndpoint emptyBindingInput [first_, second_ & #endpoint .~ endpoint] + for_ ["ftp://private.test", "http://private.test/path", "http://user:private@host", "http://private.test/?secret", "http://private.test/#fragment", "http://private.test:99999", "http://private.test/ "] $ \endpoint -> + check ScenarioInvalidEndpoint emptyBindingInput [first_ & #endpoint .~ endpoint, second_] + check ScenarioDuplicateParameter emptyBindingInput [first_ & #bindings .~ [ScenarioBinding (ParameterName "baseUrl") "private-value"], second_] + check ScenarioInvalidParameter emptyBindingInput [first_ & #endpointParameter .~ ParameterName "undeclared", second_] + check ScenarioDuplicateParameter emptyBindingInput [first_ & #secretEnvironment .~ [ScenarioSecret (ParameterName "baseUrl") "PRIVATE_ENV"], second_] + let literal = either (error . show) id (mkHurlValueLiteral "private-override") + check ScenarioConflictingBinding (emptyBindingInput {plainOverrides = Map.singleton (ParameterName "baseUrl") literal}) [first_, second_] + withSystemTempDirectory "scenario-conflict" $ \directory -> do + let file = directory "variables" + ByteString.writeFile file "baseUrl=private-file-value\n" + check ScenarioConflictingBinding (emptyBindingInput {variableFiles = [file]}) [first_, second_] + check ScenarioConflictingBinding (emptyBindingInput {secretFiles = [file]}) [first_, second_], + testCase "handoff conflicts with committed layers and enforces workflow parameter kinds" $ do + loaded <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/full/hurl-workbench.dhall") + context <- either (assertFailure . show) pure loaded + workspace <- validateWorkspace context >>= either (assertFailure . show) pure + runs <- either (assertFailure . show) (pure . toList) (resolveSelection workspace (SelectMatrix (MatrixName "property-page-sizes"))) + let inputs binding = + ScenarioInputs + [ (assignment (run ^. #artifactStem) (Text.pack (show ordinal)) ("https://fixture" <> Text.pack (show ordinal) <> ".test")) + { endpointParameter = ParameterName "base_url", + bindings = [binding] + } + | (ordinal, run) <- zip [1 :: Int ..] runs + ] + check expected raw = + verifyScenarioInputs workspace runs emptyBindingInput raw >>= \case + Left issue -> issue @?= expected + Right _ -> assertFailure "invalid provider binding accepted" + check ScenarioConflictingBinding (inputs (ScenarioBinding (ParameterName "top") "private-generated-value")) + check ScenarioInvalidParameter (inputs (ScenarioBinding (ParameterName "client_secret") "private-plain-secret")) + check ScenarioRuntimeInputFailed (inputs (ScenarioBinding (ParameterName "client_id") " private-invalid-literal ")) + let ScenarioInputs valid = inputs (ScenarioBinding (ParameterName "client_id") "private-generated-client") + verifyScenarioInputs workspace runs emptyBindingInput (ScenarioInputs valid) >>= \case + Left issue -> assertFailure (show issue) + Right verified -> for_ runs $ \run -> do + input <- maybe (assertFailure "missing assignment") pure (scenarioBindingInput verified run) + assertBool "provider overrides declared endpoint fallback" (Map.member (ParameterName "base_url") (input ^. #plainOverrides)) + ] + +assignment :: FilePath -> Text -> Text -> ScenarioAssignment +assignment scenario fixtureId endpoint = ScenarioAssignment scenario fixtureId endpoint (ParameterName "baseUrl") [] [] + +loadValidated :: IO ValidatedWorkspace +loadValidated = do + loaded <- loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/isolation/hurl-workbench.dhall") + context <- either (assertFailure . show) pure loaded + validateWorkspace context >>= either (assertFailure . show) pure diff --git a/test/HurlWorkbench/Workflow/WorkflowTest.hs b/test/HurlWorkbench/Workflow/WorkflowTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Workflow/WorkflowTest.hs @@ -0,0 +1,244 @@ +module HurlWorkbench.Workflow.WorkflowTest (tests) where + +import Data.ByteString qualified as ByteString +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Text.IO qualified as Text.IO +import Data.Version (makeVersion) +import HurlWorkbench.Hurl.Format +import HurlWorkbench.Prelude +import HurlWorkbench.Workflow.Render +import HurlWorkbench.Workflow.Resolve +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Discover (WorkspaceSource (..)) +import HurlWorkbench.Workspace.Error (renderWorkspaceError) +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Directory + ( canonicalizePath, + doesFileExist, + getPermissions, + removeFile, + setOwnerExecutable, + setPermissions, + ) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "workflow" + [ resolutionTests, + renderingTests, + hurlfmtTests + ] + +resolutionTests :: TestTree +resolutionTests = + testGroup + "resolution" + [ testCase "resolves declared fragments in workflow order" $ + withSystemTempDirectory "hurl-workbench-resolve" $ \dir -> do + validated <- makeWorkspace dir [("first", "first.hurl", "GET https://first.test"), ("second", "second.hurl", "GET https://second.test")] [("ordered", ["second", "first"])] + case resolveWorkflow validated (WorkflowName "ordered") of + Left err -> assertFailure (Text.unpack (renderWorkflowError err)) + Right resolved -> + map (view (#fragment . #name)) (NonEmpty.toList (resolved ^. #sourceFragments)) + @?= [FragmentName "second", FragmentName "first"], + testCase "reports an unknown workflow without a partial lookup" $ + withSystemTempDirectory "hurl-workbench-resolve" $ \dir -> do + validated <- makeWorkspace dir [("one", "one.hurl", "GET https://one.test")] [("known", ["one"])] + resolveWorkflow validated (WorkflowName "missing") @?= Left (WorkflowNotFound (WorkflowName "missing")) + ] + +renderingTests :: TestTree +renderingTests = + testGroup + "rendering" + [ testCase "preserves bytes and inserts only required line feeds" $ + withSystemTempDirectory "hurl-workbench-render" $ \dir -> do + let first = Text.Encoding.encodeUtf8 "GET https://first.test\r\n# café" + second = "POST https://second.test\n" + third = "PUT https://third.test\n\n" + fourth = "DELETE https://fourth.test" + validated <- + makeWorkspace + dir + [("first", "first.hurl", first), ("second", "second.hurl", second), ("third", "third.hurl", third), ("fourth", "fourth.hurl", fourth)] + [("flow", ["first", "second", "third", "fourth"])] + rendered <- renderNamed validated "flow" + rendered ^. #contents + @?= Text.Encoding.decodeUtf8 first + <> "\n\n" + <> Text.Encoding.decodeUtf8 second + <> "\n" + <> Text.Encoding.decodeUtf8 third + <> Text.Encoding.decodeUtf8 fourth + <> "\n" + map (\span_ -> (span_ ^. #fragmentName, span_ ^. #firstLine, span_ ^. #lastLine)) (NonEmpty.toList (rendered ^. #fragmentSpans)) + @?= [ (FragmentName "first", 1, 2), + (FragmentName "second", 4, 4), + (FragmentName "third", 6, 7), + (FragmentName "fourth", 8, 8) + ], + testCase "keeps capture and use entries ordered with placeholders unresolved" $ do + validated <- fullFixture + rendered <- renderNamed validated "list-properties" + let output = rendered ^. #contents + (_beforeCapture, fromCapture) = Text.breakOn "access_token: jsonpath" output + (_beforeUse, fromUse) = Text.breakOn "Authorization: Bearer {{access_token}}" output + assertBool "contains the OAuth capture" (not (Text.null fromCapture)) + assertBool "contains the unresolved use" (not (Text.null fromUse)) + assertBool "capture precedes use" (Text.length fromCapture > Text.length fromUse), + testCase "rejects an empty fragment" $ + withSystemTempDirectory "hurl-workbench-render" $ \dir -> do + validated <- makeWorkspace dir [("empty", "empty.hurl", "")] [("flow", ["empty"])] + resolved <- resolveNamed validated "flow" + renderWorkflow resolved >>= \case + Left (EmptyFragment (FragmentName "empty") _) -> pure () + other -> assertFailure ("expected EmptyFragment, got " <> show other), + testCase "reports the invalid UTF-8 byte offset" $ + withSystemTempDirectory "hurl-workbench-render" $ \dir -> do + validated <- makeWorkspace dir [("bad", "bad.hurl", ByteString.pack [0x47, 0x45, 0xFF, 0x54])] [("flow", ["bad"])] + resolved <- resolveNamed validated "flow" + renderWorkflow resolved >>= \case + Left (InvalidFragmentUtf8 (FragmentName "bad") _ 2 _) -> pure () + other -> assertFailure ("expected byte offset 2, got " <> show other), + testCase "turns a post-validation filesystem change into a render error" $ + withSystemTempDirectory "hurl-workbench-render" $ \dir -> do + validated <- makeWorkspace dir [("gone", "gone.hurl", "GET https://gone.test")] [("flow", ["gone"])] + resolved <- resolveNamed validated "flow" + removeFile (dir "gone.hurl") + renderWorkflow resolved >>= \case + Left (FragmentReadFailed (FragmentName "gone") _ _) -> pure () + other -> assertFailure ("expected FragmentReadFailed, got " <> show other) + ] + +hurlfmtTests :: TestTree +hurlfmtTests = + testGroup + "hurlfmt" + [ testCase "parses the released Hurlfmt version format" $ do + parseHurlfmtVersion "hurlfmt 8.0.1" @?= Just (makeVersion [8, 0, 1]) + parseHurlfmtVersion "not a version" @?= Nothing, + testCase "maps a Hurlfmt line diagnostic to its source fragment and cleans the temporary file" $ + withSystemTempDirectory "hurl-workbench-format" $ \dir -> do + validated <- makeWorkspace dir [("broken", "broken.hurl", "GET https://example.test\n[Asserts")] [("flow", ["broken"])] + rendered <- renderNamed validated "flow" + executable <- writeFailingHurlfmt dir + let capabilities = HurlfmtCapabilities (HurlfmtExecutable executable) (makeVersion [8, 0, 1]) + validateRenderedWorkflow capabilities rendered >>= \case + Left (InvalidHurl (WorkflowName "flow") (Just span_) diagnostics) -> do + span_ ^. #fragmentName @?= FragmentName "broken" + assertBool "keeps Hurlfmt diagnostics" ("expecting" `Text.isInfixOf` diagnostics) + other -> assertFailure ("expected mapped InvalidHurl, got " <> show other) + temporaryPath <- Text.unpack . Text.strip <$> Text.IO.readFile (executable <> ".called") + remains <- doesFileExist temporaryPath + assertBool "temporary Hurl source was removed" (not remains), + testCase "validates every workflow in stable name order" $ + withSystemTempDirectory "hurl-workbench-format" $ \dir -> do + validated <- + makeWorkspace + dir + [("broken", "broken.hurl", "GET https://example.test\n[Asserts")] + [("zeta", ["broken"]), ("alpha", ["broken"])] + executable <- writeFailingHurlfmt dir + let capabilities = HurlfmtCapabilities (HurlfmtExecutable executable) (makeVersion [8, 0, 1]) + validateWorkspaceSyntax capabilities validated >>= \case + Right issues -> map syntaxWorkflowName issues @?= [Just (WorkflowName "alpha"), Just (WorkflowName "zeta")] + Left err -> assertFailure (Text.unpack (renderDependencyError err)), + testCase "reports an executable that disappears after detection" $ + withSystemTempDirectory "hurl-workbench-format" $ \dir -> do + validated <- makeWorkspace dir [("one", "one.hurl", "GET https://one.test")] [("flow", ["one"])] + rendered <- renderNamed validated "flow" + let missing = dir "missing-hurlfmt" + validateRenderedWorkflow (HurlfmtCapabilities (HurlfmtExecutable missing) (makeVersion [8, 0, 1])) rendered + >>= (@?= Left (HurlfmtNotFound missing)) + ] + +syntaxWorkflowName :: WorkflowSyntaxError -> Maybe WorkflowName +syntaxWorkflowName = \case + SyntaxFormatFailed (InvalidHurl name _span _diagnostics) -> Just name + SyntaxRenderFailed name _err -> Just name + SyntaxResolutionFailed _err -> Nothing + SyntaxFormatFailed _err -> Nothing + +makeWorkspace :: FilePath -> [(Text, FilePath, ByteString.ByteString)] -> [(Text, [Text])] -> IO ValidatedWorkspace +makeWorkspace directory fragmentInputs workflowInputs = do + canonicalRoot <- canonicalizePath directory + for_ fragmentInputs $ \(_name, path, bytes) -> ByteString.writeFile (canonicalRoot path) bytes + let decoded = + Workspace + { schemaVersion = supportedSchemaVersion, + parameters = [], + fragments = [Fragment (FragmentName name) path Nothing | (name, path, _bytes) <- fragmentInputs], + workflows = + [ Workflow + { name = WorkflowName name, + fragments = map FragmentName fragmentNames, + parameters = [], + description = Nothing + } + | (name, fragmentNames) <- workflowInputs + ], + recipes = [], + matrices = [], + checks = [], + services = [], + suites = [] + } + context = + WorkspaceContext + { manifestPath = canonicalRoot "hurl-workbench.dhall", + workspaceRoot = WorkspaceRoot canonicalRoot, + workspace = decoded + } + validateWorkspace context >>= \case + Left issues -> assertFailure (Text.unpack (Text.unlines (map renderValidationIssue (toList issues)))) + Right validated -> pure validated + +resolveNamed :: ValidatedWorkspace -> Text -> IO ResolvedWorkflow +resolveNamed validated name = + case resolveWorkflow validated (WorkflowName name) of + Left err -> assertFailure (Text.unpack (renderWorkflowError err)) + Right resolved -> pure resolved + +renderNamed :: ValidatedWorkspace -> Text -> IO RenderedWorkflow +renderNamed validated name = do + resolved <- resolveNamed validated name + renderWorkflow resolved >>= \case + Left err -> assertFailure (Text.unpack (renderRenderError err)) + Right rendered -> pure rendered + +fullFixture :: IO ValidatedWorkspace +fullFixture = do + context <- + loadWorkspaceContext (ExplicitWorkspace "test/fixtures/workspaces/full/hurl-workbench.dhall") >>= \case + Left err -> assertFailure (Text.unpack (renderWorkspaceError err)) + Right loaded -> pure loaded + validateWorkspace context >>= \case + Left issues -> assertFailure (Text.unpack (Text.unlines (map renderValidationIssue (toList issues)))) + Right validated -> pure validated + +writeFailingHurlfmt :: FilePath -> IO FilePath +writeFailingHurlfmt directory = do + let executable = directory "hurlfmt-failure" + Text.IO.writeFile + executable + ( Text.unlines + [ "#!/bin/sh", + "last=''", + "for arg in \"$@\"; do last=\"$arg\"; done", + "printf '%s\\n' \"$last\" > \"$0.called\"", + "printf 'error: Parsing JSON\\n --> %s:2:3\\n |\\n 2 | [Asserts\\n | ^ expecting a closing bracket\\n' \"$last\" >&2", + "exit 1" + ] + ) + permissions <- getPermissions executable + setPermissions executable (setOwnerExecutable True permissions) + pure executable diff --git a/test/HurlWorkbench/Workspace/NameSafetyTest.hs b/test/HurlWorkbench/Workspace/NameSafetyTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Workspace/NameSafetyTest.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} + +-- | Compile-time name safety, checked at run time: this module is compiled +-- with deferred type errors, so each ill-typed top-level binding below +-- compiles into a 'TypeError' exception. Each test forces one binding and +-- expects that exception, proving that category-specific names cannot be +-- interchanged. Each binding must stay top-level: GHC floats deferred-error +-- evidence to the enclosing binding, so an inline expression would throw +-- before the surrounding 'try' runs. +module HurlWorkbench.Workspace.NameSafetyTest (tests) where + +import Control.Exception (TypeError (..), evaluate, try) +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "category-specific names" + [ testCase "a recipe name is not a workflow name" (expectTypeError recipeAsWorkflow), + testCase "a workflow name is not a fragment name" (expectTypeError workflowAsFragment), + testCase "a matrix name is not a suite name" (expectTypeError matrixAsSuite), + testCase "plain text is not a parameter name" (expectTypeError textAsParameter) + ] + +recipeAsWorkflow :: ValidatedWorkspace -> Maybe Workflow +recipeAsWorkflow = lookupWorkflow (RecipeName "top-properties") + +workflowAsFragment :: ValidatedWorkspace -> Maybe Fragment +workflowAsFragment = lookupFragment (WorkflowName "list-properties") + +matrixAsSuite :: ValidatedWorkspace -> Maybe Suite +matrixAsSuite = lookupSuite (MatrixName "grid") + +textAsParameter :: ValidatedWorkspace -> Maybe Parameter +textAsParameter = lookupParameter ("base_url" :: Text) + +expectTypeError :: a -> IO () +expectTypeError value = do + result <- try (evaluate value) + case result of + Left (TypeError _) -> pure () + Right _ -> assertFailure "expected the expression to be rejected by the type checker" diff --git a/test/HurlWorkbench/Workspace/WorkspaceTest.hs b/test/HurlWorkbench/Workspace/WorkspaceTest.hs new file mode 100644 --- /dev/null +++ b/test/HurlWorkbench/Workspace/WorkspaceTest.hs @@ -0,0 +1,323 @@ +module HurlWorkbench.Workspace.WorkspaceTest (tests) where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.IO qualified as Text.IO +import HurlWorkbench.Prelude +import HurlWorkbench.Workspace.Context +import HurlWorkbench.Workspace.Decode +import HurlWorkbench.Workspace.Discover +import HurlWorkbench.Workspace.Error +import HurlWorkbench.Workspace.Types +import HurlWorkbench.Workspace.Validate +import System.Directory (canonicalizePath, createDirectoryIfMissing, createFileLink) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "workspace" + [ decodingTests, + discoveryTests, + validationTests, + literalTests + ] + +fixture :: FilePath -> FilePath +fixture name = "test/fixtures/workspaces" name "hurl-workbench.dhall" + +-------------------------------------------------------------------------------- +-- Decoding + +decodingTests :: TestTree +decodingTests = + testGroup + "decoding" + [ testCase "frozen old service suites normalize additive fields and run unions" $ do + ws <- decodeOrFail (fixture "old-service-suite") + map suiteServices (ws ^. #suites) @?= [[ServiceName "old"]] + map (view #setup) (ws ^. #suites) @?= [[]] + map (view #commandTimeoutSeconds) (ws ^. #suites) @?= [60], + testCase "frozen populated old suites default to shared state" $ do + old <- decodeOrFail (fixture "old-suite") + shared <- decodeOrFail (fixture "shared-suite") + old @?= shared + map (view #isolation) (old ^. #suites) @?= [SharedState] + independent <- decodeOrFail (fixture "independent-suite") + independent @?= (shared & #suites .~ map (\suite -> suite & #isolation .~ IndependentState) (shared ^. #suites)), + testCase "invalid isolation values fail typed decode" $ + withSystemTempDirectory "hurl-isolation" $ \dir -> do + schema <- canonicalizePath schemaPackage + for_ ["42", "< Wrong >.Wrong"] $ \policy -> do + let manifest = dir manifestFileName + Text.IO.writeFile manifest ("let S = " <> Text.pack schema <> " in S.Workspace::{ schemaVersion = 1, suites = [{ name = \"bad\", runs = [] : List S.RunReference, service = None Text, failFast = False, description = None Text, isolation = " <> policy <> " }] }") + decodeWorkspaceFile manifest >>= \case + Left DhallFailure {} -> pure () + other -> assertFailure ("expected invalid policy, got " <> show other), + policyDecodingTests, + testCase "frozen old service and readiness records inherit" $ + for_ ["old-command", "old-http"] $ \name -> do + ws <- decodeOrFail (fixture name) + map (view (#command . #environmentPolicy)) (ws ^. #services) @?= [Inherit], + testCase "completion-based and fully specified manifests decode identically" $ do + completed <- decodeOrFail (fixture "minimal") + explicit <- decodeOrFail (fixture "minimal-explicit") + completed @?= explicit + completed ^. #schemaVersion @?= 1 + map (view #defaultValue) (completed ^. #parameters) + @?= [Just (literal "https://api.example.test")], + testCase "a manifest may import sibling Dhall modules" $ do + ws <- decodeOrFail (fixture "full") + map (unParameterName . view #name) (ws ^. #parameters) + @?= ["auth_url", "base_url", "client_id", "client_secret", "top"], + testCase "an unsupported schema version is reported before typed decoding" $ do + path <- canonicalizePath (fixture "schema-version") + result <- decodeWorkspaceFile path + result @?= Left (UnsupportedSchemaVersion path 2 1), + testCase "a Dhall type error is reported with the manifest path" $ + withSystemTempDirectory "hurl-workbench" $ \dir -> do + let manifest = dir manifestFileName + Text.IO.writeFile manifest "{ schemaVersion = 1, fragments = 42 }" + result <- decodeWorkspaceFile manifest + case result of + Left (DhallFailure path message) -> do + path @?= manifest + assertBool "mentions the mismatch" ("doesn't match annotation" `Text.isInfixOf` message) + assertBool "contains no ANSI escapes" (not ("\ESC" `Text.isInfixOf` message)) + other -> assertFailure ("expected a Dhall failure, got " <> show other) + ] + +decodeOrFail :: FilePath -> IO Workspace +decodeOrFail path = + decodeWorkspaceFile path >>= \case + Right ws -> pure ws + Left err -> assertFailure (Text.unpack (renderWorkspaceError err)) + +literal :: Text -> HurlValueLiteral +literal value = either (error . show) id (mkHurlValueLiteral value) + +-------------------------------------------------------------------------------- +-- Discovery + +discoveryTests :: TestTree +discoveryTests = + testGroup + "discovery" + [ testCase "finds the manifest from a nested child directory" $ + withSystemTempDirectory "hurl-workbench" $ \dir -> do + writeManifest dir [] + let nested = dir "a" "b" "c" + createDirectoryIfMissing True nested + result <- discoverWorkspace Nothing nested + result @?= Right (DiscoveredWorkspace (dir manifestFileName)), + testCase "an explicit manifest wins over discovery" $ + withSystemTempDirectory "hurl-workbench" $ \dir -> do + writeManifest dir [] + let other = dir "other" + createDirectoryIfMissing True other + writeManifest other [] + result <- discoverWorkspace (Just ("other" manifestFileName)) dir + result @?= Right (ExplicitWorkspace (other manifestFileName)), + testCase "a missing explicit manifest is an error, even when discovery would succeed" $ + withSystemTempDirectory "hurl-workbench" $ \dir -> do + writeManifest dir [] + result <- discoverWorkspace (Just "missing.dhall") dir + result @?= Left (ManifestNotFound (dir "missing.dhall")), + testCase "discovery stops at the filesystem root" $ + withSystemTempDirectory "hurl-workbench" $ \dir -> do + result <- discoverWorkspace Nothing dir + result @?= Left (NoWorkspaceFound dir) + ] + +-- | Write a manifest with the given @(name, path)@ fragments, importing the +-- repository schema by absolute path. +writeManifest :: FilePath -> [(Text, Text)] -> IO () +writeManifest dir fragmentList = do + schema <- canonicalizePath schemaPackage + writeManifestWithSchema schema dir fragmentList + +-- | The repository schema, relative to the package directory in which +-- @cabal test@ runs. +schemaPackage :: FilePath +schemaPackage = "schema/package.dhall" + +-------------------------------------------------------------------------------- +-- Validation + +validationTests :: TestTree +validationTests = + testGroup + "validation" + [ testCase "independent suites cannot declare a shared service" $ do + original <- validFixture "full" + let context = validatedContext original + suites = map (\suite -> suite & #isolation .~ IndependentState) (validatedWorkspace original ^. #suites) + validateWorkspace (context & #workspace . #suites .~ suites) >>= \case + Left issues -> assertBool "service rejected" (any (Text.isInfixOf "cannot declare a shared managed service" . view #message) issues) + Right _ -> assertFailure "expected invalid independent managed suite", + testCase "a complete workspace validates and offers typed lookups" $ do + vw <- validFixture "full" + Map.keys (validatedWorkflows vw) @?= [WorkflowName "list-members", WorkflowName "list-properties"] + let fragmentsOf name = maybe [] (view #fragments) (lookupWorkflow (WorkflowName name) vw) + -- One OAuth fragment is shared by both resource workflows. + take 1 (fragmentsOf "list-properties") @?= [FragmentName "oauth"] + take 1 (fragmentsOf "list-members") @?= [FragmentName "oauth"] + fmap (view #safety) (lookupRecipe (RecipeName "top-properties") vw) @?= Just ReadOnly + fmap (length . view #cases) (lookupMatrix (MatrixName "property-page-sizes") vw) @?= Just 2 + fmap (view #service) (lookupSuite (SuiteName "smoke") vw) @?= Just (Just (ServiceName "api")) + root <- canonicalizePath "test/fixtures/workspaces/full" + validatedRoot vw @?= WorkspaceRoot root + lookupFragmentFile (FragmentName "oauth") vw @?= Just (root "hurl/oauth.hurl"), + testCase "every unresolved reference is reported together, in stable order" $ do + issues <- invalidFixture "missing-reference" + issues + @?= [ ValidationIssue "workflows/empty/fragments" "workflow must list at least one fragment", + ValidationIssue "workflows/flow/fragments" "unknown fragment \"missing-fragment\"", + ValidationIssue "workflows/flow/parameters" "unknown parameter \"missing_parameter\"", + ValidationIssue "recipes/orphan/workflow" "unknown workflow \"missing-workflow\"", + ValidationIssue "matrices/grid/recipe" "unknown recipe \"missing-recipe\"", + ValidationIssue "matrices/grid/cases" "matrix must have at least one case", + ValidationIssue "suites/all/runs" "unknown matrix \"missing-matrix\"", + ValidationIssue "suites/all/service" "unknown service \"missing-service\"" + ] + again <- invalidFixture "missing-reference" + again @?= issues, + testCase "duplicate and malformed names are reported" $ do + issues <- invalidFixture "duplicate" + map (view #location) issues @?= ["fragments/a", "workflows/9-bad name", "workflows/flow"] + assertMentions issues "duplicate fragment name declared 2 times" + assertMentions issues "duplicate workflow name declared 2 times", + testCase "unsafe fragment paths are rejected" $ do + issues <- invalidFixture "escaping-path" + issues + @?= [ ValidationIssue "fragments/absolute/path" "path \"/etc/hosts\" must be relative to the workspace root", + ValidationIssue "fragments/missing/path" "path \"hurl/missing.hurl\" does not exist as a regular file", + ValidationIssue "fragments/not-hurl/path" "fragment path \"outside-notes.txt\" must end in .hurl", + ValidationIssue "fragments/parent/path" "path \"../minimal/hurl/health.hurl\" escapes the workspace root" + ], + testCase "a symlink that leaves the workspace is rejected" $ + withSystemTempDirectory "hurl-workbench" $ \dir -> do + let workspaceDir = dir "workspace" + createDirectoryIfMissing True (workspaceDir "hurl") + Text.IO.writeFile (dir "outside.hurl") "GET https://example.test\n" + Text.IO.writeFile (workspaceDir "hurl" "inside.hurl") "GET https://example.test\n" + createFileLink (dir "outside.hurl") (workspaceDir "hurl" "escape.hurl") + createFileLink (workspaceDir "hurl" "inside.hurl") (workspaceDir "hurl" "alias.hurl") + writeManifest workspaceDir [("escape", "hurl/escape.hurl"), ("alias", "hurl/alias.hurl")] + issues <- invalidManifest (workspaceDir manifestFileName) + issues @?= [ValidationIssue "fragments/escape/path" "path \"hurl/escape.hurl\" escapes the workspace root"], + testCase "a secret with a committed default is rejected" $ do + issues <- invalidFixture "secret-default" + issues @?= [ValidationIssue "parameters/api_key" "secret parameters must not have a committed defaultValue"], + testCase "values that Hurl variable files cannot carry are rejected with their location" $ do + issues <- invalidFixture "invalid-value" + map (view #location) issues + @?= ["parameters/multiline/defaultValue", "parameters/newUuid", "parameters/padded/defaultValue"] + ] + where + assertMentions issues needle = + assertBool + ("expected an issue mentioning " <> Text.unpack needle) + (any (Text.isInfixOf needle . view #message) issues) + +writeManifestWithSchema :: FilePath -> FilePath -> [(Text, Text)] -> IO () +writeManifestWithSchema schema dir fragmentList = + Text.IO.writeFile (dir manifestFileName) $ + Text.unlines + [ "let Schema = " <> Text.pack schema, + "in Schema.Workspace::{ schemaVersion = 1, fragments = [" + <> Text.intercalate ", " [fragmentLiteral name path | (name, path) <- fragmentList] + <> "] : List Schema.Fragment.Type }" + ] + where + fragmentLiteral name path = "Schema.Fragment::{ name = \"" <> name <> "\", path = \"" <> path <> "\" }" + +loadManifest :: FilePath -> IO (Either (NonEmpty ValidationIssue) ValidatedWorkspace) +loadManifest manifest = do + context <- + discoverWorkspace (Just manifest) "." >>= \case + Left err -> assertFailure (Text.unpack (renderWorkspaceError err)) + Right source -> + loadWorkspaceContext source >>= \case + Left err -> assertFailure (Text.unpack (renderWorkspaceError err)) + Right ctx -> pure ctx + validateWorkspace context + +validFixture :: FilePath -> IO ValidatedWorkspace +validFixture name = + loadManifest (fixture name) >>= \case + Right vw -> pure vw + Left issues -> assertFailure (Text.unpack (Text.unlines (map renderValidationIssue (toList issues)))) + +invalidFixture :: FilePath -> IO [ValidationIssue] +invalidFixture = invalidManifest . fixture + +invalidManifest :: FilePath -> IO [ValidationIssue] +invalidManifest manifest = + loadManifest manifest >>= \case + Right _ -> assertFailure "expected validation to fail" + Left issues -> pure (toList issues) + +-------------------------------------------------------------------------------- +-- Hurl value literals + +literalTests :: TestTree +literalTests = + testGroup + "HurlValueLiteral" + [ testCase "accepts values Hurl reads back unchanged" $ + for_ ["", "true", "null", "42", "3.5", "a=b", "has inner space", "\"quoted\""] $ \value -> + fmap hurlValueLiteralText (mkHurlValueLiteral value) @?= Right value, + testCase "rejects line breaks and NUL" $ + for_ ["a\nb", "a\rb", "a\0b"] $ \value -> + mkHurlValueLiteral value @?= Left ContainsLineBreakOrNul, + testCase "rejects surrounding whitespace that Hurl trims" $ + for_ [" a", "a ", "\ta", "a\x2028", "\x85"] $ \value -> + mkHurlValueLiteral value @?= Left SurroundingWhitespace + ] + +policyDecodingTests :: TestTree +policyDecodingTests = + testGroup + "command policies" + [ testCase "default, explicit inheritance, and empty clean policies" $ + withSystemTempDirectory "policy-decode" $ \dir -> do + for_ [("", Inherit), (", environmentPolicy = Schema.EnvironmentPolicy.Inherit", Inherit), (", environmentPolicy = Schema.EnvironmentPolicy.Clean ([] : List Text)", Clean [])] $ \(field, expected) -> do + writePolicyManifest dir field + ws <- decodeOrFail (dir manifestFileName) + map (view (#command . #environmentPolicy)) (ws ^. #services) @?= [expected], + testCase "malformed policy types fail decoding" $ + withSystemTempDirectory "policy-malformed" $ \dir -> do + for_ ["42", "< Inherit | Clean : Text >.Clean \"PATH\""] $ \value -> do + writePolicyManifest dir (", environmentPolicy = " <> value) + decodeWorkspaceFile (dir manifestFileName) >>= \case + Left (DhallFailure _ _) -> pure () + other -> assertFailure (show other), + testCase "invalid and duplicate inherited names reject deterministically in both commands" $ + withSystemTempDirectory "policy-validation" $ \dir -> do + writePolicyManifest dir ", environmentPolicy = Schema.EnvironmentPolicy.Clean [ \"\", \"9BAD\", \"A=B\", \"A B\", \"PATH\", \"PATH\" ]" + loaded <- loadWorkspaceContext (ExplicitWorkspace (dir manifestFileName)) >>= either (assertFailure . show) pure + let extraNames = Clean ["A\NULB", "A\nB", "A\tB"] + withExtra = loaded & #workspace . #services %~ map (\service -> service & #command . #environmentPolicy .~ extraNames) + validateWorkspace withExtra >>= \case + Left issues -> assertBool "NUL and whitespace rejected" (length (toList issues) >= 3) + Right _ -> assertFailure "expected invalid control characters" + first <- validateWorkspace loaded + second <- validateWorkspace loaded + case (first, second) of + (Left issues, Left again) -> do + issues @?= again + length (toList issues) @?= 10 + assertBool "readiness locations present" (any (Text.isInfixOf "/readiness/command/environmentPolicy" . view #location) (toList issues)) + _ -> assertFailure "expected static policy errors" + ] + +writePolicyManifest :: FilePath -> Text -> IO () +writePolicyManifest dir policyField = do + schema <- canonicalizePath schemaPackage + Text.IO.writeFile (dir manifestFileName) $ + "let Schema = " <> Text.pack schema <> " let command = Schema.CommandSpec::{ executable = \"/usr/bin/true\" " <> policyField <> " } in Schema.Workspace::{ schemaVersion = 1, services = [ Schema.Service::{ name = \"policy\", command = command, readiness = Schema.Readiness.Command Schema.CommandReadiness::{ command = command } } ] }" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,46 @@ +module Main (main) where + +import HurlWorkbench.Check.RunTest qualified as CheckRunTest +import HurlWorkbench.Hurl.RunTest qualified as RunTest +import HurlWorkbench.Parameter.GenerateTest qualified as GenerateTest +import HurlWorkbench.Parameter.ParameterTest qualified as ParameterTest +import HurlWorkbench.Run.FileRootTest qualified as FileRootTest +import HurlWorkbench.Run.SelectionTest qualified as SelectionTest +import HurlWorkbench.Service.RunTest qualified as ServiceRunTest +import HurlWorkbench.Suite.RunTest qualified as SuiteRunTest +import HurlWorkbench.Suite.ScenarioTest qualified as ScenarioTest +import HurlWorkbench.Workflow.WorkflowTest qualified as WorkflowTest +import HurlWorkbench.Workspace.NameSafetyTest qualified as NameSafetyTest +import HurlWorkbench.Workspace.WorkspaceTest qualified as WorkspaceTest +import System.Environment (getArgs) +import Test.Tasty (defaultMain, localOption, testGroup) +import Test.Tasty.Runners (NumThreads (..)) + +main :: IO () +main = do + arguments <- getArgs + case arguments of + ["--clean-environment-scenario", binary, directory] -> ServiceRunTest.runIsolatedScenario binary directory + _ -> runTests + +runTests :: IO () +runTests = + -- Existing environment-binding tests mutate process-global state. Serialize + -- test cases so concurrent POSIX spawns cannot race libc environ updates. + defaultMain $ + localOption (NumThreads 1) $ + testGroup + "hurl-workbench-core" + [ CheckRunTest.tests, + FileRootTest.tests, + GenerateTest.tests, + RunTest.tests, + ParameterTest.tests, + SelectionTest.tests, + ServiceRunTest.tests, + SuiteRunTest.tests, + ScenarioTest.tests, + WorkspaceTest.tests, + NameSafetyTest.tests, + WorkflowTest.tests + ] diff --git a/test/fixtures/processes/environment.c b/test/fixtures/processes/environment.c new file mode 100644 --- /dev/null +++ b/test/fixtures/processes/environment.c @@ -0,0 +1,62 @@ +/* Inspect envp before any language runtime can add platform variables. */ +#include +#include +#include +#include + +static int compare(const void *a, const void *b) { + return strcmp(*(const char *const *)a, *(const char *const *)b); +} + +int main(int argc, char **argv, char **envp) { + if (argc != 5) return 2; + size_t count = 0; + while (envp[count]) count++; + char **names = calloc(count + 1, sizeof(char *)); + size_t length = 3; + for (size_t i = 0; i < count; i++) { + char *equals = strchr(envp[i], '='); + if (!equals) return 3; + names[i] = strndup(envp[i], (size_t)(equals - envp[i])); + length += strlen(names[i]) + 3; + if (!strcmp(names[i], "SELECTED") && *(equals + 1)) return 4; + if (!strcmp(names[i], "BOUND") && strcmp(equals + 1, "private-bound-sentinel")) return 4; + } + qsort(names, count, sizeof(char *), compare); + char *observed = calloc(length, 1); + strcat(observed, "["); + for (size_t i = 0; i < count; i++) { + if (i) strcat(observed, ","); + strcat(observed, "\""); strcat(observed, names[i]); strcat(observed, "\""); + } + strcat(observed, "]"); + if (!strcmp(argv[4], "inherit")) { + if (!getenv("PATH")) return 5; + } else if (strcmp(observed, argv[4])) { puts(observed); return 5; } + int probe = !strcmp(argv[2], "probe") || !strcmp(argv[2], "retry"); + if (probe) { + char *service = calloc(strlen(argv[3]) + 16, 1); + strcpy(service, argv[3]); + char *slash = strrchr(service, '/'); + if (!slash) return 6; + strcpy(slash + 1, "service"); + while (access(service, F_OK)) usleep(10000); + free(service); + if (!strcmp(argv[2], "retry")) { + char *counter = calloc(strlen(argv[3]) + 16, 1); + strcpy(counter, argv[3]); strcat(counter, ".attempts"); + int attempts = 0; + FILE *previous = fopen(counter, "r"); + if (previous) { fscanf(previous, "%d", &attempts); fclose(previous); } + FILE *next = fopen(counter, "w"); + if (!next) return 8; + fprintf(next, "%d", attempts + 1); fclose(next); free(counter); + if (!attempts) return 1; + } + } + FILE *marker = fopen(argv[3], "w"); + if (!marker) return 7; + fprintf(marker, "%d", getpid()); fclose(marker); + if (!probe) sleep(60); + return 0; +} diff --git a/test/fixtures/workspaces/composition/hurl-workbench.dhall b/test/fixtures/workspaces/composition/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/composition/hurl-workbench.dhall @@ -0,0 +1,27 @@ +-- One authentication entry reused by a parameterized resource request. +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , parameters = + [ Schema.Parameter::{ name = "auth_url" } + , Schema.Parameter::{ name = "base_url" } + , Schema.Parameter::{ name = "client_id" } + , Schema.Parameter::{ + , name = "client_secret" + , kind = Schema.ParameterKind.Secret + } + , Schema.Parameter::{ name = "top", defaultValue = Some "5" } + ] + , fragments = + [ Schema.Fragment::{ name = "oauth", path = "hurl/oauth.hurl" } + , Schema.Fragment::{ name = "property", path = "hurl/property.hurl" } + ] + , workflows = + [ Schema.Workflow::{ + , name = "oauth-property" + , fragments = [ "oauth", "property" ] + , parameters = [ "auth_url", "base_url", "client_id", "client_secret", "top" ] + } + ] + } diff --git a/test/fixtures/workspaces/composition/hurl/oauth.hurl b/test/fixtures/workspaces/composition/hurl/oauth.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/composition/hurl/oauth.hurl @@ -0,0 +1,9 @@ +# Obtain an access token once; later entries use {{access_token}}. +POST {{auth_url}}/oauth/token +[FormParams] +grant_type: client_credentials +client_id: {{client_id}} +client_secret: {{client_secret}} +HTTP 200 +[Captures] +access_token: jsonpath "$.access_token" diff --git a/test/fixtures/workspaces/composition/hurl/property.hurl b/test/fixtures/workspaces/composition/hurl/property.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/composition/hurl/property.hurl @@ -0,0 +1,3 @@ +GET {{base_url}}/Property?$top={{top}} +Authorization: Bearer {{access_token}} +HTTP 200 diff --git a/test/fixtures/workspaces/duplicate/hurl-workbench.dhall b/test/fixtures/workspaces/duplicate/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/duplicate/hurl-workbench.dhall @@ -0,0 +1,14 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , fragments = + [ Schema.Fragment::{ name = "a", path = "hurl/a.hurl" } + , Schema.Fragment::{ name = "a", path = "hurl/a.hurl" } + ] + , workflows = + [ Schema.Workflow::{ name = "flow", fragments = [ "a" ] } + , Schema.Workflow::{ name = "flow", fragments = [ "a" ] } + , Schema.Workflow::{ name = "9-bad name", fragments = [ "a" ] } + ] + } diff --git a/test/fixtures/workspaces/duplicate/hurl/a.hurl b/test/fixtures/workspaces/duplicate/hurl/a.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/duplicate/hurl/a.hurl @@ -0,0 +1,2 @@ +GET https://example.test +HTTP 200 diff --git a/test/fixtures/workspaces/escaping-path/hurl-workbench.dhall b/test/fixtures/workspaces/escaping-path/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/escaping-path/hurl-workbench.dhall @@ -0,0 +1,11 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , fragments = + [ Schema.Fragment::{ name = "parent", path = "../minimal/hurl/health.hurl" } + , Schema.Fragment::{ name = "absolute", path = "/etc/hosts" } + , Schema.Fragment::{ name = "not-hurl", path = "outside-notes.txt" } + , Schema.Fragment::{ name = "missing", path = "hurl/missing.hurl" } + ] + } diff --git a/test/fixtures/workspaces/escaping-path/outside-notes.txt b/test/fixtures/workspaces/escaping-path/outside-notes.txt new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/escaping-path/outside-notes.txt @@ -0,0 +1,2 @@ +GET https://example.test +HTTP 200 diff --git a/test/fixtures/workspaces/execution/hurl-workbench.dhall b/test/fixtures/workspaces/execution/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/execution/hurl-workbench.dhall @@ -0,0 +1,41 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , parameters = + [ Schema.Parameter::{ name = "baseUrl" } + ] + , fragments = + [ Schema.Fragment::{ name = "health", path = "hurl/health.hurl" } + ] + , workflows = + [ Schema.Workflow::{ + , name = "health" + , fragments = [ "health" ] + , parameters = [ "baseUrl" ] + } + ] + , recipes = + [ Schema.Recipe::{ + , name = "health" + , workflow = "health" + , safety = Schema.Safety.ReadOnly + } + , Schema.Recipe::{ + , name = "dangerous-health" + , workflow = "health" + , safety = Schema.Safety.Mutating + } + ] + , matrices = + [ Schema.Matrix::{ + , name = "health-cases" + , recipe = "health" + , cases = + [ Schema.MatrixCase::{ name = "first" } + , Schema.MatrixCase::{ name = "second" } + , Schema.MatrixCase::{ name = "third" } + ] + } + ] + } diff --git a/test/fixtures/workspaces/execution/hurl/health.hurl b/test/fixtures/workspaces/execution/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/execution/hurl/health.hurl @@ -0,0 +1,4 @@ +GET {{baseUrl}}/health +HTTP 200 +[Asserts] +body contains "ok" diff --git a/test/fixtures/workspaces/full/hurl-workbench.dhall b/test/fixtures/workspaces/full/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/full/hurl-workbench.dhall @@ -0,0 +1,81 @@ +-- One OAuth fragment reused by two resource workflows, plus a recipe, a +-- matrix, a managed service, and a suite. +let Schema = ../../../../schema/package.dhall + +let oauthParameters = [ "auth_url", "client_id", "client_secret" ] + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , parameters = ./parameters.dhall + , fragments = + [ Schema.Fragment::{ + , name = "oauth" + , path = "hurl/oauth.hurl" + , description = Some "Client-credentials token" + } + , Schema.Fragment::{ name = "properties", path = "hurl/properties.hurl" } + , Schema.Fragment::{ name = "members", path = "hurl/members.hurl" } + ] + , workflows = + [ Schema.Workflow::{ + , name = "list-properties" + , fragments = [ "oauth", "properties" ] + , parameters = oauthParameters # [ "base_url", "top" ] + } + , Schema.Workflow::{ + , name = "list-members" + , fragments = [ "oauth", "members" ] + , parameters = oauthParameters # [ "base_url", "top" ] + } + ] + , recipes = + [ Schema.Recipe::{ + , name = "top-properties" + , workflow = "list-properties" + , bindings = [ Schema.Binding::{ parameter = "top", value = "10" } ] + , safety = Schema.Safety.ReadOnly + } + ] + , matrices = + [ Schema.Matrix::{ + , name = "property-page-sizes" + , recipe = "top-properties" + , cases = + [ Schema.MatrixCase::{ + , name = "small" + , bindings = [ Schema.Binding::{ parameter = "top", value = "1" } ] + } + , Schema.MatrixCase::{ + , name = "large" + , bindings = [ Schema.Binding::{ parameter = "top", value = "100" } ] + } + ] + } + ] + , services = + [ Schema.Service::{ + , name = "api" + , command = Schema.CommandSpec::{ + , executable = "python3" + , arguments = [ "-m", "http.server", "8080" ] + , workingDirectory = Some "." + , environment = + [ Schema.EnvironmentBinding::{ variable = "CLIENT_ID", parameter = "client_id" } ] + } + , readiness = + Schema.Readiness.Http + Schema.HttpReadiness::{ url = "http://127.0.0.1:8080/" } + } + ] + , suites = + [ Schema.Suite::{ + , name = "smoke" + , runs = + [ Schema.RunReference.Workflow "list-members" + , Schema.RunReference.Recipe "top-properties" + , Schema.RunReference.Matrix "property-page-sizes" + ] + , service = Some "api" + } + ] + } diff --git a/test/fixtures/workspaces/full/hurl/members.hurl b/test/fixtures/workspaces/full/hurl/members.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/full/hurl/members.hurl @@ -0,0 +1,3 @@ +GET {{base_url}}/Member?$top={{top}} +Authorization: Bearer {{access_token}} +HTTP 200 diff --git a/test/fixtures/workspaces/full/hurl/oauth.hurl b/test/fixtures/workspaces/full/hurl/oauth.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/full/hurl/oauth.hurl @@ -0,0 +1,9 @@ +# Obtain an access token once; later entries use {{access_token}}. +POST {{auth_url}}/oauth/token +[FormParams] +grant_type: client_credentials +client_id: {{client_id}} +client_secret: {{client_secret}} +HTTP 200 +[Captures] +access_token: jsonpath "$.access_token" diff --git a/test/fixtures/workspaces/full/hurl/properties.hurl b/test/fixtures/workspaces/full/hurl/properties.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/full/hurl/properties.hurl @@ -0,0 +1,3 @@ +GET {{base_url}}/Property?$top={{top}} +Authorization: Bearer {{access_token}} +HTTP 200 diff --git a/test/fixtures/workspaces/full/parameters.dhall b/test/fixtures/workspaces/full/parameters.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/full/parameters.dhall @@ -0,0 +1,14 @@ +-- A sibling module imported relative to the manifest. +let Schema = ../../../../schema/package.dhall + +in [ Schema.Parameter::{ name = "auth_url", defaultValue = Some "https://auth.example.test" } + , Schema.Parameter::{ name = "base_url", defaultValue = Some "https://api.example.test" } + , Schema.Parameter::{ name = "client_id", environment = Some "EXAMPLE_CLIENT_ID" } + , Schema.Parameter::{ + , name = "client_secret" + , kind = Schema.ParameterKind.Secret + , environment = Some "EXAMPLE_CLIENT_SECRET" + , description = Some "OAuth client secret" + } + , Schema.Parameter::{ name = "top", defaultValue = Some "5" } + ] diff --git a/test/fixtures/workspaces/independent-suite/hurl-workbench.dhall b/test/fixtures/workspaces/independent-suite/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/independent-suite/hurl-workbench.dhall @@ -0,0 +1,77 @@ +-- The same workspace as ../minimal, with every field spelled out and no +-- schema import. Both must decode to the same Haskell value. +{ schemaVersion = 1 +, parameters = + [ { name = "base_url" + , description = None Text + , kind = < Plain | Secret >.Plain + , defaultValue = Some "https://api.example.test" + , environment = None Text + } + ] +, fragments = + [ { name = "health", path = "hurl/health.hurl", description = None Text } ] +, workflows = + [ { name = "check-health" + , fragments = [ "health" ] + , parameters = [ "base_url" ] + , description = None Text + } + ] +, recipes = + [] : List + { name : Text + , workflow : Text + , bindings : List { parameter : Text, value : Text } + , safety : < ReadOnly | Mutating > + , description : Optional Text + } +, matrices = + [] : List + { name : Text + , recipe : Text + , cases : + List { name : Text, bindings : List { parameter : Text, value : Text } } + , failFast : Bool + , description : Optional Text + } +, services = + [] : List + { name : Text + , command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , readiness : + < Http : + { url : Text + , expectedStatus : Natural + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + | Command : + { command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + > + , shutdownTimeoutSeconds : Natural + , description : Optional Text + } +, suites = + [ { name = "compatibility" + , isolation = < SharedState | IndependentState >.IndependentState + , runs = [ < Workflow : Text | Recipe : Text | Matrix : Text >.Workflow "check-health" ] + , service = None Text + , failFast = False + , description = None Text + } + ] +} diff --git a/test/fixtures/workspaces/independent-suite/hurl/health.hurl b/test/fixtures/workspaces/independent-suite/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/independent-suite/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/invalid-value/hurl-workbench.dhall b/test/fixtures/workspaces/invalid-value/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/invalid-value/hurl-workbench.dhall @@ -0,0 +1,11 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , parameters = + [ Schema.Parameter::{ name = "padded", defaultValue = Some "value " } + , Schema.Parameter::{ name = "multiline", defaultValue = Some "line one\nline two" } + , Schema.Parameter::{ name = "equals", defaultValue = Some "a=b" } + , Schema.Parameter::{ name = "newUuid" } + ] + } diff --git a/test/fixtures/workspaces/isolation/hurl-workbench.dhall b/test/fixtures/workspaces/isolation/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/isolation/hurl-workbench.dhall @@ -0,0 +1,51 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , parameters = + [ Schema.Parameter::{ name = "baseUrl" } + ] + , fragments = + [ Schema.Fragment::{ name = "health", path = "hurl/health.hurl" } + ] + , workflows = + [ Schema.Workflow::{ + , name = "health" + , fragments = [ "health" ] + , parameters = [ "baseUrl" ] + } + ] + , recipes = + [ Schema.Recipe::{ + , name = "health" + , workflow = "health" + , safety = Schema.Safety.ReadOnly + } + , Schema.Recipe::{ + , name = "dangerous-health" + , workflow = "health" + , safety = Schema.Safety.Mutating + } + ] + , suites = + [ Schema.Suite::{ name = "mixed", runs = [ Schema.RunReference.Recipe "health", Schema.RunReference.Recipe "dangerous-health", Schema.RunReference.Matrix "writes", Schema.RunReference.Workflow "health" ], service = Some "marker" } + , Schema.Suite::{ name = "single-write", runs = [ Schema.RunReference.Recipe "dangerous-health" ] } + , Schema.Suite::{ name = "reads", runs = [ Schema.RunReference.Matrix "health-cases" ] } + , Schema.Suite::{ name = "independent", runs = [ Schema.RunReference.Matrix "writes" ], isolation = Schema.IsolationPolicy.IndependentState } + ] + , services = + [ Schema.Service::{ name = "marker", command = Schema.CommandSpec::{ executable = "sh", arguments = [ "-c", "touch service-started; exit 1" ] }, readiness = Schema.Readiness.Command Schema.CommandReadiness::{ command = Schema.CommandSpec::{ executable = "sh", arguments = [ "-c", "touch readiness-started; exit 1" ] } } } ] + , matrices = + [ Schema.Matrix::{ name = "single-write", recipe = "dangerous-health", cases = [ Schema.MatrixCase::{ name = "only" } ] } + , Schema.Matrix::{ name = "writes", recipe = "dangerous-health", cases = [ Schema.MatrixCase::{ name = "first" }, Schema.MatrixCase::{ name = "second" } ] } + , Schema.Matrix::{ + , name = "health-cases" + , recipe = "health" + , cases = + [ Schema.MatrixCase::{ name = "first" } + , Schema.MatrixCase::{ name = "second" } + , Schema.MatrixCase::{ name = "third" } + ] + } + ] + } diff --git a/test/fixtures/workspaces/isolation/hurl/health.hurl b/test/fixtures/workspaces/isolation/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/isolation/hurl/health.hurl @@ -0,0 +1,4 @@ +GET {{baseUrl}}/health +HTTP 200 +[Asserts] +body contains "ok" diff --git a/test/fixtures/workspaces/minimal-explicit/hurl-workbench.dhall b/test/fixtures/workspaces/minimal-explicit/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/minimal-explicit/hurl-workbench.dhall @@ -0,0 +1,76 @@ +-- The same workspace as ../minimal, with every field spelled out and no +-- schema import. Both must decode to the same Haskell value. +{ schemaVersion = 1 +, parameters = + [ { name = "base_url" + , description = None Text + , kind = < Plain | Secret >.Plain + , defaultValue = Some "https://api.example.test" + , environment = None Text + } + ] +, fragments = + [ { name = "health", path = "hurl/health.hurl", description = None Text } ] +, workflows = + [ { name = "check-health" + , fragments = [ "health" ] + , parameters = [ "base_url" ] + , description = None Text + } + ] +, recipes = + [] : List + { name : Text + , workflow : Text + , bindings : List { parameter : Text, value : Text } + , safety : < ReadOnly | Mutating > + , description : Optional Text + } +, matrices = + [] : List + { name : Text + , recipe : Text + , cases : + List { name : Text, bindings : List { parameter : Text, value : Text } } + , failFast : Bool + , description : Optional Text + } +, services = + [] : List + { name : Text + , command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , readiness : + < Http : + { url : Text + , expectedStatus : Natural + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + | Command : + { command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + > + , shutdownTimeoutSeconds : Natural + , description : Optional Text + } +, suites = + [] : List + { name : Text + , runs : List < Workflow : Text | Recipe : Text | Matrix : Text > + , service : Optional Text + , failFast : Bool + , description : Optional Text + } +} diff --git a/test/fixtures/workspaces/minimal-explicit/hurl/health.hurl b/test/fixtures/workspaces/minimal-explicit/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/minimal-explicit/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/minimal/hurl-workbench.dhall b/test/fixtures/workspaces/minimal/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/minimal/hurl-workbench.dhall @@ -0,0 +1,21 @@ +-- The smallest useful workspace, written with record completion so every +-- defaulted field is omitted. +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , parameters = + [ Schema.Parameter::{ + , name = "base_url" + , defaultValue = Some "https://api.example.test" + } + ] + , fragments = [ Schema.Fragment::{ name = "health", path = "hurl/health.hurl" } ] + , workflows = + [ Schema.Workflow::{ + , name = "check-health" + , fragments = [ "health" ] + , parameters = [ "base_url" ] + } + ] + } diff --git a/test/fixtures/workspaces/minimal/hurl/health.hurl b/test/fixtures/workspaces/minimal/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/minimal/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/missing-reference/hurl-workbench.dhall b/test/fixtures/workspaces/missing-reference/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/missing-reference/hurl-workbench.dhall @@ -0,0 +1,38 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , fragments = [ Schema.Fragment::{ name = "a", path = "hurl/a.hurl" } ] + , workflows = + [ Schema.Workflow::{ + , name = "flow" + , fragments = [ "a", "missing-fragment" ] + , parameters = [ "missing_parameter" ] + } + , Schema.Workflow::{ name = "empty", fragments = [] : List Text } + ] + , recipes = + [ Schema.Recipe::{ + , name = "orphan" + , workflow = "missing-workflow" + , safety = Schema.Safety.ReadOnly + } + ] + , matrices = + [ Schema.Matrix::{ + , name = "grid" + , recipe = "missing-recipe" + , cases = [] : List Schema.MatrixCase.Type + } + ] + , suites = + [ Schema.Suite::{ + , name = "all" + , runs = + [ Schema.RunReference.Workflow "flow" + , Schema.RunReference.Matrix "missing-matrix" + ] + , service = Some "missing-service" + } + ] + } diff --git a/test/fixtures/workspaces/missing-reference/hurl/a.hurl b/test/fixtures/workspaces/missing-reference/hurl/a.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/missing-reference/hurl/a.hurl @@ -0,0 +1,2 @@ +GET https://example.test +HTTP 200 diff --git a/test/fixtures/workspaces/old-command/hurl-workbench.dhall b/test/fixtures/workspaces/old-command/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-command/hurl-workbench.dhall @@ -0,0 +1,5 @@ +let Command = { executable : Text, arguments : List Text, workingDirectory : Optional Text, environment : List { variable : Text, parameter : Text } } +let Readiness = < Http : { url : Text, expectedStatus : Natural, intervalMilliseconds : Natural, timeoutSeconds : Natural } | Command : { command : Command, intervalMilliseconds : Natural, timeoutSeconds : Natural } > +let command = { executable = "/usr/bin/true", arguments = [] : List Text, workingDirectory = None Text, environment = [] : List { variable : Text, parameter : Text } } +let old = ../minimal-explicit/hurl-workbench.dhall +in old // { services = [ { name = "old", command = command, readiness = Readiness.Command { command = command, intervalMilliseconds = 10, timeoutSeconds = 1 }, shutdownTimeoutSeconds = 1, description = None Text } ] } diff --git a/test/fixtures/workspaces/old-command/hurl/health.hurl b/test/fixtures/workspaces/old-command/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-command/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/old-http/hurl-workbench.dhall b/test/fixtures/workspaces/old-http/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-http/hurl-workbench.dhall @@ -0,0 +1,5 @@ +let Command = { executable : Text, arguments : List Text, workingDirectory : Optional Text, environment : List { variable : Text, parameter : Text } } +let Readiness = < Http : { url : Text, expectedStatus : Natural, intervalMilliseconds : Natural, timeoutSeconds : Natural } | Command : { command : Command, intervalMilliseconds : Natural, timeoutSeconds : Natural } > +let command = { executable = "/usr/bin/true", arguments = [] : List Text, workingDirectory = None Text, environment = [] : List { variable : Text, parameter : Text } } +let old = ../minimal-explicit/hurl-workbench.dhall +in old // { services = [ { name = "old", command = command, readiness = Readiness.Http { url = "http://127.0.0.1:1/health", expectedStatus = 200, intervalMilliseconds = 10, timeoutSeconds = 1 }, shutdownTimeoutSeconds = 1, description = None Text } ] } diff --git a/test/fixtures/workspaces/old-http/hurl/health.hurl b/test/fixtures/workspaces/old-http/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-http/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/old-parameters/hurl-workbench.dhall b/test/fixtures/workspaces/old-parameters/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-parameters/hurl-workbench.dhall @@ -0,0 +1,77 @@ +-- The same workspace as ../minimal, with every field spelled out and no +-- schema import. Both must decode to the same Haskell value. +{ schemaVersion = 1 +, parameters = + [ { name = "base_url" + , description = None Text + , kind = < Plain | Secret >.Plain + , defaultValue = Some "https://api.example.test" + , environment = None Text + } + , { name = "token", description = None Text, kind = < Plain | Secret >.Secret, defaultValue = None Text, environment = None Text } + ] +, fragments = + [ { name = "health", path = "hurl/health.hurl", description = None Text } ] +, workflows = + [ { name = "check-health" + , fragments = [ "health" ] + , parameters = [ "base_url" ] + , description = None Text + } + ] +, recipes = + [] : List + { name : Text + , workflow : Text + , bindings : List { parameter : Text, value : Text } + , safety : < ReadOnly | Mutating > + , description : Optional Text + } +, matrices = + [] : List + { name : Text + , recipe : Text + , cases : + List { name : Text, bindings : List { parameter : Text, value : Text } } + , failFast : Bool + , description : Optional Text + } +, services = + [] : List + { name : Text + , command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , readiness : + < Http : + { url : Text + , expectedStatus : Natural + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + | Command : + { command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + > + , shutdownTimeoutSeconds : Natural + , description : Optional Text + } +, suites = + [] : List + { name : Text + , runs : List < Workflow : Text | Recipe : Text | Matrix : Text > + , service : Optional Text + , failFast : Bool + , description : Optional Text + } +} diff --git a/test/fixtures/workspaces/old-parameters/hurl/health.hurl b/test/fixtures/workspaces/old-parameters/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-parameters/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/old-service-suite/hurl-workbench.dhall b/test/fixtures/workspaces/old-service-suite/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-service-suite/hurl-workbench.dhall @@ -0,0 +1,3 @@ +-- Frozen pre-lifecycle schema records and union, without completion defaults. +let old = ../old-http/hurl-workbench.dhall +in old // { suites = [ { name = "old-service", runs = [ < Workflow : Text | Recipe : Text | Matrix : Text >.Workflow "check-health" ], service = Some "old", failFast = False, description = None Text } ] } diff --git a/test/fixtures/workspaces/old-service-suite/hurl/health.hurl b/test/fixtures/workspaces/old-service-suite/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-service-suite/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/old-suite/hurl-workbench.dhall b/test/fixtures/workspaces/old-suite/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-suite/hurl-workbench.dhall @@ -0,0 +1,76 @@ +-- The same workspace as ../minimal, with every field spelled out and no +-- schema import. Both must decode to the same Haskell value. +{ schemaVersion = 1 +, parameters = + [ { name = "base_url" + , description = None Text + , kind = < Plain | Secret >.Plain + , defaultValue = Some "https://api.example.test" + , environment = None Text + } + ] +, fragments = + [ { name = "health", path = "hurl/health.hurl", description = None Text } ] +, workflows = + [ { name = "check-health" + , fragments = [ "health" ] + , parameters = [ "base_url" ] + , description = None Text + } + ] +, recipes = + [] : List + { name : Text + , workflow : Text + , bindings : List { parameter : Text, value : Text } + , safety : < ReadOnly | Mutating > + , description : Optional Text + } +, matrices = + [] : List + { name : Text + , recipe : Text + , cases : + List { name : Text, bindings : List { parameter : Text, value : Text } } + , failFast : Bool + , description : Optional Text + } +, services = + [] : List + { name : Text + , command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , readiness : + < Http : + { url : Text + , expectedStatus : Natural + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + | Command : + { command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + > + , shutdownTimeoutSeconds : Natural + , description : Optional Text + } +, suites = + [ { name = "compatibility" + , runs = [ < Workflow : Text | Recipe : Text | Matrix : Text >.Workflow "check-health" ] + , service = None Text + , failFast = False + , description = None Text + } + ] +} diff --git a/test/fixtures/workspaces/old-suite/hurl/health.hurl b/test/fixtures/workspaces/old-suite/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/old-suite/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/schema-version/hurl-workbench.dhall b/test/fixtures/workspaces/schema-version/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/schema-version/hurl-workbench.dhall @@ -0,0 +1,2 @@ +-- Written for a future schema version this build does not understand. +{ schemaVersion = 2, somethingNew = True } diff --git a/test/fixtures/workspaces/secret-default/hurl-workbench.dhall b/test/fixtures/workspaces/secret-default/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/secret-default/hurl-workbench.dhall @@ -0,0 +1,12 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , parameters = + [ Schema.Parameter::{ + , name = "api_key" + , kind = Schema.ParameterKind.Secret + , defaultValue = Some "committed-secret" + } + ] + } diff --git a/test/fixtures/workspaces/shared-suite/hurl-workbench.dhall b/test/fixtures/workspaces/shared-suite/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/shared-suite/hurl-workbench.dhall @@ -0,0 +1,77 @@ +-- The same workspace as ../minimal, with every field spelled out and no +-- schema import. Both must decode to the same Haskell value. +{ schemaVersion = 1 +, parameters = + [ { name = "base_url" + , description = None Text + , kind = < Plain | Secret >.Plain + , defaultValue = Some "https://api.example.test" + , environment = None Text + } + ] +, fragments = + [ { name = "health", path = "hurl/health.hurl", description = None Text } ] +, workflows = + [ { name = "check-health" + , fragments = [ "health" ] + , parameters = [ "base_url" ] + , description = None Text + } + ] +, recipes = + [] : List + { name : Text + , workflow : Text + , bindings : List { parameter : Text, value : Text } + , safety : < ReadOnly | Mutating > + , description : Optional Text + } +, matrices = + [] : List + { name : Text + , recipe : Text + , cases : + List { name : Text, bindings : List { parameter : Text, value : Text } } + , failFast : Bool + , description : Optional Text + } +, services = + [] : List + { name : Text + , command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , readiness : + < Http : + { url : Text + , expectedStatus : Natural + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + | Command : + { command : + { executable : Text + , arguments : List Text + , workingDirectory : Optional Text + , environment : List { variable : Text, parameter : Text } + } + , intervalMilliseconds : Natural + , timeoutSeconds : Natural + } + > + , shutdownTimeoutSeconds : Natural + , description : Optional Text + } +, suites = + [ { name = "compatibility" + , isolation = < SharedState | IndependentState >.SharedState + , runs = [ < Workflow : Text | Recipe : Text | Matrix : Text >.Workflow "check-health" ] + , service = None Text + , failFast = False + , description = None Text + } + ] +} diff --git a/test/fixtures/workspaces/shared-suite/hurl/health.hurl b/test/fixtures/workspaces/shared-suite/hurl/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/shared-suite/hurl/health.hurl @@ -0,0 +1,2 @@ +GET {{base_url}}/health +HTTP 200 diff --git a/test/fixtures/workspaces/suite-failure/health.hurl b/test/fixtures/workspaces/suite-failure/health.hurl new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/suite-failure/health.hurl @@ -0,0 +1,2 @@ +GET http://127.0.0.1/health +HTTP 200 diff --git a/test/fixtures/workspaces/suite-failure/hurl-workbench.dhall b/test/fixtures/workspaces/suite-failure/hurl-workbench.dhall new file mode 100644 --- /dev/null +++ b/test/fixtures/workspaces/suite-failure/hurl-workbench.dhall @@ -0,0 +1,40 @@ +let Schema = ../../../../schema/package.dhall + +in Schema.Workspace::{ + , schemaVersion = Schema.schemaVersion + , fragments = + [ Schema.Fragment::{ name = "health", path = "health.hurl" } ] + , workflows = + [ Schema.Workflow::{ name = "health", fragments = [ "health" ] } ] + , recipes = + [ Schema.Recipe::{ + , name = "health" + , workflow = "health" + , safety = Schema.Safety.ReadOnly + } + ] + , services = + [ Schema.Service::{ + , name = "failure" + , command = Schema.CommandSpec::{ + , executable = "python3" + , arguments = [ "-c", "import sys; sys.exit(9)" ] + } + , readiness = + Schema.Readiness.Command + Schema.CommandReadiness::{ + , command = Schema.CommandSpec::{ + , executable = "python3" + , arguments = [ "-c", "import time; time.sleep(0.2)" ] + } + } + } + ] + , suites = + [ Schema.Suite::{ + , name = "failure" + , runs = [ Schema.RunReference.Recipe "health" ] + , service = Some "failure" + } + ] + }