diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,15 @@ +# Changelog + +## 0.3.0.0 — 2026-10-21 + +Initial release. + +### New Features + +- Add the reusable `Settei.Preflight` deployment preflight harness with explicit + input classifications, controlled environment/file channels, timeout, cleanup, + exact-value secret redaction, and deterministic text and JSON reports. +- Add strict reference-only secret requests through `Settei.Preflight.Request` + and the `settei-preflight --request PATH [--json]` executable. +- Accept `aeson >=2.2.4.1 && <2.4` (tested on 2.2.4.1, 2.2.5.1, and 2.3.2.0), so the + package also builds against the locked nixpkgs Haskell set. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2026, shinzui +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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,31 @@ +# settei-preflight + +New in the shared 0.3.0.0 family release; this package was not part of 0.2.0.0. + +Run an application's own configuration check against explicitly proposed inputs. +`Settei.Preflight` isolates the environment, materializes files in a private directory, +redacts exact known secrets, and reports `pass`, `inconclusive`, or `fail`. +Only `pass` passes a gate; partial coverage is never deployment validation. +Reports have private constructors; use `preflightVerdict`, `preflightOutcome`, +`preflightCoverage`, `preflightExecution`, and the summary accessors to inspect them +without a lens dependency. +Supported execution platforms: Linux and macOS. The harness is not a sandbox. + +`Settei.Preflight.Request` parses strict `settei.preflight-request` version 1 JSON. +Unknown fields and conflicting forms fail. Each environment/file entry has a name +and exactly one of `value` (public), `secretFromEnvironment`, `secretFromFile`, +`synthetic` with `reason` and optional `sensitivity`, `unresolved`, or `unavailableSecret`. +Secret files are read as strict UTF-8 without trimming. Request references are resolved +from the harness process; they never mean inheritance into the checked process. + +Run `settei-preflight --request request.json [--json]`. Exit codes: 0 pass, +1 inconclusive, 2 CLI usage, 3 harness failure, 4 application rejection. +The child receives only proposed present inputs plus the explicit inherited allowlist +(default `PATH`, `LANG`, `LC_ALL`, `LC_CTYPE`; `inherit: []` disables it). +The timeout covers child completion and both output streams. SIGTERM-resistant children +and descendants are not force-killed. Temporary input directories use mode 0700; +failed cleanup blocks the gate. Output is captured in memory, so use a trusted, +bounded-output configuration check. + +See [the deployment preflight guide](../docs/guides/deployment-preflight.md) in the +repository for the request schema, reference extraction workflow, and limitations. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,37 @@ +module Main (main) where + +import Control.Exception (IOException, try) +import Data.ByteString qualified as BS +import Data.Generics.Labels () +import Data.Text.IO qualified as T +import Options.Applicative qualified as O +import Settei.Preflight +import Settei.Preflight.Request +import Settei.Prelude +import System.Exit (ExitCode (..), exitWith) +import System.IO (hSetEncoding, stderr, stdout, utf8) + +main :: IO () +main = do + mapM_ (`hSetEncoding` utf8) [stdout, stderr] + (path, asJson) <- + O.execParser $ + O.info + ( (,) + <$> O.parserOptionGroup "Preflight" (O.strOption (O.long "request" <> O.metavar "PATH" <> O.help "Read a preflight request document")) + <*> O.parserOptionGroup "Output" (O.switch (O.long "json" <> O.help "Print the versioned JSON report")) O.<**> O.helper + ) + (O.fullDesc <> O.progDesc "Check proposed inputs with the application's own check command" <> O.failureCode 2) + readResult <- try (BS.readFile path) :: IO (Either IOException BS.ByteString) + request <- case readResult of + Left _ -> abort "request: file could not be read\n" + Right bytes -> case parsePreflightRequest bytes of Left ps -> abort (renderRequestErrorsText ps); Right r -> pure r + resolved <- resolveRequest processRequestEnvironment request + report <- runPreflight (resolved ^. #options) (resolved ^. #role) (resolved ^. #command) (resolved ^. #inputs) + if asJson then T.putStrLn (renderPreflightReportJson report) else T.putStr (renderPreflightReportText report) + exitWith $ case report ^. #verdict of + Pass -> ExitSuccess + Inconclusive -> ExitFailure 1 + Fail -> ExitFailure (case report ^. #outcome of Rejected _ _ -> 4; _ -> 3) + where + abort message = T.hPutStr stderr message >> exitWith (ExitFailure 3) diff --git a/settei-preflight.cabal b/settei-preflight.cabal new file mode 100644 --- /dev/null +++ b/settei-preflight.cabal @@ -0,0 +1,102 @@ +cabal-version: 3.8 +name: settei-preflight +version: 0.3.0.0 +synopsis: Run application configuration checks on proposed deployment inputs +description: + Materialize explicitly proposed environment and file inputs, run the application's + own check command, redact known secrets, and report honest deployment coverage. + +homepage: https://github.com/shinzui/settei +bug-reports: https://github.com/shinzui/settei/issues +license: BSD-3-Clause +license-file: LICENSE +author: shinzui +maintainer: shinzui +category: Configuration +build-type: Simple +tested-with: ghc ==9.12.4 +extra-doc-files: + CHANGELOG.md + README.md + +data-files: + test/golden/*.json + test/golden/*.txt + +source-repository head + type: git + location: https://github.com/shinzui/settei.git + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + + ghc-options: + -Wall + -Wcompat + +common dependencies + build-depends: + aeson >=2.2.4.1 && <2.4, + base >=4.21 && <5, + bytestring >=0.12 && <0.13, + containers >=0.6.8 && <0.8, + directory >=1.3.8 && <1.4, + filepath >=1.5.4 && <1.6, + generic-lens >=2.2 && <2.4, + process >=1.6.19 && <1.7, + settei ==0.3.0.0, + settei-env ==0.3.0.0, + temporary >=1.3 && <1.4, + text >=2.1 && <2.2, + +library + import: common, dependencies + hs-source-dirs: src + exposed-modules: + Settei.Preflight + Settei.Preflight.Request + + other-modules: Settei.Preflight.Internal + +executable settei-preflight + import: common + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded + build-depends: + base >=4.21 && <5, + bytestring >=0.12 && <0.13, + generic-lens >=2.2 && <2.4, + optparse-applicative >=0.19 && <0.20, + settei ==0.3.0.0, + settei-preflight ==0.3.0.0, + text >=2.1 && <2.2, + +test-suite settei-preflight-tests + import: common, dependencies + type: exitcode-stdio-1.0 + hs-source-dirs: + test + src + + main-is: Main.hs + ghc-options: -threaded + other-modules: + Paths_settei_preflight + Settei.Preflight + Settei.Preflight.Fixture + Settei.Preflight.Internal + Settei.Preflight.Request + Settei.Preflight.RequestTest + Settei.PreflightTest + + autogen-modules: Paths_settei_preflight + build-tool-depends: settei-preflight:settei-preflight + build-depends: + tasty >=1.5 && <1.6, + tasty-hunit >=0.10.2 && <0.11, diff --git a/src/Settei/Preflight.hs b/src/Settei/Preflight.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Preflight.hs @@ -0,0 +1,155 @@ +-- | Run an application's configuration check against explicitly proposed inputs. +-- Only 'Pass' passes a deployment gate. This runner is not a sandbox and does not +-- establish connectivity, deployed image identity, or readiness. Known nonempty +-- secrets are redacted by exact match; transformed or unclassified secrets cannot +-- be recognized. Supported execution platforms are Linux and macOS. +module Settei.Preflight + ( RoleLabel (..), + FileName (..), + ArgumentPart (..), + Argument (..), + literalArgument, + fileArgument, + CheckCommand (..), + ProposedValue (..), + ProposedFile (..), + ProposedInputs (..), + defaultInherited, + emptyProposedInputs, + ExitCodeMapping (..), + defaultExitCodes, + PreflightOptions (..), + defaultPreflightOptions, + PreflightProblem (..), + InputRef (..), + validatePreflight, + renderPreflightProblemText, + renderPreflightProblemsText, + runPreflight, + PreflightReport, + CommandSummary, + InputSummary, + Classification (..), + Outcome (..), + RejectionCategory (..), + NotRunReason (..), + Coverage (..), + Limitation, + LimitationKind (..), + Verdict (..), + Execution, + preflightRole, + preflightCommand, + preflightInputs, + preflightInherited, + preflightNotes, + preflightOutcome, + preflightCoverage, + preflightVerdict, + preflightExecution, + commandExecutable, + commandArguments, + inputReference, + inputClassification, + inputPassed, + limitationInput, + limitationKind, + limitationReason, + executionExitCode, + executionTimedOut, + executionStandardOutput, + executionStandardError, + renderPreflightReportText, + renderPreflightReportJson, + ) +where + +import Data.Generics.Labels () +import Settei.Env (EnvName) +import Settei.Preflight.Internal +import Settei.Prelude (Text, (^.)) + +-- | Read-only accessors keep reports usable without a lens dependency. +preflightRole :: PreflightReport -> RoleLabel +preflightRole value = value ^. #role + +-- | The sanitized executable and symbolic command arguments. +preflightCommand :: PreflightReport -> CommandSummary +preflightCommand value = value ^. #command + +-- | Input summaries ordered by channel and name. +preflightInputs :: PreflightReport -> [InputSummary] +preflightInputs value = value ^. #inputs + +-- | Inherited execution-context names and whether each was present; never their values. +preflightInherited :: PreflightReport -> [(EnvName, Bool)] +preflightInherited value = value ^. #inherited + +-- | Sanitized extraction notes; every version-one note reduces coverage. +preflightNotes :: PreflightReport -> [Text] +preflightNotes value = value ^. #notes + +-- | Application acceptance/rejection or the harness failure reason. +preflightOutcome :: PreflightReport -> Outcome +preflightOutcome value = value ^. #outcome + +-- | Whether every proposed input was supplied without coverage limitations. +preflightCoverage :: PreflightReport -> Coverage +preflightCoverage value = value ^. #coverage + +-- | The gate decision. Only 'Pass' passes; 'Inconclusive' also blocks a gate. +preflightVerdict :: PreflightReport -> Verdict +preflightVerdict value = value ^. #verdict + +-- | Captured execution details when a child was successfully spawned. +preflightExecution :: PreflightReport -> Maybe Execution +preflightExecution value = value ^. #execution + +-- | The sanitized resolved executable path, or attempted path when lookup failed. +commandExecutable :: CommandSummary -> FilePath +commandExecutable value = value ^. #executable + +-- | Sanitized symbolic arguments using file/directory references instead of temporary paths. +commandArguments :: CommandSummary -> [Text] +commandArguments value = value ^. #arguments + +-- | The sanitized environment name or relative file name. +inputReference :: InputSummary -> InputRef +inputReference value = value ^. #input + +-- | The input's supplied, synthetic, unresolved, or unavailable classification. +inputClassification :: InputSummary -> Classification +inputClassification value = value ^. #classification + +-- | True only for a present value supplied to a successfully spawned child. +-- It does not establish that the application consumed the input. +inputPassed :: InputSummary -> Bool +inputPassed value = value ^. #passed + +-- | The affected input or zero-based extraction-note index. +limitationInput :: Limitation -> InputRef +limitationInput value = value ^. #input + +-- | The category preventing complete coverage. +limitationKind :: Limitation -> LimitationKind +limitationKind value = value ^. #kind + +-- | The sanitized reason for incomplete coverage. +limitationReason :: Limitation -> Text +limitationReason value = value ^. #reason + +-- | The child exit code, if captured before a timeout or harness failure. +executionExitCode :: Execution -> Maybe Int +executionExitCode value = value ^. #exitCode + +-- | Whether the timeout expired during child completion or pipe draining. +executionTimedOut :: Execution -> Bool +executionTimedOut value = value ^. #timedOut + +-- | Captured stdout with exact known nonempty secrets redacted. +executionStandardOutput :: Execution -> Text +executionStandardOutput value = value ^. #standardOutput + +-- | Captured stderr with exact known nonempty secrets redacted. +executionStandardError :: Execution -> Text +executionStandardError value = value ^. #standardError diff --git a/src/Settei/Preflight/Internal.hs b/src/Settei/Preflight/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Preflight/Internal.hs @@ -0,0 +1,549 @@ +-- | Private implementation and injectable IO boundary. Raw inputs deliberately lack Show. +module Settei.Preflight.Internal where + +import Control.Concurrent (forkFinally, killThread, newChan, newEmptyMVar, putMVar, readChan, readMVar, writeChan) +import Control.Exception (IOException, bracket, fromException, throwIO, try) +import Control.Monad (forM_, unless, void, when) +import Data.Aeson qualified as A +import Data.Aeson.Encoding qualified as E +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.Generics.Labels () +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.List (find, sortOn) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.Encoding.Error (lenientDecode) +import Settei (Sensitivity (..)) +import Settei.Env (EnvName (..)) +import Settei.Prelude +import System.Directory qualified as D +import System.Environment qualified as Env +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, ()) +import System.IO qualified as IO +import System.IO.Temp (withSystemTempDirectory) +import System.Process qualified as P +import System.Timeout (timeout) + +-- | An operator-facing application role. Labels must be nonblank and credential-free. +newtype RoleLabel = RoleLabel Text deriving stock (Generic, Eq, Show) + +-- | A path relative to the private input directory. Validation rejects absolute, +-- empty, dot, parent, NUL, and backslash path segments. +newtype FileName = FileName Text deriving stock (Generic, Eq, Ord, Show) + +-- | A public literal or symbolic reference to a proposed file or directory. +-- References are replaced with private absolute paths when the command runs. +data ArgumentPart = LiteralPart !Text | FilePart !FileName | DirectoryPart !FileName deriving stock (Generic, Eq) + +-- | One command-line argument assembled from ordered parts, without invoking a shell. +-- Never put credentials in literal parts; use environment or file channels. +newtype Argument = Argument [ArgumentPart] deriving stock (Generic, Eq) + +-- | One public literal argument. Known secrets in assembled arguments are rejected. +literalArgument :: Text -> Argument +literalArgument t = Argument [LiteralPart t] + +-- | One argument naming a declared proposed file in the private directory. +fileArgument :: FileName -> Argument +fileArgument f = Argument [FilePart f] + +-- | The caller-selected host executable and arguments for an application check. +-- The runner cannot establish its equivalence to a deployed image or sandbox it. +data CheckCommand = CheckCommand {executable :: !FilePath, arguments :: ![Argument]} deriving stock (Generic, Eq) + +-- | A supplied value, fake synthetic stand-in with reason, unresolved input, or +-- unavailable secret. Only supplied values count toward complete coverage. +-- Sensitivity controls exact-value redaction; raw values deliberately lack Show. +data ProposedValue = SuppliedValue !Sensitivity !Text | SyntheticValue !Sensitivity !Text !Text | UnresolvedValue !Text | UnavailableSecret !Text deriving stock (Generic, Eq) + +-- | A named UTF-8 file input. Unresolved and unavailable contents are not written. +data ProposedFile = ProposedFile {name :: !FileName, content :: !ProposedValue} deriving stock (Generic, Eq) + +-- | The complete proposal: ordered environment entries, UTF-8 files, an explicit +-- inherited-variable allowlist, and extraction notes. Every note reduces coverage. +-- The child otherwise starts with an empty environment. +data ProposedInputs = ProposedInputs {environment :: ![(EnvName, ProposedValue)], files :: ![ProposedFile], inherited :: ![EnvName], notes :: ![Text]} deriving stock (Generic, Eq) + +-- | Default execution context: PATH, LANG, LC_ALL, and LC_CTYPE. Inherited names +-- are not deployment coverage and cannot overlap proposed environment entries. +defaultInherited :: [EnvName] +defaultInherited = fmap EnvName ["PATH", "LANG", "LC_ALL", "LC_CTYPE"] + +-- | No proposed values or notes, with only 'defaultInherited' execution context. +emptyProposedInputs :: ProposedInputs +emptyProposedInputs = ProposedInputs [] [] defaultInherited [] + +-- | Disjoint child exit-code categories, with one accepted code. Every code must +-- be in 0..255; unlisted codes are classified as unknown rejection. +data ExitCodeMapping = ExitCodeMapping {accepted :: !Int, usage :: ![Int], sourceFailure :: ![Int], rejected :: ![Int]} deriving stock (Generic, Eq, Show) + +-- | Accepted 0, usage 2, source failure 3, and configuration rejection 4. +defaultExitCodes :: ExitCodeMapping +defaultExitCodes = ExitCodeMapping 0 [2] [3] [4] + +-- | A positive timeout in seconds and the application-owned exit-code convention. +data PreflightOptions = PreflightOptions {timeoutSeconds :: !Int, exitCodes :: !ExitCodeMapping} deriving stock (Generic, Eq, Show) + +-- | A 60-second timeout with 'defaultExitCodes'. +defaultPreflightOptions :: PreflightOptions +defaultPreflightOptions = PreflightOptions 60 defaultExitCodes + +-- | An environment name, relative file name, or zero-based extraction-note index. +data InputRef = EnvironmentInput !EnvName | FileInput !FileName | ExtractionNote !Int deriving stock (Generic, Eq, Show) + +-- | A structural request problem retaining metadata rather than input values. +-- Use the public validation/runner boundary to sanitize known secrets in metadata. +data PreflightProblem + = InvalidEnvironmentName !EnvName + | DuplicateEnvironmentName !EnvName + | InvalidEnvironmentValue !EnvName + | InvalidFileName !FileName + | DuplicateFileName !FileName + | FilePathConflict !FileName !FileName + | UnknownFileReference !Int !FileName + | SecretInArgument !Int !InputRef + | InvalidInheritedName !EnvName + | InheritedNameProposed !EnvName + | DuplicateInheritedName !EnvName + | InvalidExecutable + | InvalidArgument !Int + | SecretInExecutable !InputRef + | InvalidTimeout + | InvalidExitCodeMapping + | EmptyRoleLabel + deriving stock (Generic, Eq, Show) + +-- | Sanitized executable and symbolic arguments; temporary paths are not retained. +data CommandSummary = CommandSummary {executable :: !FilePath, arguments :: ![Text]} deriving stock (Generic, Eq, Show) + +-- | Sanitized input identity, coverage classification, and whether it was supplied +-- to a successfully spawned child. This does not prove the application consumed it. +data InputSummary = InputSummary {input :: !InputRef, classification :: !Classification, passed :: !Bool} deriving stock (Generic, Eq, Show) + +-- | Whether an input is supplied, synthetic, unresolved, or unavailable, preserving +-- public/secret classification without retaining its value. +data Classification = SuppliedPublic | SuppliedSecret | SyntheticPublic | SyntheticSecret | Unresolved | UnavailableSecretInput deriving stock (Generic, Eq, Show) + +-- | Application acceptance, categorized rejection with child exit code, or a harness +-- failure. Partial coverage affects the verdict even when the application accepts. +data Outcome = Accepted | Rejected !RejectionCategory !Int | NotRun !NotRunReason deriving stock (Generic, Eq, Show) + +-- | Child exit classification under the caller's 'ExitCodeMapping'. +data RejectionCategory = UsageError | SourceFailure | ConfigurationRejected | UnknownExitCode deriving stock (Generic, Eq, Show) + +-- | A sanitized harness failure. A timeout or capture/cleanup failure may occur +-- after the child started; execution details are retained when available. +data NotRunReason = RequestInvalid !(NonEmpty PreflightProblem) | ExecutableNotFound !FilePath | SpawnFailed !Text | MaterializationFailed !Text | CaptureFailed !Text | CleanupFailed !Text | TimedOut !Int deriving stock (Generic, Eq, Show) + +-- | Complete proposed-input coverage or a nonempty list of limitations. +-- This does not establish deployed credentials, connectivity, or readiness. +data Coverage = CompleteCoverage | PartialCoverage !(NonEmpty Limitation) deriving stock (Generic, Eq, Show) + +-- | One sanitized input or extraction-note reason preventing complete coverage. +data Limitation = Limitation {input :: !InputRef, kind :: !LimitationKind, reason :: !Text} deriving stock (Generic, Eq, Show) + +-- | Synthetic, unresolved, unavailable-secret, or incomplete-extraction coverage. +data LimitationKind = SyntheticStandIn | NotYetResolved | SecretUnavailable | ExtractionIncomplete deriving stock (Generic, Eq, Show) + +-- | Only Pass passes a gate. Accepted checks with partial coverage are Inconclusive; +-- application rejection or harness failure is Fail regardless of coverage. +data Verdict = Pass | Inconclusive | Fail deriving stock (Generic, Eq, Show) + +-- | Sanitized child exit/timeout information and captured output. Output is buffered +-- in memory and redacts exact known nonempty secrets, not transformed values. +data Execution = Execution {exitCode :: !(Maybe Int), timedOut :: !Bool, standardOutput :: !Text, standardError :: !Text} deriving stock (Generic, Eq, Show) + +-- Private captured bytes decoded as text, before redaction; deliberately no Show. +data CapturedExecution = CapturedExecution !(Maybe Int) !Bool !Text !Text + +-- | A sanitized report with private constructors at the public boundary. Inspect +-- using Settei.Preflight accessors and render only the safe report, not raw inputs. +data PreflightReport = PreflightReport + {role :: !RoleLabel, command :: !CommandSummary, inputs :: ![InputSummary], inherited :: ![(EnvName, Bool)], notes :: ![Text], outcome :: !Outcome, coverage :: !Coverage, verdict :: !Verdict, execution :: !(Maybe Execution)} + deriving stock (Generic, Eq, Show) + +validEnvironmentName :: EnvName -> Bool +validEnvironmentName (EnvName t) = case T.uncons t of + Nothing -> False + Just (c, rest) -> initial c && T.all (\x -> initial x || (isDigit x && x <= '9')) rest + where + initial c = isAsciiLower c || isAsciiUpper c || c == '_' + +validFileName :: FileName -> Bool +validFileName (FileName t) = not (T.null t) && not (T.any (`elem` ['\0', '\\']) t) && all (\s -> s /= "" && s /= "." && s /= "..") (T.splitOn "/" t) + +fileText :: FileName -> Text +fileText (FileName t) = t + +envText :: EnvName -> Text +envText (EnvName t) = t + +refText :: InputRef -> Text +refText = \case EnvironmentInput n -> envText n; FileInput f -> "file " <> fileText f; ExtractionNote n -> "extraction note " <> tshow n + +entries :: ProposedInputs -> [(InputRef, ProposedValue)] +entries p = [(EnvironmentInput n, v) | (n, v) <- p ^. #environment] <> [(FileInput (f ^. #name), f ^. #content) | f <- p ^. #files] + +valueText :: ProposedValue -> Maybe Text +valueText = \case SuppliedValue _ v -> Just v; SyntheticValue _ v _ -> Just v; _ -> Nothing + +secretValues :: ProposedInputs -> [(Text, Text)] +secretValues p = + sortOn + (negate . T.length . fst) + [(v, marker n ref) | (n, (ref, pv)) <- zip [0 :: Int ..] (entries p), Just v <- [secret pv], not (T.null v)] + where + secret = \case SuppliedValue Secret v -> Just v; SyntheticValue Secret v _ -> Just v; _ -> Nothing + allSecrets = [v | (_, pv) <- entries p, Just v <- [secret pv], not (T.null v)] + marker n ref = "[redacted:" <> (if any (`T.isInfixOf` refText ref) allSecrets then "input " <> tshow n else refText ref) <> "]" + +-- | Match original text once; never rescan inserted markers, even for overlapping secrets. +redact :: [(Text, Text)] -> Text -> Text +redact secrets = T.concat . go + where + go t | T.null t = [] + go t = case find (\(s, _) -> s `T.isPrefixOf` t) secrets of + Just (s, m) -> m : go (T.drop (T.length s) t) + Nothing -> T.take 1 t : go (T.drop 1 t) + +mapRef :: (Text -> Text) -> InputRef -> InputRef +mapRef f = \case EnvironmentInput n -> EnvironmentInput (EnvName (f (envText n))); FileInput n -> FileInput (FileName (f (fileText n))); ExtractionNote n -> ExtractionNote n + +mapProblem :: (Text -> Text) -> PreflightProblem -> PreflightProblem +mapProblem f = \case + InvalidEnvironmentName n -> InvalidEnvironmentName (en n) + DuplicateEnvironmentName n -> DuplicateEnvironmentName (en n) + InvalidEnvironmentValue n -> InvalidEnvironmentValue (en n) + InvalidFileName n -> InvalidFileName (fn n) + DuplicateFileName n -> DuplicateFileName (fn n) + FilePathConflict a b -> FilePathConflict (fn a) (fn b) + UnknownFileReference n a -> UnknownFileReference n (fn a) + SecretInArgument n a -> SecretInArgument n (mapRef f a) + InvalidInheritedName n -> InvalidInheritedName (en n) + InheritedNameProposed n -> InheritedNameProposed (en n) + DuplicateInheritedName n -> DuplicateInheritedName (en n) + SecretInExecutable a -> SecretInExecutable (mapRef f a) + a -> a + where + en = EnvName . f . envText; fn = FileName . f . fileText + +-- | Pure request validation: names, paths, references, timeout, exit codes, and +-- known-secret command exposure. It performs no IO or application execution. +validatePreflight :: PreflightOptions -> RoleLabel -> CheckCommand -> ProposedInputs -> Either (NonEmpty PreflightProblem) () +validatePreflight opts role cmd p = case validatePreflightRaw opts role cmd p of + Left ps -> Left (fmap (mapProblem (redact (secretValues p))) ps) + Right () -> Right () + +validatePreflightRaw :: PreflightOptions -> RoleLabel -> CheckCommand -> ProposedInputs -> Either (NonEmpty PreflightProblem) () +validatePreflightRaw opts (RoleLabel label) cmd p = maybe (Right ()) Left (NE.nonEmpty problems) + where + es = p ^. #environment + fs = fmap (view #name) (p ^. #files) + ins = p ^. #inherited + problems = + [EmptyRoleLabel | T.null (T.strip label)] + <> [InvalidExecutable | null (cmd ^. #executable) || '\0' `elem` (cmd ^. #executable)] + <> [InvalidTimeout | opts ^. #timeoutSeconds <= 0 || opts ^. #timeoutSeconds > maxBound `div` 1000000] + <> [InvalidExitCodeMapping | not (validExitCodes (opts ^. #exitCodes))] + <> concat [[InvalidEnvironmentName n | not (validEnvironmentName n)] <> [DuplicateEnvironmentName n | n `elem` take i (fmap fst es)] <> [InvalidEnvironmentValue n | maybe False (T.any (== '\0')) (valueText v)] | (i, (n, v)) <- zip [0 ..] es] + <> concat [[InvalidFileName f | not (validFileName f)] <> [DuplicateFileName f | f `elem` take i fs] <> [FilePathConflict a f | a <- take i fs, parent a f || parent f a] | (i, f) <- zip [0 ..] fs] + <> concat [[InvalidInheritedName n | not (validEnvironmentName n)] <> [DuplicateInheritedName n | n `elem` take i ins] <> [InheritedNameProposed n | n `elem` fmap fst es] | (i, n) <- zip [0 ..] ins] + <> concat [[InvalidArgument i | T.any (== '\0') (summaryArgument a)] <> [UnknownFileReference i f | part <- argumentParts a, f <- case part of FilePart n -> [n | n `notElem` fs]; DirectoryPart n -> [n | not (validFileName n) || not (any (parent n) fs)]; _ -> []] | (i, a) <- zip [0 ..] (cmd ^. #arguments)] + <> secretCommandProblems p (cmd ^. #executable) (fmap summaryArgument (cmd ^. #arguments)) + argumentParts (Argument ps) = ps + parent a b = (fileText a <> "/") `T.isPrefixOf` fileText b + +validExitCodes :: ExitCodeMapping -> Bool +validExitCodes m = all (\n -> n >= 0 && n <= 255) codes && length codes == length (unique codes) + where + codes = [m ^. #accepted] <> m ^. #usage <> m ^. #sourceFailure <> m ^. #rejected + +unique :: (Eq a) => [a] -> [a] +unique = foldl (\xs x -> if x `elem` xs then xs else xs <> [x]) [] + +summaryArgument :: Argument -> Text +summaryArgument (Argument ps) = foldMap (\case LiteralPart t -> t; FilePart f -> "{file:" <> fileText f <> "}"; DirectoryPart f -> "{dir:" <> fileText f <> "}") ps + +secretCommandProblems :: ProposedInputs -> FilePath -> [Text] -> [PreflightProblem] +secretCommandProblems p exe args = concatMap check (entries p) + where + check (ref, v) = case v of + SuppliedValue Secret t -> matches ref t + SyntheticValue Secret t _ -> matches ref t + _ -> [] + matches _ t | T.null t = [] + matches ref t = [SecretInExecutable ref | t `T.isInfixOf` T.pack exe] <> [SecretInArgument i ref | (i, a) <- zip [0 ..] args, t `T.isInfixOf` a] + +-- | Private operations make failures deterministic to test without weakening the public API. +data RunOperations = RunOperations + { materializeInputs :: !(FilePath -> ProposedInputs -> CheckCommand -> IO ()), + captureOutput :: !(IO.Handle -> IO BS.ByteString), + removeInputs :: !(FilePath -> IO ()), + createCheckProcess :: !(P.CreateProcess -> IO (Maybe IO.Handle, Maybe IO.Handle, Maybe IO.Handle, P.ProcessHandle)) + } + deriving stock (Generic) + +defaultRunOperations :: RunOperations +defaultRunOperations = RunOperations materialize (\h -> BS.hGetSome h 32768) D.removePathForcibly P.createProcess + +materialize :: FilePath -> ProposedInputs -> CheckCommand -> IO () +materialize root p cmd = do + forM_ (p ^. #files) $ \f -> case valueText (f ^. #content) of + Nothing -> pure () + Just v -> do + let path = root T.unpack (fileText (f ^. #name)) + D.createDirectoryIfMissing True (takeDirectory path) + BS.writeFile path (TE.encodeUtf8 v) + mapM_ (\(Argument ps) -> mapM_ (\case DirectoryPart n -> D.createDirectoryIfMissing True (root T.unpack (fileText n)); _ -> pure ()) ps) (cmd ^. #arguments) + +materializedArguments :: FilePath -> CheckCommand -> [Text] +materializedArguments root cmd = fmap (\(Argument ps) -> foldMap (\case LiteralPart t -> t; FilePart f -> path f; DirectoryPart f -> path f) ps) (cmd ^. #arguments) + where + path f = T.pack (root T.unpack (fileText f)) + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +-- | Validate, materialize in a fresh 0700 directory, run the check, redact output, +-- and verify cleanup before returning. Timeout includes pipe draining and requests +-- SIGTERM; resistant children/descendants are not force-killed. Use trusted checks +-- with bounded output. This runner is not a sandbox. +runPreflight :: PreflightOptions -> RoleLabel -> CheckCommand -> ProposedInputs -> IO PreflightReport +runPreflight = runPreflightWith defaultRunOperations + +runPreflightWith :: RunOperations -> PreflightOptions -> RoleLabel -> CheckCommand -> ProposedInputs -> IO PreflightReport +runPreflightWith ops opts label cmd p = do + ambient <- Env.getEnvironment + let inheritedValues = [(n, lookup (T.unpack (envText n)) ambient) | n <- p ^. #inherited] + childEnv = [(T.unpack (envText n), v) | (n, Just v) <- inheritedValues] <> [(T.unpack (envText n), T.unpack v) | (n, pv) <- p ^. #environment, Just v <- [valueText pv]] + finish exe started result = pure (makeReport opts label exe (cmd ^. #arguments) p (fmap (\(n, v) -> (n, maybe False (const True) v)) inheritedValues) started result) + case validatePreflightRaw opts label cmd p of + Left problems -> finish (cmd ^. #executable) False (Left (RequestInvalid problems), Nothing) + Right () -> do + resolved <- + tryIO $ + if '/' `elem` (cmd ^. #executable) + then do path <- D.makeAbsolute (cmd ^. #executable); exists <- D.doesFileExist path; pure (if exists then Just path else Nothing) + else D.findExecutable (cmd ^. #executable) >>= traverse D.makeAbsolute + case resolved of + Left _ -> finish (cmd ^. #executable) False (Left (SpawnFailed "executable lookup failed"), Nothing) + Right Nothing -> finish (cmd ^. #executable) False (Left (ExecutableNotFound (cmd ^. #executable)), Nothing) + Right (Just exe) -> do + attempted <- tryIO $ withSystemTempDirectory "settei-preflight" $ \root -> do + written <- tryIO ((ops ^. #materializeInputs) root p cmd) + result <- case written of + Left _ -> pure (False, (Left (MaterializationFailed "input files could not be written"), Nothing)) + Right () -> case NE.nonEmpty (secretCommandProblems p exe (materializedArguments root cmd)) of + Just ps -> pure (False, (Left (RequestInvalid ps), Nothing)) + Nothing -> execute ops opts root exe (materializedArguments root cmd) childEnv + removed <- tryIO $ do + (ops ^. #removeInputs) root + remains <- D.doesPathExist root + when remains (ioError (userError "cleanup incomplete")) + pure $ case removed of + Left _ -> (fst result, (Left (CleanupFailed "temporary input directory could not be removed"), snd (snd result))) + Right () -> result + case attempted of + Left _ -> finish exe False (Left (MaterializationFailed "temporary input directory could not be created"), Nothing) + Right (started, result) -> finish exe started result + +-- Reader scopes are INSIDE the process bracket: cancellation joins before hClose. +execute :: RunOperations -> PreflightOptions -> FilePath -> FilePath -> [Text] -> [(String, String)] -> IO (Bool, (Either NotRunReason Int, Maybe CapturedExecution)) +execute ops opts root exe args environmentValues = do + out <- newIORef [] + err <- newIORef [] + spawned <- newIORef False + events <- newChan + let reader h buffer = do + chunk <- (ops ^. #captureOutput) h + unless (BS.null chunk) (modifyIORef' buffer (chunk :) >> reader h buffer) + scoped action continuation = + bracket + ( do + done <- newEmptyMVar + tid <- forkFinally action (\result -> putMVar done () >> writeChan events result) + pure (tid, done) + ) + (\(tid, done) -> killThread tid >> void (readMVar done)) + (const continuation) + collect 0 code = pure code + collect remaining code = + readChan events >>= \case + Right found -> collect (remaining - 1 :: Int) (maybe code id found) + Left e -> case fromException e of + Just ioe -> throwIO (ioe :: IOException) + Nothing -> throwIO e + process = (P.proc exe (fmap T.unpack args)) {P.cwd = Just root, P.env = Just environmentValues, P.std_in = P.CreatePipe, P.std_out = P.CreatePipe, P.std_err = P.CreatePipe} + result <- tryIO $ bracket ((ops ^. #createCheckProcess) process) P.cleanupProcess $ \(mi, mo, me, ph) -> do + modifyIORef' spawned (const True) + case (mi, mo, me) of + (Just hi, Just ho, Just he) -> do + mapM_ (`IO.hSetBinaryMode` True) [hi, ho, he] + IO.hClose hi + scoped (reader ho out >> pure Nothing) $ + scoped (reader he err >> pure Nothing) $ + scoped (Just . exitInt <$> P.waitForProcess ph) $ + timeout (opts ^. #timeoutSeconds * 1000000) (tryIO (collect 3 0)) + _ -> ioError (userError "missing pipes") + didSpawn <- readIORef spawned + stdout <- TE.decodeUtf8With lenientDecode . BS.concat . reverse <$> readIORef out + stderr <- TE.decodeUtf8With lenientDecode . BS.concat . reverse <$> readIORef err + let outcomeValue = case result of + Left _ -> Left (if didSpawn then CaptureFailed "process output could not be captured" else SpawnFailed "process could not be started") + Right Nothing -> Left (TimedOut (opts ^. #timeoutSeconds)) + Right (Just (Left _)) -> Left (CaptureFailed "process output could not be captured") + Right (Just (Right ec)) -> Right ec + executionValue = if didSpawn then Just (CapturedExecution (either (const Nothing) Just outcomeValue) (case outcomeValue of Left (TimedOut _) -> True; _ -> False) stdout stderr) else Nothing + pure (didSpawn, (outcomeValue, executionValue)) + where + exitInt ExitSuccess = 0 + exitInt (ExitFailure n) = n + +makeReport :: PreflightOptions -> RoleLabel -> FilePath -> [Argument] -> ProposedInputs -> [(EnvName, Bool)] -> Bool -> (Either NotRunReason Int, Maybe CapturedExecution) -> PreflightReport +makeReport opts (RoleLabel label) exe args p inheritedValues started (result, ex) = + PreflightReport (RoleLabel (safe label)) (CommandSummary (T.unpack (safe (T.pack exe))) (fmap (safe . summaryArgument) args)) summaries (fmap (\(n, b) -> (EnvName (safe (envText n)), b)) inheritedValues) (fmap safe (p ^. #notes)) outcomeValue coverageValue verdictValue executionValue + where + safe = redact (secretValues p) + sorted = sortOn (\(r, _) -> case r of EnvironmentInput n -> (0 :: Int, envText n); FileInput n -> (1, fileText n); ExtractionNote n -> (2, tshow n)) (entries p) + classify = \case SuppliedValue Public _ -> SuppliedPublic; SuppliedValue Secret _ -> SuppliedSecret; SyntheticValue Public _ _ -> SyntheticPublic; SyntheticValue Secret _ _ -> SyntheticSecret; UnresolvedValue _ -> Unresolved; UnavailableSecret _ -> UnavailableSecretInput + summaries = [InputSummary (mapRef safe r) (classify v) (started && maybe False (const True) (valueText v)) | (r, v) <- sorted] + limits = + [Limitation (mapRef safe r) k (safe reason) | (r, v) <- sorted, (k, reason) <- case v of SyntheticValue _ _ why -> [(SyntheticStandIn, why)]; UnresolvedValue why -> [(NotYetResolved, why)]; UnavailableSecret why -> [(SecretUnavailable, why)]; _ -> []] + <> [Limitation (ExtractionNote n) ExtractionIncomplete (safe note) | (n, note) <- zip [0 ..] (p ^. #notes)] + coverageValue = maybe CompleteCoverage PartialCoverage (NE.nonEmpty limits) + outcomeValue = either (NotRun . sanitizeNotRun safe) (classifyExit (opts ^. #exitCodes)) result + verdictValue = case outcomeValue of Accepted -> if null limits then Pass else Inconclusive; _ -> Fail + executionValue = fmap (\(CapturedExecution ec timed stdout stderr) -> Execution ec timed (safe stdout) (safe stderr)) ex + +classifyExit :: ExitCodeMapping -> Int -> Outcome +classifyExit m n | n == m ^. #accepted = Accepted +classifyExit m n = Rejected (if n `elem` m ^. #usage then UsageError else if n `elem` m ^. #sourceFailure then SourceFailure else if n `elem` m ^. #rejected then ConfigurationRejected else UnknownExitCode) n + +sanitizeNotRun :: (Text -> Text) -> NotRunReason -> NotRunReason +sanitizeNotRun f = \case + RequestInvalid ps -> RequestInvalid (fmap (mapProblem f) ps) + ExecutableNotFound p -> ExecutableNotFound (T.unpack (f (T.pack p))) + SpawnFailed t -> SpawnFailed (f t) + MaterializationFailed t -> MaterializationFailed (f t) + CaptureFailed t -> CaptureFailed (f t) + CleanupFailed t -> CleanupFailed (f t) + TimedOut n -> TimedOut n + +tshow :: (Show a) => a -> Text +tshow = T.pack . show + +problemFields :: PreflightProblem -> (Text, Maybe Text, Maybe Int, Maybe Text) +problemFields = \case + InvalidEnvironmentName n -> named "invalid-environment-name" (envText n) + DuplicateEnvironmentName n -> named "duplicate-environment-name" (envText n) + InvalidEnvironmentValue n -> named "invalid-environment-value" (envText n) + InvalidFileName n -> named "invalid-file-name" (fileText n) + DuplicateFileName n -> named "duplicate-file-name" (fileText n) + FilePathConflict a b -> ("file-path-conflict", Just (fileText a), Nothing, Just (fileText b)) + UnknownFileReference i n -> ("unknown-file-reference", Just (fileText n), Just i, Nothing) + SecretInArgument i r -> ("secret-in-argument", Just (refText r), Just i, Nothing) + InvalidInheritedName n -> named "invalid-inherited-name" (envText n) + InheritedNameProposed n -> named "inherited-name-proposed" (envText n) + DuplicateInheritedName n -> named "duplicate-inherited-name" (envText n) + SecretInExecutable r -> named "secret-in-executable" (refText r) + InvalidExecutable -> bare "invalid-executable" + InvalidArgument i -> ("invalid-argument", Nothing, Just i, Nothing) + InvalidTimeout -> bare "invalid-timeout" + InvalidExitCodeMapping -> bare "invalid-exit-code-mapping" + EmptyRoleLabel -> bare "empty-role-label" + where + named k n = (k, Just n, Nothing, Nothing); bare k = (k, Nothing, Nothing, Nothing) + +-- | Render one sanitized structural problem as one physical line. +renderPreflightProblemText :: PreflightProblem -> Text +renderPreflightProblemText p = let (k, n, a, r) = problemFields p in k <> maybe "" ((": " <>) . oneLine) n <> maybe "" (\i -> " (argument " <> tshow i <> ")") a <> maybe "" ((" conflicts with " <>) . oneLine) r + +-- Preserve the one-problem-per-line contract even for invalid names. +oneLine :: Text -> Text +oneLine = T.concatMap (\case '\n' -> "\\n"; '\r' -> "\\r"; '\t' -> "\\t"; '\0' -> "\\0"; c -> T.singleton c) + +-- | Render sanitized request problems in order, one per line. +renderPreflightProblemsText :: NonEmpty PreflightProblem -> Text +renderPreflightProblemsText = T.unlines . fmap renderPreflightProblemText . NE.toList + +verdictText :: Verdict -> Text +verdictText = \case Pass -> "pass"; Inconclusive -> "inconclusive"; Fail -> "fail" + +categoryText :: RejectionCategory -> Text +categoryText = \case UsageError -> "usage"; SourceFailure -> "source-failure"; ConfigurationRejected -> "configuration-rejected"; UnknownExitCode -> "unknown-exit-code" + +notRunFields :: NotRunReason -> (Text, Maybe Text, [PreflightProblem]) +notRunFields = \case + RequestInvalid ps -> ("request-invalid", Nothing, NE.toList ps) + ExecutableNotFound p -> ("executable-not-found", Just (T.pack p), []) + SpawnFailed t -> ("spawn-failed", Just t, []) + MaterializationFailed t -> ("materialization-failed", Just t, []) + CaptureFailed t -> ("capture-failed", Just t, []) + CleanupFailed t -> ("cleanup-failed", Just t, []) + TimedOut n -> ("timed-out", Just (tshow n <> " seconds"), []) + +verdictExplanation :: PreflightReport -> Text +verdictExplanation r = case r ^. #outcome of + Accepted -> if r ^. #verdict == Pass then "accepted with complete coverage" else "accepted with partial coverage; not a deployment validation" + Rejected c n -> (case c of UsageError -> "usage error"; SourceFailure -> "source loading failed"; ConfigurationRejected -> "configuration rejected"; UnknownExitCode -> "unknown exit code") <> ", exit " <> tshow n + NotRun why -> let (k, d, ps) = notRunFields why in "not run: " <> T.replace "-" " " k <> maybe "" (": " <>) d <> (if null ps then "" else ": " <> T.intercalate "; " (fmap renderPreflightProblemText ps)) + +classificationText :: Classification -> Text +classificationText = \case SuppliedPublic -> "supplied-public"; SuppliedSecret -> "supplied-secret"; SyntheticPublic -> "synthetic-public"; SyntheticSecret -> "synthetic-secret"; Unresolved -> "unresolved"; UnavailableSecretInput -> "unavailable-secret" + +limitationText :: LimitationKind -> Text +limitationText = \case SyntheticStandIn -> "synthetic-stand-in"; NotYetResolved -> "not-yet-resolved"; SecretUnavailable -> "secret-unavailable"; ExtractionIncomplete -> "extraction-incomplete" + +limitations :: Coverage -> [Limitation] +limitations = \case CompleteCoverage -> []; PartialCoverage ls -> NE.toList ls + +-- | Render a deterministic human-readable verdict, coverage, inputs, and safe output. +renderPreflightReportText :: PreflightReport -> Text +renderPreflightReportText r = + T.unlines $ + ["preflight " <> label <> ": " <> verdictText (r ^. #verdict) <> " (" <> verdictExplanation r <> ")", "coverage: " <> (case r ^. #coverage of CompleteCoverage -> "complete"; _ -> "partial")] + <> [" " <> refText (l ^. #input) <> ": " <> (case l ^. #kind of SyntheticStandIn -> "synthetic stand-in"; k -> T.replace "-" " " (limitationText k)) <> " (" <> l ^. #reason <> ")" | l <- limitations (r ^. #coverage)] + <> (if null (r ^. #inputs) then ["inputs: (none)"] else "inputs:" : [" " <> refText (s ^. #input) <> ": " <> T.replace "-" " " (classificationText (s ^. #classification)) <> (if s ^. #passed then "" else " (omitted)") | s <- r ^. #inputs]) + <> ["inherited: " <> (if null (r ^. #inherited) then "(none)" else T.intercalate ", " [envText n <> if present then " (present)" else " (absent)" | (n, present) <- r ^. #inherited]), "command: " <> T.unwords (T.pack (r ^. #command . #executable) : r ^. #command . #arguments)] + <> (if null (r ^. #notes) then [] else "notes:" : fmap (" " <>) (r ^. #notes)) + <> block "stdout" (maybe "" (view #standardOutput) (r ^. #execution)) + <> block "stderr" (maybe "" (view #standardError) (r ^. #execution)) + where + RoleLabel label = r ^. #role + block name t = (name <> ":") : if T.null t then [" (empty)"] else fmap (" " <>) (T.lines t) + +encodingText :: A.Encoding -> Text +encodingText = TE.decodeUtf8 . BL.toStrict . E.encodingToLazyByteString + +obj :: [(A.Key, A.Encoding)] -> A.Encoding +obj = E.pairs . foldMap (uncurry E.pair) + +json :: (A.ToJSON a) => a -> A.Encoding +json = A.toEncoding + +refFields :: InputRef -> [(A.Key, A.Encoding)] +refFields ref = [("channel", json channel), ("name", json name)] + where + (channel, name) = case ref of EnvironmentInput n -> ("environment" :: Text, envText n); FileInput f -> ("file", fileText f); ExtractionNote n -> ("extraction", tshow n) + +-- | Render deterministic settei.preflight schema-version-1 JSON. Report fields +-- contain sanitized metadata and output, without proposed raw values. +renderPreflightReportJson :: PreflightReport -> Text +renderPreflightReportJson r = + encodingText $ + obj + [("schemaVersion", json (1 :: Int)), ("type", json ("settei.preflight" :: Text)), ("role", json label), ("verdict", json (verdictText (r ^. #verdict))), ("verdictExplanation", json (verdictExplanation r)), ("outcome", outcomeJson (r ^. #outcome)), ("coverage", obj [("kind", json (case r ^. #coverage of CompleteCoverage -> "complete" :: Text; _ -> "partial")), ("limitations", E.list limitJson (limitations (r ^. #coverage)))]), ("inputs", E.list inputJson (r ^. #inputs)), ("inherited", E.list (\(n, b) -> obj [("name", json (envText n)), ("present", json b)]) (r ^. #inherited)), ("notes", json (r ^. #notes)), ("command", obj [("executable", json (r ^. #command . #executable)), ("arguments", json (r ^. #command . #arguments))]), ("execution", maybe E.null_ executionJson (r ^. #execution))] + where + RoleLabel label = r ^. #role + inputJson s = obj (refFields (s ^. #input) <> [("classification", json (classificationText (s ^. #classification))), ("passed", json (s ^. #passed))]) + limitJson l = obj (refFields (l ^. #input) <> [("limitation", json (limitationText (l ^. #kind))), ("reason", json (l ^. #reason))]) + executionJson e = obj [("exitCode", json (e ^. #exitCode)), ("timedOut", json (e ^. #timedOut)), ("stdout", json (e ^. #standardOutput)), ("stderr", json (e ^. #standardError))] + outcomeJson = \case + Accepted -> obj [("kind", json ("accepted" :: Text))] + Rejected c n -> obj [("kind", json ("rejected" :: Text)), ("category", json (categoryText c)), ("exitCode", json n)] + NotRun why -> let (k, d, ps) = notRunFields why in obj [("kind", json ("not-run" :: Text)), ("reason", json k), ("detail", json d), ("problems", E.list problemJson ps)] + problemJson p = let (k, n, a, related) = problemFields p in obj ([("kind", json k), ("name", json n), ("argument", json a)] <> maybe [] (\v -> [("relatedName", json v)]) related) diff --git a/src/Settei/Preflight/Request.hs b/src/Settei/Preflight/Request.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Preflight/Request.hs @@ -0,0 +1,265 @@ +-- | Strict version-one request documents for deployment tooling. +-- Public values and fake stand-ins may be inline. Real secrets use references. +-- Parser diagnostics retain only schema paths and fixed messages, never input text. +module Settei.Preflight.Request + ( PreflightRequest (..), + RequestEntry (..), + EntryForm (..), + preflightRequest, + parsePreflightRequest, + renderPreflightRequestJson, + RequestError, + renderRequestErrorText, + renderRequestErrorsText, + RequestEnvironment (..), + processRequestEnvironment, + ResolvedRequest (..), + resolveRequest, + ) +where + +import Control.Monad (unless) +import Data.Aeson qualified as A +import Data.Aeson.Encoding qualified as E +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString qualified as BS +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Settei (Sensitivity (..)) +import Settei.Env (EnvName (..)) +import Settei.Preflight.Internal +import Settei.Prelude +import System.Environment qualified as Env + +-- No Show on any request-bearing type: callers must not log unresolved/raw inputs. + +-- | A version-one tooling request before secret-reference resolution. Inline values +-- must be public or fake stand-ins. No Show instance prevents accidental raw logging. +data PreflightRequest = PreflightRequest + { role :: !RoleLabel, + command :: !CheckCommand, + environment :: ![RequestEntry], + files :: ![RequestEntry], + inherit :: !(Maybe [EnvName]), + timeoutSeconds :: !Int, + exitCodes :: !ExitCodeMapping, + notes :: ![Text] + } + deriving stock (Generic, Eq) + +-- | A proposed environment/file name with exactly one value form. +data RequestEntry = RequestEntry {name :: !Text, form :: !EntryForm} deriving stock (Generic, Eq) + +-- | A public inline value, secret reference, fake synthetic value with sensitivity +-- and reason, unresolved input, or unavailable secret. Real secrets use references. +data EntryForm + = InlineValue !Text + | SecretFromEnvironment !EnvName + | SecretFromFile !FilePath + | SyntheticEntry !Sensitivity !Text !Text + | UnresolvedEntry !Text + | UnavailableSecretEntry !Text + deriving stock (Generic, Eq) + +-- | A safe schema path and fixed diagnostic, without input excerpts or values. +newtype RequestError = RequestError Text deriving stock (Generic, Eq, Show) + +-- | Render one safe request error without raw parser details. +renderRequestErrorText :: RequestError -> Text +renderRequestErrorText (RequestError t) = t + +-- | Render request errors in order, one per line. +renderRequestErrorsText :: NonEmpty RequestError -> Text +renderRequestErrorsText = T.unlines . fmap renderRequestErrorText . NE.toList + +-- | Construct a request with a 60-second timeout, default exit codes, no notes, +-- and the default inheritance policy. The runner validates the assembled proposal. +preflightRequest :: RoleLabel -> CheckCommand -> [RequestEntry] -> [RequestEntry] -> PreflightRequest +preflightRequest r c es fs = PreflightRequest r c es fs Nothing 60 defaultExitCodes [] + +-- A deliberately small closed-schema parser. Aeson's syntax/type errors are never retained. +type Parsed a = Either RequestError a + +bad :: Text -> Text -> Parsed a +bad path message = Left (RequestError (path <> ": " <> message)) + +objectAt :: Text -> [Text] -> A.Value -> Parsed A.Object +objectAt path allowed = \case + A.Object o -> if all ((`elem` allowed) . K.toText) (KM.keys o) then Right o else bad path "unknown key" + _ -> bad path "expected object" + +required :: Text -> A.Object -> Text -> Parsed A.Value +required path o key = maybe (bad (path <> "." <> key) "required field is missing") Right (KM.lookup (K.fromText key) o) + +textAt :: Text -> A.Value -> Parsed Text +textAt path = \case A.String t -> Right t; _ -> bad path "expected string" + +intAt :: Text -> A.Value -> Parsed Int +intAt path v = case A.fromJSON v of A.Success n -> Right n; A.Error _ -> bad path "expected integer" + +arrayAt :: Text -> (Text -> A.Value -> Parsed a) -> A.Value -> Parsed [a] +arrayAt path parse v = case A.fromJSON v of + A.Success values -> sequence [parse (path <> "[" <> tshow i <> "]") value | (i, value) <- zip [0 :: Int ..] values] + A.Error _ -> bad path "expected array" + +optional :: Text -> A.Object -> Text -> a -> (Text -> A.Value -> Parsed a) -> Parsed a +optional path o key fallback parse = maybe (Right fallback) (parse (path <> "." <> key)) (KM.lookup (K.fromText key) o) + +field :: Text -> A.Object -> Text -> (Text -> A.Value -> Parsed a) -> Parsed a +field path o key parse = required path o key >>= parse (path <> "." <> key) + +-- | Parse strict settei.preflight-request schema-version-1 UTF-8 JSON. Reject +-- unknown keys, conflicting forms, and unsupported versions without source excerpts. +-- Structural proposal validation still occurs at the runner boundary. +parsePreflightRequest :: BS.ByteString -> Either (NonEmpty RequestError) PreflightRequest +parsePreflightRequest bytes = case A.eitherDecodeStrict bytes of + Left _ -> Left (RequestError "request: invalid JSON" :| []) + Right value -> case parseRequest value of Left e -> Left (e :| []); Right request -> Right request + +parseRequest :: A.Value -> Parsed PreflightRequest +parseRequest value = do + let path = "request" + o <- objectAt path ["schemaVersion", "type", "role", "command", "environment", "files", "inherit", "timeoutSeconds", "exitCodes", "notes"] value + version <- field path o "schemaVersion" intAt + unless (version == 1) (bad "request.schemaVersion" "unsupported version") + typ <- field path o "type" textAt + unless (typ == "settei.preflight-request") (bad "request.type" "unexpected document type") + label <- field path o "role" textAt + unless (not (T.null (T.strip label))) (bad "request.role" "must not be empty") + cmd <- field path o "command" parseCommand + es <- field path o "environment" (\p -> arrayAt p parseEntry) + fs <- optional path o "files" [] (\p -> arrayAt p parseEntry) + inh <- case KM.lookup "inherit" o of Nothing -> Right Nothing; Just v -> Just <$> arrayAt "request.inherit" parseEnvName v + seconds <- optional path o "timeoutSeconds" 60 intAt + unless (seconds > 0 && seconds <= maxBound `div` 1000000) (bad "request.timeoutSeconds" "outside supported range") + codes <- optional path o "exitCodes" defaultExitCodes parseCodes + ns <- optional path o "notes" [] (\p -> arrayAt p textAt) + pure (PreflightRequest (RoleLabel label) cmd es fs inh seconds codes ns) + +parseEnvName :: Text -> A.Value -> Parsed EnvName +parseEnvName path v = do + n <- EnvName <$> textAt path v + if validEnvironmentName n then Right n else bad path "invalid environment variable name" + +parseCommand :: Text -> A.Value -> Parsed CheckCommand +parseCommand path value = do + o <- objectAt path ["executable", "arguments"] value + exe <- field path o "executable" textAt + args <- field path o "arguments" (\p -> arrayAt p parseArgument) + pure (CheckCommand (T.unpack exe) args) + +parseArgument :: Text -> A.Value -> Parsed Argument +parseArgument path value = do + o <- objectAt path ["literal", "file", "directory", "parts"] value + if KM.size o /= 1 + then bad path "expected exactly one argument form" + else case KM.lookup "parts" o of + Just v -> Argument <$> arrayAt (path <> ".parts") parsePart v + Nothing -> Argument . pure <$> parsePart path value + +parsePart :: Text -> A.Value -> Parsed ArgumentPart +parsePart path value = do + o <- objectAt path ["literal", "file", "directory"] value + if KM.size o /= 1 + then bad path "expected exactly one argument part" + else case () of + _ + | Just v <- KM.lookup "literal" o -> LiteralPart <$> textAt (path <> ".literal") v + | Just v <- KM.lookup "file" o -> FilePart . FileName <$> textAt (path <> ".file") v + | Just v <- KM.lookup "directory" o -> DirectoryPart . FileName <$> textAt (path <> ".directory") v + | otherwise -> bad path "expected argument part" + +parseEntry :: Text -> A.Value -> Parsed RequestEntry +parseEntry path value = do + o <- objectAt path ["name", "value", "secretFromEnvironment", "secretFromFile", "synthetic", "reason", "sensitivity", "unresolved", "unavailableSecret"] value + name <- field path o "name" textAt + let forms = [k | k <- ["value", "secretFromEnvironment", "secretFromFile", "synthetic", "unresolved", "unavailableSecret"], KM.member k o] + unless (length forms == 1) (bad path "expected exactly one value form") + entry <- case forms of + ["synthetic"] -> do + standin <- field path o "synthetic" textAt + reason <- field path o "reason" textAt + sensitivity <- optional path o "sensitivity" Public (\p v -> textAt p v >>= \case "public" -> Right Public; "secret" -> Right Secret; _ -> bad p "expected public or secret") + pure (SyntheticEntry sensitivity standin reason) + [k] -> do + unless (not (KM.member "reason" o || KM.member "sensitivity" o)) (bad path "reason and sensitivity require a synthetic entry; real secrets must use references") + case k of + "value" -> InlineValue <$> field path o "value" textAt + "secretFromEnvironment" -> SecretFromEnvironment <$> field path o "secretFromEnvironment" parseEnvName + "secretFromFile" -> SecretFromFile . T.unpack <$> field path o "secretFromFile" textAt + "unresolved" -> UnresolvedEntry <$> field path o "unresolved" textAt + _ -> UnavailableSecretEntry <$> field path o "unavailableSecret" textAt + _ -> bad path "expected value form" + pure (RequestEntry name entry) + +parseCodes :: Text -> A.Value -> Parsed ExitCodeMapping +parseCodes path value = do + o <- objectAt path ["accepted", "usage", "sourceFailure", "rejected"] value + codes <- ExitCodeMapping <$> field path o "accepted" intAt <*> field path o "usage" (\p -> arrayAt p intAt) <*> field path o "sourceFailure" (\p -> arrayAt p intAt) <*> field path o "rejected" (\p -> arrayAt p intAt) + if validExitCodes codes then Right codes else bad path "exit codes must be distinct integers in 0..255" + +-- | Serialize a request deterministically without resolving secret references. +-- Inline public/fake values are retained, so this is not a redaction or logging API. +renderPreflightRequestJson :: PreflightRequest -> Text +renderPreflightRequestJson r = + encodingText $ + obj $ + [("schemaVersion", json (1 :: Int)), ("type", json ("settei.preflight-request" :: Text)), ("role", json label), ("command", obj [("executable", json (r ^. #command . #executable)), ("arguments", E.list argumentJson (r ^. #command . #arguments))]), ("environment", E.list entryJson (r ^. #environment)), ("files", E.list entryJson (r ^. #files))] + <> maybe [] (\names -> [("inherit", json (fmap envText names))]) (r ^. #inherit) + <> [("timeoutSeconds", json (r ^. #timeoutSeconds)), ("exitCodes", obj [("accepted", json (codes ^. #accepted)), ("usage", json (codes ^. #usage)), ("sourceFailure", json (codes ^. #sourceFailure)), ("rejected", json (codes ^. #rejected))]), ("notes", json (r ^. #notes))] + where + RoleLabel label = r ^. #role + codes = r ^. #exitCodes + argumentJson (Argument [p]) = partJson p + argumentJson (Argument ps) = obj [("parts", E.list partJson ps)] + partJson = \case LiteralPart t -> obj [("literal", json t)]; FilePart n -> obj [("file", json (fileText n))]; DirectoryPart n -> obj [("directory", json (fileText n))] + entryJson e = + obj + ( [("name", json (e ^. #name))] <> case e ^. #form of + InlineValue t -> [("value", json t)] + SecretFromEnvironment n -> [("secretFromEnvironment", json (envText n))] + SecretFromFile p -> [("secretFromFile", json p)] + SyntheticEntry sensitivity t reason -> [("synthetic", json t), ("reason", json reason), ("sensitivity", json (case sensitivity of Public -> "public" :: Text; Secret -> "secret"))] + UnresolvedEntry t -> [("unresolved", json t)] + UnavailableSecretEntry t -> [("unavailableSecret", json t)] + ) + +-- | Injectable harness-side variable lookup and UTF-8 secret-file reads. +-- References do not imply inheritance into the checked child. +data RequestEnvironment = RequestEnvironment {lookupVariable :: !(EnvName -> IO (Maybe Text)), readSecretFile :: !(FilePath -> IO (Either Text Text))} deriving stock (Generic) + +-- | Resolved proposal and run options. It may contain real secrets and has no Show +-- instance; pass it to the runner rather than logging it. +data ResolvedRequest = ResolvedRequest {role :: !RoleLabel, command :: !CheckCommand, inputs :: !ProposedInputs, options :: !PreflightOptions} deriving stock (Generic, Eq) + +-- | Resolve against the harness process and working directory. Secret files use +-- strict UTF-8 without trimming; read failures become unavailable secret inputs. +processRequestEnvironment :: RequestEnvironment +processRequestEnvironment = + RequestEnvironment + (\(EnvName n) -> fmap T.pack <$> Env.lookupEnv (T.unpack n)) + (\p -> tryIO (BS.readFile p) >>= \case Left _ -> pure (Left "secret file could not be read"); Right bytes -> pure (case TE.decodeUtf8' bytes of Left _ -> Left "secret file is not UTF-8"; Right t -> Right t)) + +-- | Resolve references using the injected harness environment. Missing/unreadable +-- secrets remain unavailable inputs; public values and fake stand-ins retain their +-- classification. This neither runs the application nor proves complete coverage. +resolveRequest :: RequestEnvironment -> PreflightRequest -> IO ResolvedRequest +resolveRequest env r = do + es <- traverse (\e -> (EnvName (e ^. #name),) <$> resolve (e ^. #form)) (r ^. #environment) + fs <- traverse (\e -> ProposedFile (FileName (e ^. #name)) <$> resolve (e ^. #form)) (r ^. #files) + pure (ResolvedRequest (r ^. #role) (r ^. #command) (ProposedInputs es fs (maybe defaultInherited id (r ^. #inherit)) (r ^. #notes)) (PreflightOptions (r ^. #timeoutSeconds) (r ^. #exitCodes))) + where + resolve = \case + InlineValue t -> pure (SuppliedValue Public t) + SyntheticEntry sensitivity t reason -> pure (SyntheticValue sensitivity t reason) + UnresolvedEntry t -> pure (UnresolvedValue t) + UnavailableSecretEntry t -> pure (UnavailableSecret t) + SecretFromEnvironment n -> do + found <- if validEnvironmentName n then tryIO ((env ^. #lookupVariable) n) else pure (Right Nothing) + pure $ case found of Right (Just t) -> SuppliedValue Secret t; _ -> UnavailableSecret ("harness environment variable " <> envText n <> " is not set") + SecretFromFile path -> do + found <- tryIO ((env ^. #readSecretFile) path) + pure $ case found of Right (Right t) -> SuppliedValue Secret t; _ -> UnavailableSecret ("secret file " <> T.pack path <> " could not be read") diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Settei.Preflight.Fixture (fixtureMain) +import Settei.Preflight.RequestTest qualified as Request +import Settei.PreflightTest (tests) +import System.Environment (lookupEnv) +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = do + fixture <- lookupEnv "SETTEI_PREFLIGHT_FIXTURE" + case fixture of Just _ -> fixtureMain; Nothing -> defaultMain (testGroup "preflight" [tests, Request.tests]) diff --git a/test/Settei/Preflight/Fixture.hs b/test/Settei/Preflight/Fixture.hs new file mode 100644 --- /dev/null +++ b/test/Settei/Preflight/Fixture.hs @@ -0,0 +1,41 @@ +module Settei.Preflight.Fixture (fixtureMain) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_, when) +import Data.List (sort) +import Data.Text qualified +import Data.Text.IO qualified as T +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (getArgs, getEnvironment, lookupEnv) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hFlush, stderr, stdout) + +fixtureMain :: IO () +fixtureMain = do + args <- getArgs + behaviour <- lookupEnv "FIXTURE_BEHAVIOUR" + case behaviour of + Just "reject" -> die 4 "database.url: required value is missing" + Just "source-failure" -> die 3 "configuration file: could not be read" + Just "usage" -> die 2 "usage: fixture --check-config" + Just "crash" -> die 1 "unexpected failure" + Just "unicode" -> die 4 "runtime.environment: expected one of «dev»" + Just "sleep" -> getCurrentDirectory >>= putStrLn >> hFlush stdout >> threadDelay 30000000 + Just "chunks" -> do + putStr "SECRET-"; hFlush stdout; threadDelay 20000; putStrLn "ACROSS-CHUNKS" + Just "server-like" -> + if "--check-config" `elem` args + then putStrLn "configuration valid" + else do + marker <- lookupEnv "FIXTURE_STARTUP_MARKER" + forM_ marker (\path -> writeFile path "started") + putStrLn "ready" + Just "echo" -> do + env <- getEnvironment + forM_ (sort env) (\(n, v) -> putStrLn (n <> "=" <> v)) + forM_ args (\a -> T.hPutStrLn stderr (fromString a)) + forM_ args (\a -> do exists <- doesFileExist a; when exists (readFile a >>= putStr)) + _ -> putStrLn "configuration valid" + where + die n message = T.hPutStrLn stderr message >> exitWith (ExitFailure n) + fromString = Data.Text.pack diff --git a/test/Settei/Preflight/RequestTest.hs b/test/Settei/Preflight/RequestTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/Preflight/RequestTest.hs @@ -0,0 +1,168 @@ +module Settei.Preflight.RequestTest (tests) where + +import Control.Exception (bracket) +import Control.Monad (forM_) +import Data.Aeson qualified as A +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Generics.Labels () +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import Paths_settei_preflight qualified as Paths +import Settei (Sensitivity (..)) +import Settei.Env (EnvName (..)) +import Settei.Preflight +import Settei.Preflight.Request +import Settei.Prelude hiding (set) +import System.Environment qualified as Env +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +parse :: BS.ByteString -> IO PreflightRequest +parse bytes = case parsePreflightRequest bytes of Left e -> assertFailure (T.unpack (renderRequestErrorsText e)); Right r -> pure r + +fixtureRequest :: Text -> IO PreflightRequest +fixtureRequest behaviour = do + exe <- Env.getExecutablePath + pure (preflightRequest (RoleLabel "request-role") (CheckCommand exe []) [RequestEntry "SETTEI_PREFLIGHT_FIXTURE" (InlineValue "1"), RequestEntry "FIXTURE_BEHAVIOUR" (InlineValue behaviour)] []) + +runRequest :: PreflightRequest -> [String] -> IO (ExitCode, Text, Text) +runRequest request args = withSystemTempDirectory "request-cli" $ \root -> do + let path = root "request.json" + TIO.writeFile path (renderPreflightRequestJson request) + (code, out, err) <- readProcessWithExitCode "settei-preflight" (["--request", path] <> args) "" + pure (code, T.pack out, T.pack err) + +withEnv :: String -> String -> IO a -> IO a +withEnv n v action = bracket (Env.lookupEnv n <* Env.setEnv n v) (maybe (Env.unsetEnv n) (Env.setEnv n)) (const action) + +tests :: TestTree +tests = + testGroup + "Settei.Preflight.Request" + [ testCase "request golden covers every form, round-trips, and renders identically" $ do + bytes <- Paths.getDataFileName "test/golden/request.json" >>= BS.readFile + r <- parse bytes + renderPreflightRequestJson r @?= TE.decodeUtf8 bytes + reparsed <- parse (TE.encodeUtf8 (renderPreflightRequestJson r)) + assertBool "round-trip changed request" (r == reparsed) + resolved <- resolveRequest (RequestEnvironment (\(EnvName n) -> pure (if n == "PROVISIONED" then Just "SECRET-REFERENCE-SENTINEL" else Nothing)) (\p -> pure (if p == "available" then Right "FILE-SENTINEL\n" else Left "PRIVATE-ERROR"))) r + let values = fmap snd (resolved ^. #inputs . #environment) + assertBool "supplied public missing" (SuppliedValue Public "production" `elem` values) + assertBool "supplied secret missing" (SuppliedValue Secret "SECRET-REFERENCE-SENTINEL" `elem` values) + assertBool "synthetic secret missing" (SyntheticValue Secret "fake-credential" "test only" `elem` values) + assertBool "unresolved missing" (UnresolvedValue "resource output" `elem` values) + assertBool "unavailable reference missing" (UnavailableSecret "harness environment variable MISSING is not set" `elem` values) + assertBool "file bytes changed" (ProposedFile (FileName "secrets/token") (SuppliedValue Secret "FILE-SENTINEL\n") `elem` (resolved ^. #inputs . #files)) + resolved ^. #inputs . #notes @?= ["unsupported input"], + testCase "omitted optional fields retain documented defaults" $ do + r <- parse "{\"schemaVersion\":1,\"type\":\"settei.preflight-request\",\"role\":\"server\",\"command\":{\"executable\":\"/bin/true\",\"arguments\":[]},\"environment\":[]}" + resolved <- resolveRequest processRequestEnvironment r + resolved ^. #inputs . #inherited @?= defaultInherited + resolved ^. #options @?= defaultPreflightOptions, + testCase "secret files are strict UTF-8, preserve newlines, and hide IO details" $ withSystemTempDirectory "secret-files" $ \root -> do + let good = root "good"; invalid = root "invalid" + BS.writeFile good "exact\n\n" + BS.writeFile invalid (BS.pack [255, 254]) + r <- fixtureRequest "accept" + resolved <- resolveRequest processRequestEnvironment (r & #files .~ [RequestEntry "good" (SecretFromFile good), RequestEntry "invalid" (SecretFromFile invalid), RequestEntry "missing" (SecretFromFile (root "missing"))]) + case resolved ^. #inputs . #files of + [ProposedFile _ (SuppliedValue Secret t), ProposedFile _ (UnavailableSecret _), ProposedFile _ (UnavailableSecret _)] -> t @?= "exact\n\n" + _ -> assertFailure "incorrect secret-file resolution", + testGroup + "strict schema and secret-safe diagnostics" + [ testCase label $ do + let bytes = BL.toStrict (A.encode (mutation baseDocument)) + case parsePreflightRequest bytes of + Left ps -> do + let message = renderRequestErrorsText ps + assertBool (T.unpack message) (path `T.isInfixOf` message) + assertBool "parser leaked secret input" (not (sentinel `T.isInfixOf` message)) + Right _ -> assertFailure "invalid request accepted" + | (label, path, mutation) <- malformedCases + ], + testCase "syntax errors never retain Aeson diagnostics or input text" $ do + let bytes = "{\"schemaVersion\":1,\"SECRET-PARSER-SENTINEL\": INVALID}" + case parsePreflightRequest bytes of Left ps -> renderRequestErrorsText ps @?= "request: invalid JSON\n"; Right _ -> assertFailure "bad syntax accepted", + testGroup + "executable verdict mapping" + [ testCase label $ do + r <- fixtureRequest behaviour + (code, out, err) <- runRequest (modify r) args + code @?= expected + assertBool "expected verdict missing" (verdict `T.isInfixOf` out) + err @?= "" + | (label, behaviour, modify, args, expected, verdict) <- + [ ("pass", "accept", id, [], ExitSuccess, "pass"), + ("inconclusive", "accept", \r -> r & #environment %~ (<> [RequestEntry "GENERATED" (SyntheticEntry Public "fake" "not provisioned")]), [], ExitFailure 1, "inconclusive"), + ("rejected", "reject", id, [], ExitFailure 4, "fail"), + ("missing executable", "accept", \r -> r & #command .~ CheckCommand "/definitely/missing" [], [], ExitFailure 3, "executable not found"), + ("timeout", "sleep", \r -> r & #timeoutSeconds .~ 1, [], ExitFailure 3, "timed out"), + ("json", "accept", id, ["--json"], ExitSuccess, "{\"schemaVersion\":1,\"type\":\"settei.preflight\"") + ] + ], + testCase "missing and malformed request files exit 3 with safe stderr" $ do + (code, _, err) <- readProcessWithExitCode "settei-preflight" ["--request", "/definitely/missing"] "" + code @?= ExitFailure 3 + err @?= "request: file could not be read\n" + withSystemTempDirectory "malformed-cli" $ \root -> do + let path = root "bad.json" + writeFile path "{\"SECRET-PARSER-SENTINEL\": invalid}" + (badCode, out, badErr) <- readProcessWithExitCode "settei-preflight" ["--request", path] "" + badCode @?= ExitFailure 3 + out @?= "" + badErr @?= "request: invalid JSON\n", + testCase "usage and grouped help" $ do + (code, _, err) <- readProcessWithExitCode "settei-preflight" [] "" + code @?= ExitFailure 2 + assertBool "usage missing" ("Usage:" `T.isInfixOf` T.pack err) + (_, out, _) <- readProcessWithExitCode "settei-preflight" ["--help"] "" + forM_ ["\nPreflight\n", "\nOutput\n"] (\heading -> assertBool "option group missing" (heading `T.isInfixOf` T.pack out)), + testCase "real secret references never enter request, CLI reports, or invalid summaries" $ withEnv "EP28_PROVISIONED_SECRET" "CLI-SECRET-SENTINEL" $ do + r <- fixtureRequest "echo" + let secretRequest = r & #environment %~ (<> [RequestEntry "DATABASE_URL" (SecretFromEnvironment (EnvName "EP28_PROVISIONED_SECRET"))]) + assertBool "secret entered request" (not ("CLI-SECRET-SENTINEL" `T.isInfixOf` renderPreflightRequestJson secretRequest)) + forM_ [[], ["--json"]] $ \args -> do + (code, out, err) <- runRequest secretRequest args + code @?= ExitSuccess + assertBool "secret leaked from CLI" (not ("CLI-SECRET-SENTINEL" `T.isInfixOf` (out <> err))) + (invalidCode, invalidOut, invalidErr) <- runRequest (secretRequest & #command . #arguments .~ [literalArgument "CLI-SECRET-SENTINEL"]) args + invalidCode @?= ExitFailure 3 + assertBool "invalid command leaked" (not ("CLI-SECRET-SENTINEL" `T.isInfixOf` (invalidOut <> invalidErr))) + ] + +sentinel :: Text +sentinel = "SECRET-PARSER-SENTINEL" + +baseDocument :: A.Value +baseDocument = A.object ["schemaVersion" A..= (1 :: Int), "type" A..= ("settei.preflight-request" :: Text), "role" A..= ("server" :: Text), "command" A..= A.object ["executable" A..= ("/bin/true" :: Text), "arguments" A..= ([] :: [A.Value])], "environment" A..= [A.object ["name" A..= ("TOKEN" :: Text), "value" A..= sentinel]]] + +set :: A.Key -> A.Value -> A.Value -> A.Value +set k v (A.Object o) = A.Object (KM.insert k v o) +set _ _ v = v + +entry :: [(A.Key, A.Value)] -> A.Value -> A.Value +entry pairs = set "environment" (A.toJSON [A.Object (KM.fromList (("name", A.String "TOKEN") : pairs))]) + +malformedCases :: [(String, Text, A.Value -> A.Value)] +malformedCases = + [ ("inline secret", "environment[0]", entry [("value", A.String sentinel), ("sensitivity", A.String "secret")]), + ("multiple forms", "environment[0]", entry [("value", A.String sentinel), ("unresolved", A.String sentinel)]), + ("no form", "environment[0]", entry []), + ("unknown top key", "request", set "SECRET-PARSER-SENTINEL" (A.String sentinel)), + ("unknown entry key", "environment[0]", entry [("value", A.String sentinel), ("SECRET-PARSER-SENTINEL", A.String sentinel)]), + ("unknown command key", "command", set "command" (A.object ["SECRET-PARSER-SENTINEL" A..= sentinel])), + ("wrong type", "request.type", set "type" (A.String sentinel)), + ("wrong version", "schemaVersion", set "schemaVersion" (A.toJSON (2 :: Int))), + ("timeout zero", "timeoutSeconds", set "timeoutSeconds" (A.toJSON (0 :: Int))), + ("bad exit mapping", "exitCodes", set "exitCodes" (A.object ["accepted" A..= (0 :: Int), "usage" A..= [0 :: Int], "sourceFailure" A..= ([] :: [Int]), "rejected" A..= [4 :: Int]])), + ("bad secret reference name", "secretFromEnvironment", entry [("secretFromEnvironment", A.String sentinel)]), + ("missing synthetic reason", "reason", entry [("synthetic", A.String sentinel)]), + ("wrong value type", "value", entry [("value", A.toJSON (4 :: Int))]) + ] diff --git a/test/Settei/PreflightTest.hs b/test/Settei/PreflightTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/PreflightTest.hs @@ -0,0 +1,305 @@ +module Settei.PreflightTest (tests) where + +import Control.Concurrent (forkFinally, killThread, newEmptyMVar, putMVar, readMVar, tryPutMVar) +import Control.Exception (bracket, finally) +import Control.Monad (forM_) +import Data.ByteString qualified as BS +import Data.Generics.Labels () +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Paths_settei_preflight qualified as Paths +import Settei (Sensitivity (..)) +import Settei.Env (EnvName (..)) +import Settei.Preflight.Internal +import Settei.Prelude hiding (simple) +import System.Directory qualified as D +import System.Environment qualified as Env +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO qualified as IO +import System.IO.Temp (withSystemTempDirectory) +import System.Process qualified as Process +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +fixture :: Text -> [Argument] -> (ProposedInputs -> ProposedInputs) -> IO PreflightReport +fixture behaviour args modify = do + exe <- Env.getExecutablePath + runPreflight defaultPreflightOptions (RoleLabel "server") (CheckCommand exe args) (modify (fixtureInputs behaviour)) + +fixtureInputs :: Text -> ProposedInputs +fixtureInputs behaviour = emptyProposedInputs & #environment .~ [(EnvName "SETTEI_PREFLIGHT_FIXTURE", SuppliedValue Public "1"), (EnvName "FIXTURE_BEHAVIOUR", SuppliedValue Public behaviour)] + +withEnv :: String -> String -> IO a -> IO a +withEnv n v action = bracket (Env.lookupEnv n <* Env.setEnv n v) (maybe (Env.unsetEnv n) (Env.setEnv n)) (const action) + +noLeak :: Text -> PreflightReport -> Assertion +noLeak sentinel r = forM_ [renderPreflightReportText r, renderPreflightReportJson r, tshow r] $ \s -> assertBool "secret leaked" (not (sentinel `T.isInfixOf` s)) + +stdoutOf :: PreflightReport -> Text +stdoutOf = maybe "" (view #standardOutput) . view #execution + +stderrOf :: PreflightReport -> Text +stderrOf = maybe "" (view #standardError) . view #execution + +tests :: TestTree +tests = + testGroup + "Settei.Preflight" + [ testCase "accept with supplied inputs passes" $ do + r <- fixture "accept" [] id + r ^. #outcome @?= Accepted + r ^. #coverage @?= CompleteCoverage + r ^. #verdict @?= Pass + fmap (view #exitCode) (r ^. #execution) @?= Just (Just 0) + stdoutOf r @?= "configuration valid\n", + testGroup + "exit mapping" + [ testCase (T.unpack b) $ do + r <- fixture b [] id + r ^. #outcome @?= Rejected c n + r ^. #verdict @?= Fail + | (b, c, n) <- [("reject", ConfigurationRejected, 4), ("source-failure", SourceFailure, 3), ("usage", UsageError, 2), ("crash", UnknownExitCode, 1)] + ], + testGroup + "executable lookup" + [ testCase exe $ do + r <- runPreflight defaultPreflightOptions (RoleLabel "worker") (CheckCommand exe []) emptyProposedInputs + r ^. #outcome @?= NotRun (ExecutableNotFound exe) + r ^. #role @?= RoleLabel "worker" + r ^. #execution @?= Nothing + | exe <- ["/definitely/missing", "settei-no-such-executable-ep28"] + ], + testCase "relative executable is resolved before changing cwd" $ do + exe <- Env.getExecutablePath + cwd <- D.getCurrentDirectory + -- A relative symlink in a temporary directory still resolves from the harness cwd. + withSystemTempDirectory "preflight-relative" $ \root -> do + let link = root "fixture" + D.createFileLink exe link + relative <- D.makeRelativeToCurrentDirectory link + r <- runPreflight defaultPreflightOptions (RoleLabel "server") (CheckCommand (if '/' `elem` relative then relative else "./" <> relative) []) (fixtureInputs "accept") + r ^. #verdict @?= Pass + D.getCurrentDirectory >>= (@?= cwd), + testCase "nonexecutable file is spawn failure" $ withSystemTempDirectory "preflight-spawn" $ \root -> do + let path = root "not-executable" + writeFile path "not executable" + r <- runPreflight defaultPreflightOptions (RoleLabel "worker") (CheckCommand path []) emptyProposedInputs + case r ^. #outcome of NotRun (SpawnFailed _) -> pure (); _ -> assertFailure (show r), + testCase "timeout retains captured bytes and removes its own directory" $ do + exe <- Env.getExecutablePath + r <- runPreflight (defaultPreflightOptions & #timeoutSeconds .~ 1) (RoleLabel "server") (CheckCommand exe []) (fixtureInputs "sleep") + r ^. #outcome @?= NotRun (TimedOut 1) + assertBool "cwd missing from timed-out invocation" (not (T.null (stdoutOf r))) + D.doesDirectoryExist (T.unpack (T.strip (stdoutOf r))) >>= (@?= False), + testCase "environment is exactly proposed when inherit is empty" $ withEnv "PREFLIGHT_AMBIENT" "must-not-inherit" $ do + r <- fixture "echo" [] (\p -> p & #inherited .~ []) + -- CoreFoundation may synthesize this variable inside a macOS GHC process. + filter (not . T.isPrefixOf "__CF_USER_TEXT_ENCODING=") (T.lines (stdoutOf r)) @?= ["FIXTURE_BEHAVIOUR=echo", "SETTEI_PREFLIGHT_FIXTURE=1"] + native <- runPreflight defaultPreflightOptions (RoleLabel "native") (CheckCommand "/usr/bin/env" []) (emptyProposedInputs & #inherited .~ [] & #environment .~ [(EnvName "ONLY", SuppliedValue Public "proposed")]) + stdoutOf native @?= "ONLY=proposed\n", + testCase "explicit allowlist reports absent names" $ do + r <- fixture "echo" [] (\p -> p & #inherited .~ [EnvName "PATH", EnvName "PREFLIGHT_MISSING_EP28"]) + assertBool "PATH missing" ("PATH=" `T.isInfixOf` stdoutOf r) + r ^. #inherited @?= [(EnvName "PATH", True), (EnvName "PREFLIGHT_MISSING_EP28", False)], + testCase "environment and file secrets are redacted in every report form" $ do + r <- fixture "echo" [fileArgument (FileName "secrets/token")] $ \p -> + p + & #environment + %~ (<> [(EnvName "DATABASE_URL", SuppliedValue Secret "ENV-SECRET-SENTINEL")]) + & #files + .~ [ProposedFile (FileName "secrets/token") (SuppliedValue Secret "FILE-SECRET-SENTINEL")] + noLeak "ENV-SECRET-SENTINEL" r + noLeak "FILE-SECRET-SENTINEL" r + assertBool "environment marker" ("[redacted:DATABASE_URL]" `T.isInfixOf` stdoutOf r) + assertBool "file marker" ("[redacted:file secrets/token]" `T.isInfixOf` stdoutOf r), + testCase "materialized compound file and directory arguments retain symbolic summary" $ do + let name = FileName "etc/application.yaml" + r <- fixture "echo" [Argument [LiteralPart "yaml:", FilePart name], Argument [DirectoryPart (FileName "etc")], fileArgument name] $ \p -> p & #files .~ [ProposedFile name (SuppliedValue Public "server: example\n")] + assertBool "content not passed" ("server: example\n" `T.isInfixOf` stdoutOf r) + assertBool "compound path missing" ("yaml:/" `T.isInfixOf` stderrOf r) + r ^. #command . #arguments @?= ["yaml:{file:etc/application.yaml}", "{dir:etc}", "{file:etc/application.yaml}"], + testCase "omitted file absent but directory exists" $ do + r <- fixture "echo" [fileArgument (FileName "etc/missing"), Argument [DirectoryPart (FileName "etc")]] $ \p -> p & #files .~ [ProposedFile (FileName "etc/missing") (UnresolvedValue "not yet created")] + r ^. #verdict @?= Inconclusive + assertBool "omitted file passed" (not (any (\s -> s ^. #input == FileInput (FileName "etc/missing") && s ^. #passed) (r ^. #inputs))), + testCase "synthetic secret is partial and redacted" $ do + r <- fixture "echo" [] $ \p -> p & #environment %~ (<> [(EnvName "TOKEN", SyntheticValue Secret "FAKE-CREDENTIAL" "stand-in")]) + r ^. #verdict @?= Inconclusive + length (limitations (r ^. #coverage)) @?= 1 + noLeak "FAKE-CREDENTIAL" r, + testGroup + "omissions stay visible" + [ testCase (T.unpack b) $ do + r <- fixture b [] $ \p -> p & #environment %~ (<> [(EnvName "GENERATED", UnresolvedValue "resource output"), (EnvName "TOKEN", UnavailableSecret "not provisioned")]) + r ^. #verdict @?= expected + length (limitations (r ^. #coverage)) @?= 2 + length (filter (not . view #passed) (r ^. #inputs)) @?= 2 + | (b, expected) <- [("accept", Inconclusive), ("reject", Fail)] + ], + testCase "an extraction note alone prevents pass" $ do + r <- fixture "accept" [] (\p -> p & #notes .~ ["unsupported projected volume"]) + r ^. #verdict @?= Inconclusive + fmap (view #kind) (limitations (r ^. #coverage)) @?= [ExtractionIncomplete] + assertBool "honest explanation missing" ("not a deployment validation" `T.isInfixOf` renderPreflightReportJson r), + testCase "secret is redacted across flushed chunks" $ do + r <- fixture "chunks" [] (\p -> p & #environment %~ (<> [(EnvName "TOKEN", SuppliedValue Secret "SECRET-ACROSS-CHUNKS")])) + stdoutOf r @?= "[redacted:TOKEN]\n", + testCase "redaction uses longest original match and never rescans markers" $ do + redact [("LONG-SECRET", "[redacted:first]"), ("SECRET", "[redacted:second]"), ("first", "[redacted:third]")] "LONG-SECRET SECRET" @?= "[redacted:first] [redacted:second]", + testCase "secret-bearing names use numeric markers" $ do + r <- fixture "echo" [] (\p -> p & #environment %~ (<> [(EnvName "NAME_SENTINEL", SuppliedValue Secret "SENTINEL")])) + noLeak "SENTINEL" r + assertBool "numeric marker missing" ("[redacted:input 2]" `T.isInfixOf` stdoutOf r), + testCase "unicode diagnostic survives empty default locale context" $ do + r <- fixture "unicode" [] id + stderrOf r @?= "runtime.environment: expected one of «dev»\n", + testCase "server-like check skips startup and non-check control writes marker" $ withSystemTempDirectory "preflight-marker" $ \root -> do + let marker = root "started" + p x = x & #environment %~ (<> [(EnvName "FIXTURE_STARTUP_MARKER", SuppliedValue Public (T.pack marker))]) + checked <- fixture "server-like" [literalArgument "--check-config"] p + checked ^. #verdict @?= Pass + D.doesFileExist marker >>= (@?= False) + control <- fixture "server-like" [] p + control ^. #verdict @?= Pass + D.doesFileExist marker >>= (@?= True), + testGroup + "injectable IO failures" + [ testCase label $ do + exe <- Env.getExecutablePath + r <- runPreflightWith operations defaultPreflightOptions (RoleLabel "worker") (CheckCommand exe []) (fixtureInputs "accept") + r ^. #verdict @?= Fail + assertBool (show r) (predicate (r ^. #outcome)) + assertBool "upstream exception leaked" (not ("PRIVATE-EXCEPTION" `T.isInfixOf` tshow r)) + if label == "materialization" then assertBool "pre-spawn input marked passed" (all (not . view #passed) (r ^. #inputs)) else pure () + | (label, operations, predicate) <- + [ ("materialization", defaultRunOperations & #materializeInputs .~ (\_ _ _ -> ioError (userError "PRIVATE-EXCEPTION")), \case NotRun (MaterializationFailed _) -> True; _ -> False), + ("capture", defaultRunOperations & #captureOutput .~ (\_ -> ioError (userError "PRIVATE-EXCEPTION")), \case NotRun (CaptureFailed _) -> True; _ -> False), + ("cleanup", defaultRunOperations & #removeInputs .~ (\_ -> pure ()), \case NotRun (CleanupFailed _) -> True; _ -> False) + ] + ], + testCase "timeout includes draining after child exit and explicitly reaps pipe retainer" $ do + exe <- Env.getExecutablePath + retained <- newIORef Nothing + checked <- newIORef Nothing + let create process = do + (reader, writer) <- Process.createPipe + (mi, _, me, ph) <- Process.createProcess_ "preflight-pipe-test" (process {Process.std_out = Process.UseHandle writer}) + writeIORef checked (Just ph) + (_, _, _, retainer) <- Process.createProcess_ "preflight-pipe-retainer" ((Process.proc "/bin/sleep" ["30"]) {Process.std_in = Process.NoStream, Process.std_out = Process.UseHandle writer, Process.std_err = Process.NoStream}) + writeIORef retained (Just retainer) + IO.hClose writer + pure (mi, Just reader, me, ph) + reap = readIORef retained >>= mapM_ (\ph -> Process.terminateProcess ph >> Process.waitForProcess ph >> pure ()) + report <- runPreflightWith (defaultRunOperations & #createCheckProcess .~ create) (defaultPreflightOptions & #timeoutSeconds .~ 1) (RoleLabel "server") (CheckCommand exe []) (fixtureInputs "accept") `finally` reap + report ^. #outcome @?= NotRun (TimedOut 1) + child <- readIORef checked >>= maybe (fail "child not spawned") pure + Process.getProcessExitCode child >>= (@?= Just ExitSuccess) + retainer <- readIORef retained >>= maybe (fail "retainer not spawned") pure + status <- Process.getProcessExitCode retainer + assertBool "retainer was not reaped" (status /= Nothing), + testCase "asynchronous cancellation joins readers and removes private files" $ do + exe <- Env.getExecutablePath + rootReady <- newEmptyMVar + reading <- newEmptyMVar + done <- newEmptyMVar + let operations = + defaultRunOperations + & #materializeInputs + .~ (\root p cmd -> materialize root p cmd >> putMVar rootReady root) + & #captureOutput + .~ (\h -> do chunk <- BS.hGetSome h 32768; if BS.null chunk then pure () else tryPutMVar reading () >> pure (); pure chunk) + tid <- forkFinally (runPreflightWith operations defaultPreflightOptions (RoleLabel "server") (CheckCommand exe []) (fixtureInputs "sleep")) (putMVar done) + root <- readMVar rootReady + readMVar reading + killThread tid + completed <- timeout 5000000 (readMVar done) + assertBool "cancellation deadlocked" (case completed of Just (Left _) -> True; _ -> False) + D.doesPathExist root >>= (@?= False), + testCase "all retained metadata and omission reasons are redacted" $ do + exe <- Env.getExecutablePath + let secret = "META_SENTINEL" + inputs = + fixtureInputs "echo" + & #environment + %~ (<> [(EnvName "X_META_SENTINEL", SuppliedValue Secret secret), (EnvName "UNRESOLVED", UnresolvedValue ("missing " <> secret)), (EnvName "SYNTHETIC", SyntheticValue Public "dummy" ("fake " <> secret))]) + & #files + .~ [ProposedFile (FileName "files/META_SENTINEL") (UnavailableSecret ("file " <> secret))] + & #notes + .~ ["unsupported " <> secret] + report <- runPreflight defaultPreflightOptions (RoleLabel ("role " <> secret)) (CheckCommand exe []) inputs + report ^. #verdict @?= Inconclusive + noLeak secret report, + testCase "problem renderers escape invalid control characters on one line" $ do + let problem = InvalidEnvironmentName (EnvName "BAD\nNAME\r\t\0") + renderPreflightProblemText problem @?= "invalid-environment-name: BAD\\nNAME\\r\\t\\0" + length (T.lines (renderPreflightProblemsText (problem :| []))) @?= 1, + testGroup "validation" validationTests, + testGroup + "report goldens" + [ testCase name $ do + expected <- Paths.getDataFileName ("test/golden/" <> name) >>= TIO.readFile + actual @?= expected + actual @?= renderer report + | (base, report) <- [("fail", goldenFail), ("inconclusive", goldenInconclusive)], + (ext, renderer) <- [("txt", renderPreflightReportText), ("json", renderPreflightReportJson)], + let name = "report-" <> base <> "." <> ext, + let actual = renderer report + ] + ] + +validationTests :: [TestTree] +validationTests = + [ testCase label $ do + let result = validatePreflight chosenOptions chosenRole chosenCommand chosenInputs + case result of + Left ps -> assertBool (T.unpack (renderPreflightProblemsText ps)) (any ((== kind) . (\x -> let (k, _, _, _) = problemFields x in k)) (NE.toList ps)) + Right () -> assertFailure "invalid request accepted" + r <- runPreflight chosenOptions chosenRole chosenCommand chosenInputs + r ^. #execution @?= Nothing + assertBool "pre-spawn input marked passed" (all (not . view #passed) (r ^. #inputs)) + noLeak sentinel r + case result of Left ps -> assertBool "pure validation leaked" (not (sentinel `T.isInfixOf` tshow ps)); _ -> pure () + | (label, kind, chosenOptions, chosenRole, chosenCommand, chosenInputs) <- cases + ] + where + sentinel = "SECRET-SENTINEL" + opts = defaultPreflightOptions + role = RoleLabel "server" + cmd = CheckCommand "/bin/echo" [] + p = emptyProposedInputs & #environment .~ [(EnvName "TOKEN", SuppliedValue Secret sentinel)] + env n v = p & #environment %~ (<> [(EnvName n, v)]) + file n = ProposedFile (FileName n) (SuppliedValue Public "contents") + c label kind opt rol command input = (label, kind, opt, rol, command, input) + simple label kind input = c label kind opts role cmd input + cases = + [ simple "invalid name" "invalid-environment-name" (env "bad-name-SECRET-SENTINEL" (SuppliedValue Public "x")), + simple "duplicate env" "duplicate-environment-name" (env "TOKEN" (SuppliedValue Public "x")), + simple "NUL value" "invalid-environment-value" (env "BAD" (SuppliedValue Public "x\0")), + simple "invalid file" "invalid-file-name" (p & #files .~ [file "../SECRET-SENTINEL"]), + simple "duplicate file" "duplicate-file-name" (p & #files .~ [file "a", file "a"]), + simple "file parent collision" "file-path-conflict" (p & #files .~ [file "a/b", file "a"]), + simple "inherited invalid" "invalid-inherited-name" (p & #inherited .~ [EnvName "bad-name"]), + simple "inherited duplicate" "duplicate-inherited-name" (p & #inherited .~ [EnvName "PATH", EnvName "PATH"]), + simple "inherited proposed" "inherited-name-proposed" (p & #inherited .~ [EnvName "TOKEN"]), + c "unknown file" "unknown-file-reference" opts role (cmd & #arguments .~ [fileArgument (FileName "missing")]) p, + c "unknown dir" "unknown-file-reference" opts role (cmd & #arguments .~ [Argument [DirectoryPart (FileName "missing")]]) p, + c "secret argument" "secret-in-argument" opts role (cmd & #arguments .~ [literalArgument sentinel]) p, + c "split secret argument" "secret-in-argument" opts role (cmd & #arguments .~ [Argument [LiteralPart "SECRET-", LiteralPart "SENTINEL"]]) p, + c "secret executable" "secret-in-executable" opts role (CheckCommand (T.unpack sentinel) []) p, + c "empty executable" "invalid-executable" opts role (CheckCommand "" []) p, + c "NUL argument" "invalid-argument" opts role (cmd & #arguments .~ [literalArgument "\0"]) p, + c "invalid timeout" "invalid-timeout" (opts & #timeoutSeconds .~ 0) role cmd p, + c "overflow timeout" "invalid-timeout" (opts & #timeoutSeconds .~ maxBound) role cmd p, + c "overlapping codes" "invalid-exit-code-mapping" (opts & #exitCodes .~ ExitCodeMapping 0 [0] [] []) role cmd p, + c "out of range code" "invalid-exit-code-mapping" (opts & #exitCodes .~ ExitCodeMapping 256 [] [] []) role cmd p, + c "empty role" "empty-role-label" opts (RoleLabel " ") cmd p + ] + <> [simple ("invalid path " <> show n) "invalid-file-name" (p & #files .~ [file n]) | n <- ["", "/absolute", "a//b", "a/./b", "a/../b", "a\\b", "a\0b"]] + +goldenFail, goldenInconclusive :: PreflightReport +goldenFail = makeReport defaultPreflightOptions (RoleLabel "server") "/fixture" [] (emptyProposedInputs & #inherited .~ []) [] True (Right 4, Just (CapturedExecution (Just 4) False "" "database.url: required value is missing\n")) +goldenInconclusive = makeReport defaultPreflightOptions (RoleLabel "worker") "/fixture" [literalArgument "--check-config"] (emptyProposedInputs & #inherited .~ [] & #environment .~ [(EnvName "POD_NAMESPACE", SyntheticValue Public "production" "downward API namespace")]) [] True (Right 0, Just (CapturedExecution (Just 0) False "configuration valid\n" "")) diff --git a/test/golden/report-fail.json b/test/golden/report-fail.json new file mode 100644 --- /dev/null +++ b/test/golden/report-fail.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.preflight","role":"server","verdict":"fail","verdictExplanation":"configuration rejected, exit 4","outcome":{"kind":"rejected","category":"configuration-rejected","exitCode":4},"coverage":{"kind":"complete","limitations":[]},"inputs":[],"inherited":[],"notes":[],"command":{"executable":"/fixture","arguments":[]},"execution":{"exitCode":4,"timedOut":false,"stdout":"","stderr":"database.url: required value is missing\n"}} diff --git a/test/golden/report-fail.txt b/test/golden/report-fail.txt new file mode 100644 --- /dev/null +++ b/test/golden/report-fail.txt @@ -0,0 +1,9 @@ +preflight server: fail (configuration rejected, exit 4) +coverage: complete +inputs: (none) +inherited: (none) +command: /fixture +stdout: + (empty) +stderr: + database.url: required value is missing diff --git a/test/golden/report-inconclusive.json b/test/golden/report-inconclusive.json new file mode 100644 --- /dev/null +++ b/test/golden/report-inconclusive.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.preflight","role":"worker","verdict":"inconclusive","verdictExplanation":"accepted with partial coverage; not a deployment validation","outcome":{"kind":"accepted"},"coverage":{"kind":"partial","limitations":[{"channel":"environment","name":"POD_NAMESPACE","limitation":"synthetic-stand-in","reason":"downward API namespace"}]},"inputs":[{"channel":"environment","name":"POD_NAMESPACE","classification":"synthetic-public","passed":true}],"inherited":[],"notes":[],"command":{"executable":"/fixture","arguments":["--check-config"]},"execution":{"exitCode":0,"timedOut":false,"stdout":"configuration valid\n","stderr":""}} diff --git a/test/golden/report-inconclusive.txt b/test/golden/report-inconclusive.txt new file mode 100644 --- /dev/null +++ b/test/golden/report-inconclusive.txt @@ -0,0 +1,11 @@ +preflight worker: inconclusive (accepted with partial coverage; not a deployment validation) +coverage: partial + POD_NAMESPACE: synthetic stand-in (downward API namespace) +inputs: + POD_NAMESPACE: synthetic public +inherited: (none) +command: /fixture --check-config +stdout: + configuration valid +stderr: + (empty) diff --git a/test/golden/request.json b/test/golden/request.json new file mode 100644 --- /dev/null +++ b/test/golden/request.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.preflight-request","role":"server","command":{"executable":"/fixture","arguments":[{"literal":"--config"},{"file":"etc/application.yaml"},{"directory":"secrets"},{"parts":[{"literal":"yaml:"},{"file":"etc/application.yaml"}]}]},"environment":[{"name":"ENVIRONMENT","value":"production"},{"name":"TOKEN","secretFromEnvironment":"PROVISIONED"},{"name":"MISSING_TOKEN","secretFromEnvironment":"MISSING"},{"name":"FAKE","synthetic":"fake-credential","reason":"test only","sensitivity":"secret"},{"name":"GENERATED","unresolved":"resource output"},{"name":"UNAVAILABLE","unavailableSecret":"not provisioned"}],"files":[{"name":"etc/application.yaml","value":"server: example\n"},{"name":"secrets/token","secretFromFile":"available"},{"name":"secrets/missing","secretFromFile":"missing"}],"inherit":[],"timeoutSeconds":10,"exitCodes":{"accepted":0,"usage":[2],"sourceFailure":[3],"rejected":[4]},"notes":["unsupported input"]}